1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2017 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
38 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
39 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
40 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
42 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
43 doc
: /* Return the argument unchanged. */
50 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
51 doc
: /* Return a pseudo-random number.
52 All integers representable in Lisp, i.e. between `most-negative-fixnum'
53 and `most-positive-fixnum', inclusive, are equally likely.
55 With positive integer LIMIT, return random number in interval [0,LIMIT).
56 With argument t, set the random number seed from the system's entropy
57 pool if available, otherwise from less-random volatile data such as the time.
58 With a string argument, set the seed based on the string's contents.
59 Other values of LIMIT are ignored.
61 See Info node `(elisp)Random Numbers' for more details. */)
68 else if (STRINGP (limit
))
69 seed_random (SSDATA (limit
), SBYTES (limit
));
72 if (INTEGERP (limit
) && 0 < XINT (limit
))
75 /* Return the remainder, except reject the rare case where
76 get_random returns a number so close to INTMASK that the
77 remainder isn't random. */
78 EMACS_INT remainder
= val
% XINT (limit
);
79 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
80 return make_number (remainder
);
83 return make_number (val
);
86 /* Heuristic on how many iterations of a tight loop can be safely done
87 before it's time to do a quit. This must be a power of 2. It
88 is nice but not necessary for it to equal USHRT_MAX + 1. */
89 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
91 /* Process a quit, but do it only rarely, for efficiency. "Rarely"
92 means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 times,
93 whichever is smaller. Use *QUIT_COUNT to count this. */
96 rarely_quit (unsigned short int *quit_count
)
98 if (! (++*quit_count
& (QUIT_COUNT_HEURISTIC
- 1)))
102 /* Random data-structure functions. */
104 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
105 doc
: /* Return the length of vector, list or string SEQUENCE.
106 A byte-code function object is also allowed.
107 If the string contains multibyte characters, this is not necessarily
108 the number of bytes in the string; it is the number of characters.
109 To get the number of bytes, use `string-bytes'. */)
110 (register Lisp_Object sequence
)
112 register Lisp_Object val
;
114 if (STRINGP (sequence
))
115 XSETFASTINT (val
, SCHARS (sequence
));
116 else if (VECTORP (sequence
))
117 XSETFASTINT (val
, ASIZE (sequence
));
118 else if (CHAR_TABLE_P (sequence
))
119 XSETFASTINT (val
, MAX_CHAR
);
120 else if (BOOL_VECTOR_P (sequence
))
121 XSETFASTINT (val
, bool_vector_size (sequence
));
122 else if (COMPILEDP (sequence
))
123 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
124 else if (CONSP (sequence
))
131 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
133 if (MOST_POSITIVE_FIXNUM
< i
)
134 error ("List too long");
137 sequence
= XCDR (sequence
);
139 while (CONSP (sequence
));
141 CHECK_LIST_END (sequence
, sequence
);
143 val
= make_number (i
);
145 else if (NILP (sequence
))
146 XSETFASTINT (val
, 0);
148 wrong_type_argument (Qsequencep
, sequence
);
153 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
154 doc
: /* Return the length of a list, but avoid error or infinite loop.
155 This function never gets an error. If LIST is not really a list,
156 it returns 0. If LIST is circular, it returns a finite value
157 which is at least the number of distinct elements. */)
160 Lisp_Object tail
, halftail
;
165 return make_number (0);
167 /* halftail is used to detect circular lists. */
168 for (tail
= halftail
= list
; ; )
173 if (EQ (tail
, halftail
))
176 if ((lolen
& 1) == 0)
178 halftail
= XCDR (halftail
);
179 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
183 hilen
+= UINTMAX_MAX
+ 1.0;
188 /* If the length does not fit into a fixnum, return a float.
189 On all known practical machines this returns an upper bound on
191 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
194 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
195 doc
: /* Return the number of bytes in STRING.
196 If STRING is multibyte, this may be greater than the length of STRING. */)
199 CHECK_STRING (string
);
200 return make_number (SBYTES (string
));
203 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
204 doc
: /* Return t if two strings have identical contents.
205 Case is significant, but text properties are ignored.
206 Symbols are also allowed; their print names are used instead. */)
207 (register Lisp_Object s1
, Lisp_Object s2
)
210 s1
= SYMBOL_NAME (s1
);
212 s2
= SYMBOL_NAME (s2
);
216 if (SCHARS (s1
) != SCHARS (s2
)
217 || SBYTES (s1
) != SBYTES (s2
)
218 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
223 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
224 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
225 The arguments START1, END1, START2, and END2, if non-nil, are
226 positions specifying which parts of STR1 or STR2 to compare. In
227 string STR1, compare the part between START1 (inclusive) and END1
228 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
229 the string; if END1 is nil, it defaults to the length of the string.
230 Likewise, in string STR2, compare the part between START2 and END2.
231 Like in `substring', negative values are counted from the end.
233 The strings are compared by the numeric values of their characters.
234 For instance, STR1 is "less than" STR2 if its first differing
235 character has a smaller numeric value. If IGNORE-CASE is non-nil,
236 characters are converted to upper-case before comparing them. Unibyte
237 strings are converted to multibyte for comparison.
239 The value is t if the strings (or specified portions) match.
240 If string STR1 is less, the value is a negative number N;
241 - 1 - N is the number of characters that match at the beginning.
242 If string STR1 is greater, the value is a positive number N;
243 N - 1 is the number of characters that match at the beginning. */)
244 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
245 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
247 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
252 /* For backward compatibility, silently bring too-large positive end
253 values into range. */
254 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
255 end1
= make_number (SCHARS (str1
));
256 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
257 end2
= make_number (SCHARS (str2
));
259 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
260 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
265 i1_byte
= string_char_to_byte (str1
, i1
);
266 i2_byte
= string_char_to_byte (str2
, i2
);
268 while (i1
< to1
&& i2
< to2
)
270 /* When we find a mismatch, we must compare the
271 characters, not just the bytes. */
274 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
275 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
280 if (! NILP (ignore_case
))
282 c1
= XINT (Fupcase (make_number (c1
)));
283 c2
= XINT (Fupcase (make_number (c2
)));
289 /* Note that I1 has already been incremented
290 past the character that we are comparing;
291 hence we don't add or subtract 1 here. */
293 return make_number (- i1
+ from1
);
295 return make_number (i1
- from1
);
299 return make_number (i1
- from1
+ 1);
301 return make_number (- i1
+ from1
- 1);
306 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
307 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
309 Symbols are also allowed; their print names are used instead. */)
310 (register Lisp_Object string1
, Lisp_Object string2
)
312 register ptrdiff_t end
;
313 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
315 if (SYMBOLP (string1
))
316 string1
= SYMBOL_NAME (string1
);
317 if (SYMBOLP (string2
))
318 string2
= SYMBOL_NAME (string2
);
319 CHECK_STRING (string1
);
320 CHECK_STRING (string2
);
322 i1
= i1_byte
= i2
= i2_byte
= 0;
324 end
= SCHARS (string1
);
325 if (end
> SCHARS (string2
))
326 end
= SCHARS (string2
);
330 /* When we find a mismatch, we must compare the
331 characters, not just the bytes. */
334 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
335 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
338 return c1
< c2
? Qt
: Qnil
;
340 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
343 DEFUN ("string-version-lessp", Fstring_version_lessp
,
344 Sstring_version_lessp
, 2, 2, 0,
345 doc
: /* Return non-nil if S1 is less than S2, as version strings.
347 This function compares version strings S1 and S2:
348 1) By prefix lexicographically.
349 2) Then by version (similarly to version comparison of Debian's dpkg).
350 Leading zeros in version numbers are ignored.
351 3) If both prefix and version are equal, compare as ordinary strings.
353 For example, \"foo2.png\" compares less than \"foo12.png\".
355 Symbols are also allowed; their print names are used instead. */)
356 (Lisp_Object string1
, Lisp_Object string2
)
358 if (SYMBOLP (string1
))
359 string1
= SYMBOL_NAME (string1
);
360 if (SYMBOLP (string2
))
361 string2
= SYMBOL_NAME (string2
);
362 CHECK_STRING (string1
);
363 CHECK_STRING (string2
);
365 char *p1
= SSDATA (string1
);
366 char *p2
= SSDATA (string2
);
367 char *lim1
= p1
+ SBYTES (string1
);
368 char *lim2
= p2
+ SBYTES (string2
);
371 while ((cmp
= filevercmp (p1
, p2
)) == 0)
373 /* If the strings are identical through their first null bytes,
374 skip past identical prefixes and try again. */
375 ptrdiff_t size
= strlen (p1
) + 1;
379 return lim2
< p2
? Qnil
: Qt
;
384 return cmp
< 0 ? Qt
: Qnil
;
387 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
388 doc
: /* Return t if first arg string is less than second in collation order.
389 Symbols are also allowed; their print names are used instead.
391 This function obeys the conventions for collation order in your
392 locale settings. For example, punctuation and whitespace characters
393 might be considered less significant for sorting:
395 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
396 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
398 The optional argument LOCALE, a string, overrides the setting of your
399 current locale identifier for collation. The value is system
400 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
401 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
403 If IGNORE-CASE is non-nil, characters are converted to lower-case
404 before comparing them.
406 To emulate Unicode-compliant collation on MS-Windows systems,
407 bind `w32-collate-ignore-punctuation' to a non-nil value, since
408 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
410 If your system does not support a locale environment, this function
411 behaves like `string-lessp'. */)
412 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
414 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
415 /* Check parameters. */
417 s1
= SYMBOL_NAME (s1
);
419 s2
= SYMBOL_NAME (s2
);
423 CHECK_STRING (locale
);
425 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
427 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
428 return Fstring_lessp (s1
, s2
);
429 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
432 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
433 doc
: /* Return t if two strings have identical contents.
434 Symbols are also allowed; their print names are used instead.
436 This function obeys the conventions for collation order in your locale
437 settings. For example, characters with different coding points but
438 the same meaning might be considered as equal, like different grave
439 accent Unicode characters:
441 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
444 The optional argument LOCALE, a string, overrides the setting of your
445 current locale identifier for collation. The value is system
446 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
447 while it would be \"enu_USA.1252\" on MS Windows systems.
449 If IGNORE-CASE is non-nil, characters are converted to lower-case
450 before comparing them.
452 To emulate Unicode-compliant collation on MS-Windows systems,
453 bind `w32-collate-ignore-punctuation' to a non-nil value, since
454 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
456 If your system does not support a locale environment, this function
457 behaves like `string-equal'.
459 Do NOT use this function to compare file names for equality. */)
460 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
462 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
463 /* Check parameters. */
465 s1
= SYMBOL_NAME (s1
);
467 s2
= SYMBOL_NAME (s2
);
471 CHECK_STRING (locale
);
473 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
475 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
476 return Fstring_equal (s1
, s2
);
477 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
480 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
481 enum Lisp_Type target_type
, bool last_special
);
485 concat2 (Lisp_Object s1
, Lisp_Object s2
)
487 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
492 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
494 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
497 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
498 doc
: /* Concatenate all the arguments and make the result a list.
499 The result is a list whose elements are the elements of all the arguments.
500 Each argument may be a list, vector or string.
501 The last argument is not copied, just used as the tail of the new list.
502 usage: (append &rest SEQUENCES) */)
503 (ptrdiff_t nargs
, Lisp_Object
*args
)
505 return concat (nargs
, args
, Lisp_Cons
, 1);
508 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
509 doc
: /* Concatenate all the arguments and make the result a string.
510 The result is a string whose elements are the elements of all the arguments.
511 Each argument may be a string or a list or vector of characters (integers).
512 usage: (concat &rest SEQUENCES) */)
513 (ptrdiff_t nargs
, Lisp_Object
*args
)
515 return concat (nargs
, args
, Lisp_String
, 0);
518 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
519 doc
: /* Concatenate all the arguments and make the result a vector.
520 The result is a vector whose elements are the elements of all the arguments.
521 Each argument may be a list, vector or string.
522 usage: (vconcat &rest SEQUENCES) */)
523 (ptrdiff_t nargs
, Lisp_Object
*args
)
525 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
529 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
530 doc
: /* Return a copy of a list, vector, string or char-table.
531 The elements of a list or vector are not copied; they are shared
532 with the original. */)
535 if (NILP (arg
)) return arg
;
537 if (CHAR_TABLE_P (arg
))
539 return copy_char_table (arg
);
542 if (BOOL_VECTOR_P (arg
))
544 EMACS_INT nbits
= bool_vector_size (arg
);
545 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
546 Lisp_Object val
= make_uninit_bool_vector (nbits
);
547 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
551 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
552 wrong_type_argument (Qsequencep
, arg
);
554 return concat (1, &arg
, XTYPE (arg
), 0);
557 /* This structure holds information of an argument of `concat' that is
558 a string and has text properties to be copied. */
561 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
562 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
563 ptrdiff_t to
; /* refer to VAL (the target string) */
567 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
568 enum Lisp_Type target_type
, bool last_special
)
574 ptrdiff_t toindex_byte
= 0;
575 EMACS_INT result_len
;
576 EMACS_INT result_len_byte
;
578 Lisp_Object last_tail
;
581 /* When we make a multibyte string, we can't copy text properties
582 while concatenating each string because the length of resulting
583 string can't be decided until we finish the whole concatenation.
584 So, we record strings that have text properties to be copied
585 here, and copy the text properties after the concatenation. */
586 struct textprop_rec
*textprops
= NULL
;
587 /* Number of elements in textprops. */
588 ptrdiff_t num_textprops
= 0;
593 /* In append, the last arg isn't treated like the others */
594 if (last_special
&& nargs
> 0)
597 last_tail
= args
[nargs
];
602 /* Check each argument. */
603 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
607 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
608 wrong_type_argument (Qsequencep
, this);
611 /* Compute total length in chars of arguments in RESULT_LEN.
612 If desired output is a string, also compute length in bytes
613 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
614 whether the result should be a multibyte string. */
618 for (argnum
= 0; argnum
< nargs
; argnum
++)
622 len
= XFASTINT (Flength (this));
623 if (target_type
== Lisp_String
)
625 /* We must count the number of bytes needed in the string
626 as well as the number of characters. */
630 ptrdiff_t this_len_byte
;
632 if (VECTORP (this) || COMPILEDP (this))
633 for (i
= 0; i
< len
; i
++)
636 CHECK_CHARACTER (ch
);
638 this_len_byte
= CHAR_BYTES (c
);
639 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
641 result_len_byte
+= this_len_byte
;
642 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
645 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
646 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
647 else if (CONSP (this))
648 for (; CONSP (this); this = XCDR (this))
651 CHECK_CHARACTER (ch
);
653 this_len_byte
= CHAR_BYTES (c
);
654 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
656 result_len_byte
+= this_len_byte
;
657 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
660 else if (STRINGP (this))
662 if (STRING_MULTIBYTE (this))
665 this_len_byte
= SBYTES (this);
668 this_len_byte
= count_size_as_multibyte (SDATA (this),
670 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
672 result_len_byte
+= this_len_byte
;
677 if (MOST_POSITIVE_FIXNUM
< result_len
)
678 memory_full (SIZE_MAX
);
681 if (! some_multibyte
)
682 result_len_byte
= result_len
;
684 /* Create the output object. */
685 if (target_type
== Lisp_Cons
)
686 val
= Fmake_list (make_number (result_len
), Qnil
);
687 else if (target_type
== Lisp_Vectorlike
)
688 val
= Fmake_vector (make_number (result_len
), Qnil
);
689 else if (some_multibyte
)
690 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
692 val
= make_uninit_string (result_len
);
694 /* In `append', if all but last arg are nil, return last arg. */
695 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
698 /* Copy the contents of the args into the result. */
700 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
702 toindex
= 0, toindex_byte
= 0;
706 SAFE_NALLOCA (textprops
, 1, nargs
);
708 for (argnum
= 0; argnum
< nargs
; argnum
++)
711 ptrdiff_t thisleni
= 0;
712 register ptrdiff_t thisindex
= 0;
713 register ptrdiff_t thisindex_byte
= 0;
717 thislen
= Flength (this), thisleni
= XINT (thislen
);
719 /* Between strings of the same kind, copy fast. */
720 if (STRINGP (this) && STRINGP (val
)
721 && STRING_MULTIBYTE (this) == some_multibyte
)
723 ptrdiff_t thislen_byte
= SBYTES (this);
725 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
726 if (string_intervals (this))
728 textprops
[num_textprops
].argnum
= argnum
;
729 textprops
[num_textprops
].from
= 0;
730 textprops
[num_textprops
++].to
= toindex
;
732 toindex_byte
+= thislen_byte
;
735 /* Copy a single-byte string to a multibyte string. */
736 else if (STRINGP (this) && STRINGP (val
))
738 if (string_intervals (this))
740 textprops
[num_textprops
].argnum
= argnum
;
741 textprops
[num_textprops
].from
= 0;
742 textprops
[num_textprops
++].to
= toindex
;
744 toindex_byte
+= copy_text (SDATA (this),
745 SDATA (val
) + toindex_byte
,
746 SCHARS (this), 0, 1);
750 /* Copy element by element. */
753 register Lisp_Object elt
;
755 /* Fetch next element of `this' arg into `elt', or break if
756 `this' is exhausted. */
757 if (NILP (this)) break;
759 elt
= XCAR (this), this = XCDR (this);
760 else if (thisindex
>= thisleni
)
762 else if (STRINGP (this))
765 if (STRING_MULTIBYTE (this))
766 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
771 c
= SREF (this, thisindex
); thisindex
++;
772 if (some_multibyte
&& !ASCII_CHAR_P (c
))
773 c
= BYTE8_TO_CHAR (c
);
775 XSETFASTINT (elt
, c
);
777 else if (BOOL_VECTOR_P (this))
779 elt
= bool_vector_ref (this, thisindex
);
784 elt
= AREF (this, thisindex
);
788 /* Store this element into the result. */
795 else if (VECTORP (val
))
797 ASET (val
, toindex
, elt
);
803 CHECK_CHARACTER (elt
);
806 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
808 SSET (val
, toindex_byte
++, c
);
814 XSETCDR (prev
, last_tail
);
816 if (num_textprops
> 0)
819 ptrdiff_t last_to_end
= -1;
821 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
823 this = args
[textprops
[argnum
].argnum
];
824 props
= text_property_list (this,
826 make_number (SCHARS (this)),
828 /* If successive arguments have properties, be sure that the
829 value of `composition' property be the copy. */
830 if (last_to_end
== textprops
[argnum
].to
)
831 make_composition_value_copy (props
);
832 add_text_properties_from_list (val
, props
,
833 make_number (textprops
[argnum
].to
));
834 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
842 static Lisp_Object string_char_byte_cache_string
;
843 static ptrdiff_t string_char_byte_cache_charpos
;
844 static ptrdiff_t string_char_byte_cache_bytepos
;
847 clear_string_char_byte_cache (void)
849 string_char_byte_cache_string
= Qnil
;
852 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
855 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
858 ptrdiff_t best_below
, best_below_byte
;
859 ptrdiff_t best_above
, best_above_byte
;
861 best_below
= best_below_byte
= 0;
862 best_above
= SCHARS (string
);
863 best_above_byte
= SBYTES (string
);
864 if (best_above
== best_above_byte
)
867 if (EQ (string
, string_char_byte_cache_string
))
869 if (string_char_byte_cache_charpos
< char_index
)
871 best_below
= string_char_byte_cache_charpos
;
872 best_below_byte
= string_char_byte_cache_bytepos
;
876 best_above
= string_char_byte_cache_charpos
;
877 best_above_byte
= string_char_byte_cache_bytepos
;
881 if (char_index
- best_below
< best_above
- char_index
)
883 unsigned char *p
= SDATA (string
) + best_below_byte
;
885 while (best_below
< char_index
)
887 p
+= BYTES_BY_CHAR_HEAD (*p
);
890 i_byte
= p
- SDATA (string
);
894 unsigned char *p
= SDATA (string
) + best_above_byte
;
896 while (best_above
> char_index
)
899 while (!CHAR_HEAD_P (*p
)) p
--;
902 i_byte
= p
- SDATA (string
);
905 string_char_byte_cache_bytepos
= i_byte
;
906 string_char_byte_cache_charpos
= char_index
;
907 string_char_byte_cache_string
= string
;
912 /* Return the character index corresponding to BYTE_INDEX in STRING. */
915 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
918 ptrdiff_t best_below
, best_below_byte
;
919 ptrdiff_t best_above
, best_above_byte
;
921 best_below
= best_below_byte
= 0;
922 best_above
= SCHARS (string
);
923 best_above_byte
= SBYTES (string
);
924 if (best_above
== best_above_byte
)
927 if (EQ (string
, string_char_byte_cache_string
))
929 if (string_char_byte_cache_bytepos
< byte_index
)
931 best_below
= string_char_byte_cache_charpos
;
932 best_below_byte
= string_char_byte_cache_bytepos
;
936 best_above
= string_char_byte_cache_charpos
;
937 best_above_byte
= string_char_byte_cache_bytepos
;
941 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
943 unsigned char *p
= SDATA (string
) + best_below_byte
;
944 unsigned char *pend
= SDATA (string
) + byte_index
;
948 p
+= BYTES_BY_CHAR_HEAD (*p
);
952 i_byte
= p
- SDATA (string
);
956 unsigned char *p
= SDATA (string
) + best_above_byte
;
957 unsigned char *pbeg
= SDATA (string
) + byte_index
;
962 while (!CHAR_HEAD_P (*p
)) p
--;
966 i_byte
= p
- SDATA (string
);
969 string_char_byte_cache_bytepos
= i_byte
;
970 string_char_byte_cache_charpos
= i
;
971 string_char_byte_cache_string
= string
;
976 /* Convert STRING to a multibyte string. */
979 string_make_multibyte (Lisp_Object string
)
986 if (STRING_MULTIBYTE (string
))
989 nbytes
= count_size_as_multibyte (SDATA (string
),
991 /* If all the chars are ASCII, they won't need any more bytes
992 once converted. In that case, we can return STRING itself. */
993 if (nbytes
== SBYTES (string
))
996 buf
= SAFE_ALLOCA (nbytes
);
997 copy_text (SDATA (string
), buf
, SBYTES (string
),
1000 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1007 /* Convert STRING (if unibyte) to a multibyte string without changing
1008 the number of characters. Characters 0200 trough 0237 are
1009 converted to eight-bit characters. */
1012 string_to_multibyte (Lisp_Object string
)
1019 if (STRING_MULTIBYTE (string
))
1022 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1023 /* If all the chars are ASCII, they won't need any more bytes once
1025 if (nbytes
== SBYTES (string
))
1026 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1028 buf
= SAFE_ALLOCA (nbytes
);
1029 memcpy (buf
, SDATA (string
), SBYTES (string
));
1030 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1032 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1039 /* Convert STRING to a single-byte string. */
1042 string_make_unibyte (Lisp_Object string
)
1049 if (! STRING_MULTIBYTE (string
))
1052 nchars
= SCHARS (string
);
1054 buf
= SAFE_ALLOCA (nchars
);
1055 copy_text (SDATA (string
), buf
, SBYTES (string
),
1058 ret
= make_unibyte_string ((char *) buf
, nchars
);
1064 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1066 doc
: /* Return the multibyte equivalent of STRING.
1067 If STRING is unibyte and contains non-ASCII characters, the function
1068 `unibyte-char-to-multibyte' is used to convert each unibyte character
1069 to a multibyte character. In this case, the returned string is a
1070 newly created string with no text properties. If STRING is multibyte
1071 or entirely ASCII, it is returned unchanged. In particular, when
1072 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1073 \(When the characters are all ASCII, Emacs primitives will treat the
1074 string the same way whether it is unibyte or multibyte.) */)
1075 (Lisp_Object string
)
1077 CHECK_STRING (string
);
1079 return string_make_multibyte (string
);
1082 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1084 doc
: /* Return the unibyte equivalent of STRING.
1085 Multibyte character codes are converted to unibyte according to
1086 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1087 If the lookup in the translation table fails, this function takes just
1088 the low 8 bits of each character. */)
1089 (Lisp_Object string
)
1091 CHECK_STRING (string
);
1093 return string_make_unibyte (string
);
1096 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1098 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1099 If STRING is unibyte, the result is STRING itself.
1100 Otherwise it is a newly created string, with no text properties.
1101 If STRING is multibyte and contains a character of charset
1102 `eight-bit', it is converted to the corresponding single byte. */)
1103 (Lisp_Object string
)
1105 CHECK_STRING (string
);
1107 if (STRING_MULTIBYTE (string
))
1109 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1110 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1112 string
= make_unibyte_string ((char *) str
, bytes
);
1118 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1120 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1121 If STRING is multibyte, the result is STRING itself.
1122 Otherwise it is a newly created string, with no text properties.
1124 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1125 part of a correct utf-8 sequence), it is converted to the corresponding
1126 multibyte character of charset `eight-bit'.
1127 See also `string-to-multibyte'.
1129 Beware, this often doesn't really do what you think it does.
1130 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1131 If you're not sure, whether to use `string-as-multibyte' or
1132 `string-to-multibyte', use `string-to-multibyte'. */)
1133 (Lisp_Object string
)
1135 CHECK_STRING (string
);
1137 if (! STRING_MULTIBYTE (string
))
1139 Lisp_Object new_string
;
1140 ptrdiff_t nchars
, nbytes
;
1142 parse_str_as_multibyte (SDATA (string
),
1145 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1146 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1147 if (nbytes
!= SBYTES (string
))
1148 str_as_multibyte (SDATA (new_string
), nbytes
,
1149 SBYTES (string
), NULL
);
1150 string
= new_string
;
1151 set_string_intervals (string
, NULL
);
1156 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1158 doc
: /* Return a multibyte string with the same individual chars as STRING.
1159 If STRING is multibyte, the result is STRING itself.
1160 Otherwise it is a newly created string, with no text properties.
1162 If STRING is unibyte and contains an 8-bit byte, it is converted to
1163 the corresponding multibyte character of charset `eight-bit'.
1165 This differs from `string-as-multibyte' by converting each byte of a correct
1166 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1167 correct sequence. */)
1168 (Lisp_Object string
)
1170 CHECK_STRING (string
);
1172 return string_to_multibyte (string
);
1175 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1177 doc
: /* Return a unibyte string with the same individual chars as STRING.
1178 If STRING is unibyte, the result is STRING itself.
1179 Otherwise it is a newly created string, with no text properties,
1180 where each `eight-bit' character is converted to the corresponding byte.
1181 If STRING contains a non-ASCII, non-`eight-bit' character,
1182 an error is signaled. */)
1183 (Lisp_Object string
)
1185 CHECK_STRING (string
);
1187 if (STRING_MULTIBYTE (string
))
1189 ptrdiff_t chars
= SCHARS (string
);
1190 unsigned char *str
= xmalloc (chars
);
1191 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1193 if (converted
< chars
)
1194 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1195 string
= make_unibyte_string ((char *) str
, chars
);
1202 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1203 doc
: /* Return a copy of ALIST.
1204 This is an alist which represents the same mapping from objects to objects,
1205 but does not share the alist structure with ALIST.
1206 The objects mapped (cars and cdrs of elements of the alist)
1207 are shared, however.
1208 Elements of ALIST that are not conses are also shared. */)
1213 alist
= concat (1, &alist
, Lisp_Cons
, false);
1214 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1216 Lisp_Object car
= XCAR (tem
);
1218 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1223 /* Check that ARRAY can have a valid subarray [FROM..TO),
1224 given that its size is SIZE.
1225 If FROM is nil, use 0; if TO is nil, use SIZE.
1226 Count negative values backwards from the end.
1227 Set *IFROM and *ITO to the two indexes used. */
1230 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1231 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1235 if (INTEGERP (from
))
1241 else if (NILP (from
))
1244 wrong_type_argument (Qintegerp
, from
);
1255 wrong_type_argument (Qintegerp
, to
);
1257 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1258 args_out_of_range_3 (array
, from
, to
);
1264 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1265 doc
: /* Return a new string whose contents are a substring of STRING.
1266 The returned string consists of the characters between index FROM
1267 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1268 zero-indexed: 0 means the first character of STRING. Negative values
1269 are counted from the end of STRING. If TO is nil, the substring runs
1270 to the end of STRING.
1272 The STRING argument may also be a vector. In that case, the return
1273 value is a new vector that contains the elements between index FROM
1274 \(inclusive) and index TO (exclusive) of that vector argument.
1276 With one argument, just copy STRING (with properties, if any). */)
1277 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1280 ptrdiff_t size
, ifrom
, ito
;
1282 size
= CHECK_VECTOR_OR_STRING (string
);
1283 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1285 if (STRINGP (string
))
1288 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1290 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1291 res
= make_specified_string (SSDATA (string
) + from_byte
,
1292 ito
- ifrom
, to_byte
- from_byte
,
1293 STRING_MULTIBYTE (string
));
1294 copy_text_properties (make_number (ifrom
), make_number (ito
),
1295 string
, make_number (0), res
, Qnil
);
1298 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1304 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1305 doc
: /* Return a substring of STRING, without text properties.
1306 It starts at index FROM and ends before TO.
1307 TO may be nil or omitted; then the substring runs to the end of STRING.
1308 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1309 If FROM or TO is negative, it counts from the end.
1311 With one argument, just copy STRING without its properties. */)
1312 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1314 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1316 CHECK_STRING (string
);
1318 size
= SCHARS (string
);
1319 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1321 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1323 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1324 return make_specified_string (SSDATA (string
) + from_byte
,
1325 to_char
- from_char
, to_byte
- from_byte
,
1326 STRING_MULTIBYTE (string
));
1329 /* Extract a substring of STRING, giving start and end positions
1330 both in characters and in bytes. */
1333 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1334 ptrdiff_t to
, ptrdiff_t to_byte
)
1337 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1339 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1340 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1342 if (STRINGP (string
))
1344 res
= make_specified_string (SSDATA (string
) + from_byte
,
1345 to
- from
, to_byte
- from_byte
,
1346 STRING_MULTIBYTE (string
));
1347 copy_text_properties (make_number (from
), make_number (to
),
1348 string
, make_number (0), res
, Qnil
);
1351 res
= Fvector (to
- from
, aref_addr (string
, from
));
1356 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1357 doc
: /* Take cdr N times on LIST, return the result. */)
1358 (Lisp_Object n
, Lisp_Object list
)
1361 EMACS_INT num
= XINT (n
);
1362 Lisp_Object tail
= list
;
1363 immediate_quit
= true;
1364 for (EMACS_INT i
= 0; i
< num
; i
++)
1368 immediate_quit
= false;
1369 CHECK_LIST_END (tail
, list
);
1374 immediate_quit
= false;
1378 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1379 doc
: /* Return the Nth element of LIST.
1380 N counts from zero. If LIST is not that long, nil is returned. */)
1381 (Lisp_Object n
, Lisp_Object list
)
1383 return Fcar (Fnthcdr (n
, list
));
1386 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1387 doc
: /* Return element of SEQUENCE at index N. */)
1388 (register Lisp_Object sequence
, Lisp_Object n
)
1391 if (CONSP (sequence
) || NILP (sequence
))
1392 return Fcar (Fnthcdr (n
, sequence
));
1394 /* Faref signals a "not array" error, so check here. */
1395 CHECK_ARRAY (sequence
, Qsequencep
);
1396 return Faref (sequence
, n
);
1399 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1400 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1401 The value is actually the tail of LIST whose car is ELT. */)
1402 (Lisp_Object elt
, Lisp_Object list
)
1404 unsigned short int quit_count
= 0;
1406 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1408 if (! NILP (Fequal (elt
, XCAR (tail
))))
1410 rarely_quit (&quit_count
);
1412 CHECK_LIST_END (tail
, list
);
1416 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1417 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1418 The value is actually the tail of LIST whose car is ELT. */)
1419 (Lisp_Object elt
, Lisp_Object list
)
1421 immediate_quit
= true;
1423 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1425 if (EQ (XCAR (tail
), elt
))
1427 immediate_quit
= false;
1431 immediate_quit
= false;
1432 CHECK_LIST_END (tail
, list
);
1436 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1437 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1438 The value is actually the tail of LIST whose car is ELT. */)
1439 (Lisp_Object elt
, Lisp_Object list
)
1442 return Fmemq (elt
, list
);
1444 immediate_quit
= true;
1446 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1448 Lisp_Object tem
= XCAR (tail
);
1449 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1451 immediate_quit
= false;
1455 immediate_quit
= false;
1456 CHECK_LIST_END (tail
, list
);
1460 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1461 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1462 The value is actually the first element of LIST whose car is KEY.
1463 Elements of LIST that are not conses are ignored. */)
1464 (Lisp_Object key
, Lisp_Object list
)
1466 immediate_quit
= true;
1468 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1469 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1471 immediate_quit
= false;
1474 immediate_quit
= true;
1475 CHECK_LIST_END (tail
, list
);
1479 /* Like Fassq but never report an error and do not allow quits.
1480 Use only on objects known to be non-circular lists. */
1483 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1485 for (; ! NILP (list
); list
= XCDR (list
))
1486 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1491 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1492 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1493 The value is actually the first element of LIST whose car equals KEY. */)
1494 (Lisp_Object key
, Lisp_Object list
)
1496 unsigned short int quit_count
= 0;
1498 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1500 Lisp_Object car
= XCAR (tail
);
1502 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1504 rarely_quit (&quit_count
);
1506 CHECK_LIST_END (tail
, list
);
1510 /* Like Fassoc but never report an error and do not allow quits.
1511 Use only on objects known to be non-circular lists. */
1514 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1516 for (; ! NILP (list
); list
= XCDR (list
))
1518 Lisp_Object car
= XCAR (list
);
1520 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1526 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1527 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1528 The value is actually the first element of LIST whose cdr is KEY. */)
1529 (Lisp_Object key
, Lisp_Object list
)
1531 immediate_quit
= true;
1533 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1534 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1536 immediate_quit
= false;
1539 immediate_quit
= true;
1540 CHECK_LIST_END (tail
, list
);
1544 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1545 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1546 The value is actually the first element of LIST whose cdr equals KEY. */)
1547 (Lisp_Object key
, Lisp_Object list
)
1549 unsigned short int quit_count
= 0;
1551 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1553 Lisp_Object car
= XCAR (tail
);
1555 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1557 rarely_quit (&quit_count
);
1559 CHECK_LIST_END (tail
, list
);
1563 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1564 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1565 More precisely, this function skips any members `eq' to ELT at the
1566 front of LIST, then removes members `eq' to ELT from the remaining
1567 sublist by modifying its list structure, then returns the resulting
1570 Write `(setq foo (delq element foo))' to be sure of correctly changing
1571 the value of a list `foo'. See also `remq', which does not modify the
1573 (register Lisp_Object elt
, Lisp_Object list
)
1575 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1578 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1580 Lisp_Object tem
= XCAR (tail
);
1586 Fsetcdr (prev
, XCDR (tail
));
1594 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1595 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1596 SEQ must be a sequence (i.e. a list, a vector, or a string).
1597 The return value is a sequence of the same type.
1599 If SEQ is a list, this behaves like `delq', except that it compares
1600 with `equal' instead of `eq'. In particular, it may remove elements
1601 by altering the list structure.
1603 If SEQ is not a list, deletion is never performed destructively;
1604 instead this function creates and returns a new vector or string.
1606 Write `(setq foo (delete element foo))' to be sure of correctly
1607 changing the value of a sequence `foo'. */)
1608 (Lisp_Object elt
, Lisp_Object seq
)
1614 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1615 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1618 if (n
!= ASIZE (seq
))
1620 struct Lisp_Vector
*p
= allocate_vector (n
);
1622 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1623 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1624 p
->contents
[n
++] = AREF (seq
, i
);
1626 XSETVECTOR (seq
, p
);
1629 else if (STRINGP (seq
))
1631 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1634 for (i
= nchars
= nbytes
= ibyte
= 0;
1636 ++i
, ibyte
+= cbytes
)
1638 if (STRING_MULTIBYTE (seq
))
1640 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1641 cbytes
= CHAR_BYTES (c
);
1649 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1656 if (nchars
!= SCHARS (seq
))
1660 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1661 if (!STRING_MULTIBYTE (seq
))
1662 STRING_SET_UNIBYTE (tem
);
1664 for (i
= nchars
= nbytes
= ibyte
= 0;
1666 ++i
, ibyte
+= cbytes
)
1668 if (STRING_MULTIBYTE (seq
))
1670 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1671 cbytes
= CHAR_BYTES (c
);
1679 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1681 unsigned char *from
= SDATA (seq
) + ibyte
;
1682 unsigned char *to
= SDATA (tem
) + nbytes
;
1688 for (n
= cbytes
; n
--; )
1698 unsigned short int quit_count
= 0;
1699 Lisp_Object tail
, prev
;
1701 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1703 if (!NILP (Fequal (elt
, XCAR (tail
))))
1708 Fsetcdr (prev
, XCDR (tail
));
1712 rarely_quit (&quit_count
);
1714 CHECK_LIST_END (tail
, seq
);
1720 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1721 doc
: /* Reverse order of items in a list, vector or string SEQ.
1722 If SEQ is a list, it should be nil-terminated.
1723 This function may destructively modify SEQ to produce the value. */)
1728 else if (STRINGP (seq
))
1729 return Freverse (seq
);
1730 else if (CONSP (seq
))
1732 unsigned short int quit_count
= 0;
1733 Lisp_Object prev
, tail
, next
;
1735 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1737 rarely_quit (&quit_count
);
1739 Fsetcdr (tail
, prev
);
1742 CHECK_LIST_END (tail
, seq
);
1745 else if (VECTORP (seq
))
1747 ptrdiff_t i
, size
= ASIZE (seq
);
1749 for (i
= 0; i
< size
/ 2; i
++)
1751 Lisp_Object tem
= AREF (seq
, i
);
1752 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1753 ASET (seq
, size
- i
- 1, tem
);
1756 else if (BOOL_VECTOR_P (seq
))
1758 ptrdiff_t i
, size
= bool_vector_size (seq
);
1760 for (i
= 0; i
< size
/ 2; i
++)
1762 bool tem
= bool_vector_bitref (seq
, i
);
1763 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1764 bool_vector_set (seq
, size
- i
- 1, tem
);
1768 wrong_type_argument (Qarrayp
, seq
);
1772 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1773 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1774 See also the function `nreverse', which is used more often. */)
1781 else if (CONSP (seq
))
1783 unsigned short int quit_count
= 0;
1784 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1786 rarely_quit (&quit_count
);
1787 new = Fcons (XCAR (seq
), new);
1789 CHECK_LIST_END (seq
, seq
);
1791 else if (VECTORP (seq
))
1793 ptrdiff_t i
, size
= ASIZE (seq
);
1795 new = make_uninit_vector (size
);
1796 for (i
= 0; i
< size
; i
++)
1797 ASET (new, i
, AREF (seq
, size
- i
- 1));
1799 else if (BOOL_VECTOR_P (seq
))
1802 EMACS_INT nbits
= bool_vector_size (seq
);
1804 new = make_uninit_bool_vector (nbits
);
1805 for (i
= 0; i
< nbits
; i
++)
1806 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1808 else if (STRINGP (seq
))
1810 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1816 new = make_uninit_string (size
);
1817 for (i
= 0; i
< size
; i
++)
1818 SSET (new, i
, SREF (seq
, size
- i
- 1));
1822 unsigned char *p
, *q
;
1824 new = make_uninit_multibyte_string (size
, bytes
);
1825 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1826 while (q
> SDATA (new))
1830 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1832 CHAR_STRING (ch
, q
);
1837 wrong_type_argument (Qsequencep
, seq
);
1841 /* Sort LIST using PREDICATE, preserving original order of elements
1842 considered as equal. */
1845 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1847 Lisp_Object front
, back
;
1848 Lisp_Object len
, tem
;
1852 len
= Flength (list
);
1853 length
= XINT (len
);
1857 XSETINT (len
, (length
/ 2) - 1);
1858 tem
= Fnthcdr (len
, list
);
1860 Fsetcdr (tem
, Qnil
);
1862 front
= Fsort (front
, predicate
);
1863 back
= Fsort (back
, predicate
);
1864 return merge (front
, back
, predicate
);
1867 /* Using PRED to compare, return whether A and B are in order.
1868 Compare stably when A appeared before B in the input. */
1870 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1872 return NILP (call2 (pred
, b
, a
));
1875 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1876 into DEST. Argument arrays must be nonempty and must not overlap,
1877 except that B might be the last part of DEST. */
1879 merge_vectors (Lisp_Object pred
,
1880 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1881 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1882 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1884 eassume (0 < alen
&& 0 < blen
);
1885 Lisp_Object
const *alim
= a
+ alen
;
1886 Lisp_Object
const *blim
= b
+ blen
;
1890 if (inorder (pred
, a
[0], b
[0]))
1896 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1905 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1912 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1913 temporary storage. LEN must be at least 2. */
1915 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1916 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1917 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1920 ptrdiff_t halflen
= len
>> 1;
1921 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1922 if (1 < len
- halflen
)
1923 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1924 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1927 /* Using PRED to compare, sort from LEN-length SRC into DST.
1928 Len must be positive. */
1930 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1931 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1932 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1935 ptrdiff_t halflen
= len
>> 1;
1941 sort_vector_inplace (pred
, halflen
, src
, dest
);
1942 if (1 < len
- halflen
)
1943 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1944 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1948 /* Sort VECTOR in place using PREDICATE, preserving original order of
1949 elements considered as equal. */
1952 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1954 ptrdiff_t len
= ASIZE (vector
);
1957 ptrdiff_t halflen
= len
>> 1;
1960 SAFE_ALLOCA_LISP (tmp
, halflen
);
1961 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1962 tmp
[i
] = make_number (0);
1963 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1967 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1968 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1969 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1970 modified by side effects. PREDICATE is called with two elements of
1971 SEQ, and should return non-nil if the first element should sort before
1973 (Lisp_Object seq
, Lisp_Object predicate
)
1976 seq
= sort_list (seq
, predicate
);
1977 else if (VECTORP (seq
))
1978 sort_vector (seq
, predicate
);
1979 else if (!NILP (seq
))
1980 wrong_type_argument (Qsequencep
, seq
);
1985 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1987 Lisp_Object l1
= org_l1
;
1988 Lisp_Object l2
= org_l2
;
1989 Lisp_Object tail
= Qnil
;
1990 Lisp_Object value
= Qnil
;
2010 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2025 Fsetcdr (tail
, tem
);
2031 /* This does not check for quits. That is safe since it must terminate. */
2033 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2034 doc
: /* Extract a value from a property list.
2035 PLIST is a property list, which is a list of the form
2036 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2037 corresponding to the given PROP, or nil if PROP is not one of the
2038 properties on the list. This function never signals an error. */)
2039 (Lisp_Object plist
, Lisp_Object prop
)
2041 Lisp_Object tail
, halftail
;
2043 /* halftail is used to detect circular lists. */
2044 tail
= halftail
= plist
;
2045 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2047 if (EQ (prop
, XCAR (tail
)))
2048 return XCAR (XCDR (tail
));
2050 tail
= XCDR (XCDR (tail
));
2051 halftail
= XCDR (halftail
);
2052 if (EQ (tail
, halftail
))
2059 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2060 doc
: /* Return the value of SYMBOL's PROPNAME property.
2061 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2062 (Lisp_Object symbol
, Lisp_Object propname
)
2064 CHECK_SYMBOL (symbol
);
2065 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2068 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2069 doc
: /* Change value in PLIST of PROP to VAL.
2070 PLIST is a property list, which is a list of the form
2071 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2072 If PROP is already a property on the list, its value is set to VAL,
2073 otherwise the new PROP VAL pair is added. The new plist is returned;
2074 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2075 The PLIST is modified by side effects. */)
2076 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2078 immediate_quit
= true;
2079 Lisp_Object prev
= Qnil
;
2080 for (Lisp_Object tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2081 tail
= XCDR (XCDR (tail
)))
2083 if (EQ (prop
, XCAR (tail
)))
2085 immediate_quit
= false;
2086 Fsetcar (XCDR (tail
), val
);
2092 immediate_quit
= true;
2094 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2097 Fsetcdr (XCDR (prev
), newcell
);
2101 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2102 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2103 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2104 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2106 CHECK_SYMBOL (symbol
);
2108 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2112 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2113 doc
: /* Extract a value from a property list, comparing with `equal'.
2114 PLIST is a property list, which is a list of the form
2115 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2116 corresponding to the given PROP, or nil if PROP is not
2117 one of the properties on the list. */)
2118 (Lisp_Object plist
, Lisp_Object prop
)
2120 unsigned short int quit_count
= 0;
2124 CONSP (tail
) && CONSP (XCDR (tail
));
2125 tail
= XCDR (XCDR (tail
)))
2127 if (! NILP (Fequal (prop
, XCAR (tail
))))
2128 return XCAR (XCDR (tail
));
2129 rarely_quit (&quit_count
);
2132 CHECK_LIST_END (tail
, prop
);
2137 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2138 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2139 PLIST is a property list, which is a list of the form
2140 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2141 If PROP is already a property on the list, its value is set to VAL,
2142 otherwise the new PROP VAL pair is added. The new plist is returned;
2143 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2144 The PLIST is modified by side effects. */)
2145 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2147 unsigned short int quit_count
= 0;
2148 Lisp_Object prev
= Qnil
;
2149 for (Lisp_Object tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2150 tail
= XCDR (XCDR (tail
)))
2152 if (! NILP (Fequal (prop
, XCAR (tail
))))
2154 Fsetcar (XCDR (tail
), val
);
2159 rarely_quit (&quit_count
);
2161 Lisp_Object newcell
= list2 (prop
, val
);
2164 Fsetcdr (XCDR (prev
), newcell
);
2168 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2169 doc
: /* Return t if the two args are the same Lisp object.
2170 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2171 (Lisp_Object obj1
, Lisp_Object obj2
)
2174 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2176 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2179 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2180 doc
: /* Return t if two Lisp objects have similar structure and contents.
2181 They must have the same data type.
2182 Conses are compared by comparing the cars and the cdrs.
2183 Vectors and strings are compared element by element.
2184 Numbers are compared by value, but integers cannot equal floats.
2185 (Use `=' if you want integers and floats to be able to be equal.)
2186 Symbols must match exactly. */)
2187 (register Lisp_Object o1
, Lisp_Object o2
)
2189 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2192 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2193 doc
: /* Return t if two Lisp objects have similar structure and contents.
2194 This is like `equal' except that it compares the text properties
2195 of strings. (`equal' ignores text properties.) */)
2196 (register Lisp_Object o1
, Lisp_Object o2
)
2198 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2201 /* DEPTH is current depth of recursion. Signal an error if it
2203 PROPS means compare string text properties too. */
2206 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2212 error ("Stack overflow in equal");
2214 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2217 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2219 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2221 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2223 { /* `o1' was seen already. */
2224 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2225 if (!NILP (Fmemq (o2
, o2s
)))
2228 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2231 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2237 unsigned short int quit_count
= 0;
2239 rarely_quit (&quit_count
);
2242 if (XTYPE (o1
) != XTYPE (o2
))
2251 d1
= extract_float (o1
);
2252 d2
= extract_float (o2
);
2253 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2254 though they are not =. */
2255 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2259 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2263 /* FIXME: This inf-loops in a circular list! */
2267 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2271 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2272 depth
+ 1, props
, ht
)
2273 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2274 depth
+ 1, props
, ht
))
2276 o1
= XOVERLAY (o1
)->plist
;
2277 o2
= XOVERLAY (o2
)->plist
;
2282 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2283 && (XMARKER (o1
)->buffer
== 0
2284 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2288 case Lisp_Vectorlike
:
2291 ptrdiff_t size
= ASIZE (o1
);
2292 /* Pseudovectors have the type encoded in the size field, so this test
2293 actually checks that the objects have the same type as well as the
2295 if (ASIZE (o2
) != size
)
2297 /* Boolvectors are compared much like strings. */
2298 if (BOOL_VECTOR_P (o1
))
2300 EMACS_INT size
= bool_vector_size (o1
);
2301 if (size
!= bool_vector_size (o2
))
2303 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2304 bool_vector_bytes (size
)))
2308 if (WINDOW_CONFIGURATIONP (o1
))
2309 return compare_window_configurations (o1
, o2
, 0);
2311 /* Aside from them, only true vectors, char-tables, compiled
2312 functions, and fonts (font-spec, font-entity, font-object)
2313 are sensible to compare, so eliminate the others now. */
2314 if (size
& PSEUDOVECTOR_FLAG
)
2316 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2319 size
&= PSEUDOVECTOR_SIZE_MASK
;
2321 for (i
= 0; i
< size
; i
++)
2326 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2334 if (SCHARS (o1
) != SCHARS (o2
))
2336 if (SBYTES (o1
) != SBYTES (o2
))
2338 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2340 if (props
&& !compare_string_intervals (o1
, o2
))
2352 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2353 doc
: /* Store each element of ARRAY with ITEM.
2354 ARRAY is a vector, string, char-table, or bool-vector. */)
2355 (Lisp_Object array
, Lisp_Object item
)
2357 register ptrdiff_t size
, idx
;
2359 if (VECTORP (array
))
2360 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2361 ASET (array
, idx
, item
);
2362 else if (CHAR_TABLE_P (array
))
2366 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2367 set_char_table_contents (array
, i
, item
);
2368 set_char_table_defalt (array
, item
);
2370 else if (STRINGP (array
))
2372 register unsigned char *p
= SDATA (array
);
2374 CHECK_CHARACTER (item
);
2375 charval
= XFASTINT (item
);
2376 size
= SCHARS (array
);
2377 if (STRING_MULTIBYTE (array
))
2379 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2380 int len
= CHAR_STRING (charval
, str
);
2381 ptrdiff_t size_byte
= SBYTES (array
);
2384 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2385 error ("Attempt to change byte length of a string");
2386 for (idx
= 0; idx
< size_byte
; idx
++)
2387 *p
++ = str
[idx
% len
];
2390 for (idx
= 0; idx
< size
; idx
++)
2393 else if (BOOL_VECTOR_P (array
))
2394 return bool_vector_fill (array
, item
);
2396 wrong_type_argument (Qarrayp
, array
);
2400 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2402 doc
: /* Clear the contents of STRING.
2403 This makes STRING unibyte and may change its length. */)
2404 (Lisp_Object string
)
2407 CHECK_STRING (string
);
2408 len
= SBYTES (string
);
2409 memset (SDATA (string
), 0, len
);
2410 STRING_SET_CHARS (string
, len
);
2411 STRING_SET_UNIBYTE (string
);
2417 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2419 return CALLN (Fnconc
, s1
, s2
);
2422 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2423 doc
: /* Concatenate any number of lists by altering them.
2424 Only the last argument is not altered, and need not be a list.
2425 usage: (nconc &rest LISTS) */)
2426 (ptrdiff_t nargs
, Lisp_Object
*args
)
2428 unsigned short int quit_count
= 0;
2429 Lisp_Object val
= Qnil
;
2431 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2433 Lisp_Object tem
= args
[argnum
];
2434 if (NILP (tem
)) continue;
2439 if (argnum
+ 1 == nargs
) break;
2443 immediate_quit
= true;
2450 while (CONSP (tem
));
2452 immediate_quit
= false;
2453 rarely_quit (&quit_count
);
2455 tem
= args
[argnum
+ 1];
2456 Fsetcdr (tail
, tem
);
2458 args
[argnum
+ 1] = tail
;
2464 /* This is the guts of all mapping functions.
2465 Apply FN to each element of SEQ, one by one, storing the results
2466 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2467 length of VALS, which should also be the length of SEQ. Return the
2468 number of results; although this is normally LENI, it can be less
2469 if SEQ is made shorter as a side effect of FN. */
2472 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2474 Lisp_Object tail
, dummy
;
2477 if (VECTORP (seq
) || COMPILEDP (seq
))
2479 for (i
= 0; i
< leni
; i
++)
2481 dummy
= call1 (fn
, AREF (seq
, i
));
2486 else if (BOOL_VECTOR_P (seq
))
2488 for (i
= 0; i
< leni
; i
++)
2490 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2495 else if (STRINGP (seq
))
2499 for (i
= 0, i_byte
= 0; i
< leni
;)
2502 ptrdiff_t i_before
= i
;
2504 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2505 XSETFASTINT (dummy
, c
);
2506 dummy
= call1 (fn
, dummy
);
2508 vals
[i_before
] = dummy
;
2511 else /* Must be a list, since Flength did not get an error */
2514 for (i
= 0; i
< leni
; i
++)
2518 dummy
= call1 (fn
, XCAR (tail
));
2528 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2529 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2530 In between each pair of results, stick in SEPARATOR. Thus, " " as
2531 SEPARATOR results in spaces between the values returned by FUNCTION.
2532 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2533 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2536 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2537 if (CHAR_TABLE_P (sequence
))
2538 wrong_type_argument (Qlistp
, sequence
);
2539 EMACS_INT args_alloc
= 2 * leni
- 1;
2541 return empty_unibyte_string
;
2543 SAFE_ALLOCA_LISP (args
, args_alloc
);
2544 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2545 ptrdiff_t nargs
= 2 * nmapped
- 1;
2547 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2548 args
[i
+ i
] = args
[i
];
2550 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2551 args
[i
] = separator
;
2553 Lisp_Object ret
= Fconcat (nargs
, args
);
2558 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2559 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2560 The result is a list just as long as SEQUENCE.
2561 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2562 (Lisp_Object function
, Lisp_Object sequence
)
2565 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2566 if (CHAR_TABLE_P (sequence
))
2567 wrong_type_argument (Qlistp
, sequence
);
2569 SAFE_ALLOCA_LISP (args
, leni
);
2570 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2571 Lisp_Object ret
= Flist (nmapped
, args
);
2576 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2577 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2578 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2579 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2580 (Lisp_Object function
, Lisp_Object sequence
)
2582 register EMACS_INT leni
;
2584 leni
= XFASTINT (Flength (sequence
));
2585 if (CHAR_TABLE_P (sequence
))
2586 wrong_type_argument (Qlistp
, sequence
);
2587 mapcar1 (leni
, 0, function
, sequence
);
2592 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2593 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2594 the results by altering them (using `nconc').
2595 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2596 (Lisp_Object function
, Lisp_Object sequence
)
2599 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2600 if (CHAR_TABLE_P (sequence
))
2601 wrong_type_argument (Qlistp
, sequence
);
2603 SAFE_ALLOCA_LISP (args
, leni
);
2604 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2605 Lisp_Object ret
= Fnconc (nmapped
, args
);
2610 /* This is how C code calls `yes-or-no-p' and allows the user
2614 do_yes_or_no_p (Lisp_Object prompt
)
2616 return call1 (intern ("yes-or-no-p"), prompt
);
2619 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2620 doc
: /* Ask user a yes-or-no question.
2621 Return t if answer is yes, and nil if the answer is no.
2622 PROMPT is the string to display to ask the question. It should end in
2623 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2625 The user must confirm the answer with RET, and can edit it until it
2628 If dialog boxes are supported, a dialog box will be used
2629 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2630 (Lisp_Object prompt
)
2634 CHECK_STRING (prompt
);
2636 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2637 && use_dialog_box
&& ! NILP (last_input_event
))
2639 Lisp_Object pane
, menu
, obj
;
2640 redisplay_preserve_echo_area (4);
2641 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2642 Fcons (build_string ("No"), Qnil
));
2643 menu
= Fcons (prompt
, pane
);
2644 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2648 AUTO_STRING (yes_or_no
, "(yes or no) ");
2649 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2653 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2654 Qyes_or_no_p_history
, Qnil
,
2656 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2658 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2663 message1 ("Please answer yes or no.");
2664 Fsleep_for (make_number (2), Qnil
);
2668 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2669 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2671 Each of the three load averages is multiplied by 100, then converted
2674 When USE-FLOATS is non-nil, floats will be used instead of integers.
2675 These floats are not multiplied by 100.
2677 If the 5-minute or 15-minute load averages are not available, return a
2678 shortened list, containing only those averages which are available.
2680 An error is thrown if the load average can't be obtained. In some
2681 cases making it work would require Emacs being installed setuid or
2682 setgid so that it can read kernel information, and that usually isn't
2684 (Lisp_Object use_floats
)
2687 int loads
= getloadavg (load_ave
, 3);
2688 Lisp_Object ret
= Qnil
;
2691 error ("load-average not implemented for this operating system");
2695 Lisp_Object load
= (NILP (use_floats
)
2696 ? make_number (100.0 * load_ave
[loads
])
2697 : make_float (load_ave
[loads
]));
2698 ret
= Fcons (load
, ret
);
2704 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2705 doc
: /* Return t if FEATURE is present in this Emacs.
2707 Use this to conditionalize execution of lisp code based on the
2708 presence or absence of Emacs or environment extensions.
2709 Use `provide' to declare that a feature is available. This function
2710 looks at the value of the variable `features'. The optional argument
2711 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2712 (Lisp_Object feature
, Lisp_Object subfeature
)
2714 register Lisp_Object tem
;
2715 CHECK_SYMBOL (feature
);
2716 tem
= Fmemq (feature
, Vfeatures
);
2717 if (!NILP (tem
) && !NILP (subfeature
))
2718 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2719 return (NILP (tem
)) ? Qnil
: Qt
;
2722 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2723 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2724 The optional argument SUBFEATURES should be a list of symbols listing
2725 particular subfeatures supported in this version of FEATURE. */)
2726 (Lisp_Object feature
, Lisp_Object subfeatures
)
2728 register Lisp_Object tem
;
2729 CHECK_SYMBOL (feature
);
2730 CHECK_LIST (subfeatures
);
2731 if (!NILP (Vautoload_queue
))
2732 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2734 tem
= Fmemq (feature
, Vfeatures
);
2736 Vfeatures
= Fcons (feature
, Vfeatures
);
2737 if (!NILP (subfeatures
))
2738 Fput (feature
, Qsubfeatures
, subfeatures
);
2739 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2741 /* Run any load-hooks for this file. */
2742 tem
= Fassq (feature
, Vafter_load_alist
);
2744 Fmapc (Qfuncall
, XCDR (tem
));
2749 /* `require' and its subroutines. */
2751 /* List of features currently being require'd, innermost first. */
2753 static Lisp_Object require_nesting_list
;
2756 require_unwind (Lisp_Object old_value
)
2758 require_nesting_list
= old_value
;
2761 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2762 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2763 If FEATURE is not a member of the list `features', then the feature is
2764 not loaded; so load the file FILENAME.
2766 If FILENAME is omitted, the printname of FEATURE is used as the file
2767 name, and `load' will try to load this name appended with the suffix
2768 `.elc', `.el', or the system-dependent suffix for dynamic module
2769 files, in that order. The name without appended suffix will not be
2770 used. See `get-load-suffixes' for the complete list of suffixes.
2772 The directories in `load-path' are searched when trying to find the
2775 If the optional third argument NOERROR is non-nil, then return nil if
2776 the file is not found instead of signaling an error. Normally the
2777 return value is FEATURE.
2779 The normal messages at start and end of loading FILENAME are
2781 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2784 bool from_file
= load_in_progress
;
2786 CHECK_SYMBOL (feature
);
2788 /* Record the presence of `require' in this file
2789 even if the feature specified is already loaded.
2790 But not more than once in any file,
2791 and not when we aren't loading or reading from a file. */
2793 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2794 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2799 tem
= Fcons (Qrequire
, feature
);
2800 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2801 LOADHIST_ATTACH (tem
);
2803 tem
= Fmemq (feature
, Vfeatures
);
2807 ptrdiff_t count
= SPECPDL_INDEX ();
2810 /* This is to make sure that loadup.el gives a clear picture
2811 of what files are preloaded and when. */
2812 if (! NILP (Vpurify_flag
))
2813 error ("(require %s) while preparing to dump",
2814 SDATA (SYMBOL_NAME (feature
)));
2816 /* A certain amount of recursive `require' is legitimate,
2817 but if we require the same feature recursively 3 times,
2819 tem
= require_nesting_list
;
2820 while (! NILP (tem
))
2822 if (! NILP (Fequal (feature
, XCAR (tem
))))
2827 error ("Recursive `require' for feature `%s'",
2828 SDATA (SYMBOL_NAME (feature
)));
2830 /* Update the list for any nested `require's that occur. */
2831 record_unwind_protect (require_unwind
, require_nesting_list
);
2832 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2834 /* Value saved here is to be restored into Vautoload_queue */
2835 record_unwind_protect (un_autoload
, Vautoload_queue
);
2836 Vautoload_queue
= Qt
;
2838 /* Load the file. */
2839 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2840 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2842 /* If load failed entirely, return nil. */
2844 return unbind_to (count
, Qnil
);
2846 tem
= Fmemq (feature
, Vfeatures
);
2848 error ("Required feature `%s' was not provided",
2849 SDATA (SYMBOL_NAME (feature
)));
2851 /* Once loading finishes, don't undo it. */
2852 Vautoload_queue
= Qt
;
2853 feature
= unbind_to (count
, feature
);
2859 /* Primitives for work of the "widget" library.
2860 In an ideal world, this section would not have been necessary.
2861 However, lisp function calls being as slow as they are, it turns
2862 out that some functions in the widget library (wid-edit.el) are the
2863 bottleneck of Widget operation. Here is their translation to C,
2864 for the sole reason of efficiency. */
2866 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2867 doc
: /* Return non-nil if PLIST has the property PROP.
2868 PLIST is a property list, which is a list of the form
2869 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2870 Unlike `plist-get', this allows you to distinguish between a missing
2871 property and a property with the value nil.
2872 The value is actually the tail of PLIST whose car is PROP. */)
2873 (Lisp_Object plist
, Lisp_Object prop
)
2875 immediate_quit
= true;
2876 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2878 plist
= XCDR (plist
);
2879 plist
= CDR (plist
);
2881 immediate_quit
= false;
2885 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2886 doc
: /* In WIDGET, set PROPERTY to VALUE.
2887 The value can later be retrieved with `widget-get'. */)
2888 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2890 CHECK_CONS (widget
);
2891 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2895 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2896 doc
: /* In WIDGET, get the value of PROPERTY.
2897 The value could either be specified when the widget was created, or
2898 later with `widget-put'. */)
2899 (Lisp_Object widget
, Lisp_Object property
)
2907 CHECK_CONS (widget
);
2908 tmp
= Fplist_member (XCDR (widget
), property
);
2914 tmp
= XCAR (widget
);
2917 widget
= Fget (tmp
, Qwidget_type
);
2921 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2922 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2923 ARGS are passed as extra arguments to the function.
2924 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2925 (ptrdiff_t nargs
, Lisp_Object
*args
)
2927 Lisp_Object widget
= args
[0];
2928 Lisp_Object property
= args
[1];
2929 Lisp_Object propval
= Fwidget_get (widget
, property
);
2930 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2931 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2935 #ifdef HAVE_LANGINFO_CODESET
2936 #include <langinfo.h>
2939 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2940 doc
: /* Access locale data ITEM for the current C locale, if available.
2941 ITEM should be one of the following:
2943 `codeset', returning the character set as a string (locale item CODESET);
2945 `days', returning a 7-element vector of day names (locale items DAY_n);
2947 `months', returning a 12-element vector of month names (locale items MON_n);
2949 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2950 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2952 If the system can't provide such information through a call to
2953 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2955 See also Info node `(libc)Locales'.
2957 The data read from the system are decoded using `locale-coding-system'. */)
2961 #ifdef HAVE_LANGINFO_CODESET
2962 if (EQ (item
, Qcodeset
))
2964 str
= nl_langinfo (CODESET
);
2965 return build_string (str
);
2968 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2970 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2971 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2973 synchronize_system_time_locale ();
2974 for (i
= 0; i
< 7; i
++)
2976 str
= nl_langinfo (days
[i
]);
2977 AUTO_STRING (val
, str
);
2978 /* Fixme: Is this coding system necessarily right, even if
2979 it is consistent with CODESET? If not, what to do? */
2980 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2987 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2989 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2990 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2991 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2993 synchronize_system_time_locale ();
2994 for (i
= 0; i
< 12; i
++)
2996 str
= nl_langinfo (months
[i
]);
2997 AUTO_STRING (val
, str
);
2998 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3004 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3005 but is in the locale files. This could be used by ps-print. */
3007 else if (EQ (item
, Qpaper
))
3008 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3009 #endif /* PAPER_WIDTH */
3010 #endif /* HAVE_LANGINFO_CODESET*/
3014 /* base64 encode/decode functions (RFC 2045).
3015 Based on code from GNU recode. */
3017 #define MIME_LINE_LENGTH 76
3019 #define IS_ASCII(Character) \
3021 #define IS_BASE64(Character) \
3022 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3023 #define IS_BASE64_IGNORABLE(Character) \
3024 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3025 || (Character) == '\f' || (Character) == '\r')
3027 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3028 character or return retval if there are no characters left to
3030 #define READ_QUADRUPLET_BYTE(retval) \
3035 if (nchars_return) \
3036 *nchars_return = nchars; \
3041 while (IS_BASE64_IGNORABLE (c))
3043 /* Table of characters coding the 64 values. */
3044 static const char base64_value_to_char
[64] =
3046 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3047 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3048 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3049 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3050 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3051 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3052 '8', '9', '+', '/' /* 60-63 */
3055 /* Table of base64 values for first 128 characters. */
3056 static const short base64_char_to_value
[128] =
3058 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3059 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3060 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3061 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3062 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3063 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3064 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3065 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3066 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3067 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3068 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3069 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3070 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3073 /* The following diagram shows the logical steps by which three octets
3074 get transformed into four base64 characters.
3076 .--------. .--------. .--------.
3077 |aaaaaabb| |bbbbcccc| |ccdddddd|
3078 `--------' `--------' `--------'
3080 .--------+--------+--------+--------.
3081 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3082 `--------+--------+--------+--------'
3084 .--------+--------+--------+--------.
3085 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3086 `--------+--------+--------+--------'
3088 The octets are divided into 6 bit chunks, which are then encoded into
3089 base64 characters. */
3092 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3093 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3096 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3098 doc
: /* Base64-encode the region between BEG and END.
3099 Return the length of the encoded text.
3100 Optional third argument NO-LINE-BREAK means do not break long lines
3101 into shorter lines. */)
3102 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3105 ptrdiff_t allength
, length
;
3106 ptrdiff_t ibeg
, iend
, encoded_length
;
3107 ptrdiff_t old_pos
= PT
;
3110 validate_region (&beg
, &end
);
3112 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3113 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3114 move_gap_both (XFASTINT (beg
), ibeg
);
3116 /* We need to allocate enough room for encoding the text.
3117 We need 33 1/3% more space, plus a newline every 76
3118 characters, and then we round up. */
3119 length
= iend
- ibeg
;
3120 allength
= length
+ length
/3 + 1;
3121 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3123 encoded
= SAFE_ALLOCA (allength
);
3124 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3125 encoded
, length
, NILP (no_line_break
),
3126 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3127 if (encoded_length
> allength
)
3130 if (encoded_length
< 0)
3132 /* The encoding wasn't possible. */
3134 error ("Multibyte character in data for base64 encoding");
3137 /* Now we have encoded the region, so we insert the new contents
3138 and delete the old. (Insert first in order to preserve markers.) */
3139 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3140 insert (encoded
, encoded_length
);
3142 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3144 /* If point was outside of the region, restore it exactly; else just
3145 move to the beginning of the region. */
3146 if (old_pos
>= XFASTINT (end
))
3147 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3148 else if (old_pos
> XFASTINT (beg
))
3149 old_pos
= XFASTINT (beg
);
3152 /* We return the length of the encoded text. */
3153 return make_number (encoded_length
);
3156 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3158 doc
: /* Base64-encode STRING and return the result.
3159 Optional second argument NO-LINE-BREAK means do not break long lines
3160 into shorter lines. */)
3161 (Lisp_Object string
, Lisp_Object no_line_break
)
3163 ptrdiff_t allength
, length
, encoded_length
;
3165 Lisp_Object encoded_string
;
3168 CHECK_STRING (string
);
3170 /* We need to allocate enough room for encoding the text.
3171 We need 33 1/3% more space, plus a newline every 76
3172 characters, and then we round up. */
3173 length
= SBYTES (string
);
3174 allength
= length
+ length
/3 + 1;
3175 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3177 /* We need to allocate enough room for decoding the text. */
3178 encoded
= SAFE_ALLOCA (allength
);
3180 encoded_length
= base64_encode_1 (SSDATA (string
),
3181 encoded
, length
, NILP (no_line_break
),
3182 STRING_MULTIBYTE (string
));
3183 if (encoded_length
> allength
)
3186 if (encoded_length
< 0)
3188 /* The encoding wasn't possible. */
3189 error ("Multibyte character in data for base64 encoding");
3192 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3195 return encoded_string
;
3199 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3200 bool line_break
, bool multibyte
)
3213 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3214 if (CHAR_BYTE8_P (c
))
3215 c
= CHAR_TO_BYTE8 (c
);
3223 /* Wrap line every 76 characters. */
3227 if (counter
< MIME_LINE_LENGTH
/ 4)
3236 /* Process first byte of a triplet. */
3238 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3239 value
= (0x03 & c
) << 4;
3241 /* Process second byte of a triplet. */
3245 *e
++ = base64_value_to_char
[value
];
3253 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3254 if (CHAR_BYTE8_P (c
))
3255 c
= CHAR_TO_BYTE8 (c
);
3263 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3264 value
= (0x0f & c
) << 2;
3266 /* Process third byte of a triplet. */
3270 *e
++ = base64_value_to_char
[value
];
3277 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3278 if (CHAR_BYTE8_P (c
))
3279 c
= CHAR_TO_BYTE8 (c
);
3287 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3288 *e
++ = base64_value_to_char
[0x3f & c
];
3295 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3297 doc
: /* Base64-decode the region between BEG and END.
3298 Return the length of the decoded text.
3299 If the region can't be decoded, signal an error and don't modify the buffer. */)
3300 (Lisp_Object beg
, Lisp_Object end
)
3302 ptrdiff_t ibeg
, iend
, length
, allength
;
3304 ptrdiff_t old_pos
= PT
;
3305 ptrdiff_t decoded_length
;
3306 ptrdiff_t inserted_chars
;
3307 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3310 validate_region (&beg
, &end
);
3312 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3313 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3315 length
= iend
- ibeg
;
3317 /* We need to allocate enough room for decoding the text. If we are
3318 working on a multibyte buffer, each decoded code may occupy at
3320 allength
= multibyte
? length
* 2 : length
;
3321 decoded
= SAFE_ALLOCA (allength
);
3323 move_gap_both (XFASTINT (beg
), ibeg
);
3324 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3326 multibyte
, &inserted_chars
);
3327 if (decoded_length
> allength
)
3330 if (decoded_length
< 0)
3332 /* The decoding wasn't possible. */
3333 error ("Invalid base64 data");
3336 /* Now we have decoded the region, so we insert the new contents
3337 and delete the old. (Insert first in order to preserve markers.) */
3338 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3339 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3342 /* Delete the original text. */
3343 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3344 iend
+ decoded_length
, 1);
3346 /* If point was outside of the region, restore it exactly; else just
3347 move to the beginning of the region. */
3348 if (old_pos
>= XFASTINT (end
))
3349 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3350 else if (old_pos
> XFASTINT (beg
))
3351 old_pos
= XFASTINT (beg
);
3352 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3354 return make_number (inserted_chars
);
3357 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3359 doc
: /* Base64-decode STRING and return the result. */)
3360 (Lisp_Object string
)
3363 ptrdiff_t length
, decoded_length
;
3364 Lisp_Object decoded_string
;
3367 CHECK_STRING (string
);
3369 length
= SBYTES (string
);
3370 /* We need to allocate enough room for decoding the text. */
3371 decoded
= SAFE_ALLOCA (length
);
3373 /* The decoded result should be unibyte. */
3374 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3376 if (decoded_length
> length
)
3378 else if (decoded_length
>= 0)
3379 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3381 decoded_string
= Qnil
;
3384 if (!STRINGP (decoded_string
))
3385 error ("Invalid base64 data");
3387 return decoded_string
;
3390 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3391 MULTIBYTE, the decoded result should be in multibyte
3392 form. If NCHARS_RETURN is not NULL, store the number of produced
3393 characters in *NCHARS_RETURN. */
3396 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3397 bool multibyte
, ptrdiff_t *nchars_return
)
3399 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3402 unsigned long value
;
3403 ptrdiff_t nchars
= 0;
3407 /* Process first byte of a quadruplet. */
3409 READ_QUADRUPLET_BYTE (e
-to
);
3413 value
= base64_char_to_value
[c
] << 18;
3415 /* Process second byte of a quadruplet. */
3417 READ_QUADRUPLET_BYTE (-1);
3421 value
|= base64_char_to_value
[c
] << 12;
3423 c
= (unsigned char) (value
>> 16);
3424 if (multibyte
&& c
>= 128)
3425 e
+= BYTE8_STRING (c
, e
);
3430 /* Process third byte of a quadruplet. */
3432 READ_QUADRUPLET_BYTE (-1);
3436 READ_QUADRUPLET_BYTE (-1);
3445 value
|= base64_char_to_value
[c
] << 6;
3447 c
= (unsigned char) (0xff & value
>> 8);
3448 if (multibyte
&& c
>= 128)
3449 e
+= BYTE8_STRING (c
, e
);
3454 /* Process fourth byte of a quadruplet. */
3456 READ_QUADRUPLET_BYTE (-1);
3463 value
|= base64_char_to_value
[c
];
3465 c
= (unsigned char) (0xff & value
);
3466 if (multibyte
&& c
>= 128)
3467 e
+= BYTE8_STRING (c
, e
);
3476 /***********************************************************************
3478 ***** Hash Tables *****
3480 ***********************************************************************/
3482 /* Implemented by gerd@gnu.org. This hash table implementation was
3483 inspired by CMUCL hash tables. */
3487 1. For small tables, association lists are probably faster than
3488 hash tables because they have lower overhead.
3490 For uses of hash tables where the O(1) behavior of table
3491 operations is not a requirement, it might therefore be a good idea
3492 not to hash. Instead, we could just do a linear search in the
3493 key_and_value vector of the hash table. This could be done
3494 if a `:linear-search t' argument is given to make-hash-table. */
3497 /* The list of all weak hash tables. Don't staticpro this one. */
3499 static struct Lisp_Hash_Table
*weak_hash_tables
;
3502 /***********************************************************************
3504 ***********************************************************************/
3507 CHECK_HASH_TABLE (Lisp_Object x
)
3509 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3513 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3515 h
->key_and_value
= key_and_value
;
3518 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3523 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3525 gc_aset (h
->next
, idx
, val
);
3528 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3533 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3535 gc_aset (h
->hash
, idx
, val
);
3538 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3543 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3545 gc_aset (h
->index
, idx
, val
);
3548 /* If OBJ is a Lisp hash table, return a pointer to its struct
3549 Lisp_Hash_Table. Otherwise, signal an error. */
3551 static struct Lisp_Hash_Table
*
3552 check_hash_table (Lisp_Object obj
)
3554 CHECK_HASH_TABLE (obj
);
3555 return XHASH_TABLE (obj
);
3559 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3560 number. A number is "almost" a prime number if it is not divisible
3561 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3564 next_almost_prime (EMACS_INT n
)
3566 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3567 for (n
|= 1; ; n
+= 2)
3568 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3573 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3574 which USED[I] is non-zero. If found at index I in ARGS, set
3575 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3576 0. This function is used to extract a keyword/argument pair from
3577 a DEFUN parameter list. */
3580 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3584 for (i
= 1; i
< nargs
; i
++)
3585 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3596 /* Return a Lisp vector which has the same contents as VEC but has
3597 at least INCR_MIN more entries, where INCR_MIN is positive.
3598 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3599 than NITEMS_MAX. Entries in the resulting
3600 vector that are not copied from VEC are set to nil. */
3603 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3605 struct Lisp_Vector
*v
;
3606 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3607 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3608 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3609 ? nitems_max
: C_language_max
);
3610 eassert (VECTORP (vec
));
3611 eassert (0 < incr_min
&& -1 <= nitems_max
);
3612 old_size
= ASIZE (vec
);
3613 incr_max
= n_max
- old_size
;
3614 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3615 if (incr_max
< incr
)
3616 memory_full (SIZE_MAX
);
3617 new_size
= old_size
+ incr
;
3618 v
= allocate_vector (new_size
);
3619 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3620 memclear (v
->contents
+ old_size
, incr
* word_size
);
3621 XSETVECTOR (vec
, v
);
3626 /***********************************************************************
3628 ***********************************************************************/
3630 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3631 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3632 KEY2 are the same. */
3635 cmpfn_eql (struct hash_table_test
*ht
,
3639 return (FLOATP (key1
)
3641 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3645 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3646 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3647 KEY2 are the same. */
3650 cmpfn_equal (struct hash_table_test
*ht
,
3654 return !NILP (Fequal (key1
, key2
));
3658 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3659 HASH2 in hash table H using H->user_cmp_function. Value is true
3660 if KEY1 and KEY2 are the same. */
3663 cmpfn_user_defined (struct hash_table_test
*ht
,
3667 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3670 /* Value is a hash code for KEY for use in hash table H which uses
3671 `eq' to compare keys. The hash code returned is guaranteed to fit
3672 in a Lisp integer. */
3675 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3677 return XHASH (key
) ^ XTYPE (key
);
3680 /* Value is a hash code for KEY for use in hash table H which uses
3681 `equal' to compare keys. The hash code returned is guaranteed to fit
3682 in a Lisp integer. */
3685 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3687 return sxhash (key
, 0);
3690 /* Value is a hash code for KEY for use in hash table H which uses
3691 `eql' to compare keys. The hash code returned is guaranteed to fit
3692 in a Lisp integer. */
3695 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3697 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3700 /* Value is a hash code for KEY for use in hash table H which uses as
3701 user-defined function to compare keys. The hash code returned is
3702 guaranteed to fit in a Lisp integer. */
3705 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3707 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3708 return hashfn_eq (ht
, hash
);
3711 struct hash_table_test
const
3712 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3713 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3714 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3715 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3716 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3717 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3719 /* Allocate basically initialized hash table. */
3721 static struct Lisp_Hash_Table
*
3722 allocate_hash_table (void)
3724 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3725 count
, PVEC_HASH_TABLE
);
3728 /* An upper bound on the size of a hash table index. It must fit in
3729 ptrdiff_t and be a valid Emacs fixnum. */
3730 #define INDEX_SIZE_BOUND \
3731 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3733 /* Create and initialize a new hash table.
3735 TEST specifies the test the hash table will use to compare keys.
3736 It must be either one of the predefined tests `eq', `eql' or
3737 `equal' or a symbol denoting a user-defined test named TEST with
3738 test and hash functions USER_TEST and USER_HASH.
3740 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3742 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3743 new size when it becomes full is computed by adding REHASH_SIZE to
3744 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3745 table's new size is computed by multiplying its old size with
3748 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3749 be resized when the ratio of (number of entries in the table) /
3750 (table size) is >= REHASH_THRESHOLD.
3752 WEAK specifies the weakness of the table. If non-nil, it must be
3753 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3756 make_hash_table (struct hash_table_test test
,
3757 Lisp_Object size
, Lisp_Object rehash_size
,
3758 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3760 struct Lisp_Hash_Table
*h
;
3762 EMACS_INT index_size
, sz
;
3766 /* Preconditions. */
3767 eassert (SYMBOLP (test
.name
));
3768 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3769 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3770 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3771 eassert (FLOATP (rehash_threshold
)
3772 && 0 < XFLOAT_DATA (rehash_threshold
)
3773 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3775 if (XFASTINT (size
) == 0)
3776 size
= make_number (1);
3778 sz
= XFASTINT (size
);
3779 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3780 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3781 ? next_almost_prime (index_float
)
3782 : INDEX_SIZE_BOUND
+ 1);
3783 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3784 error ("Hash table too large");
3786 /* Allocate a table and initialize it. */
3787 h
= allocate_hash_table ();
3789 /* Initialize hash table slots. */
3792 h
->rehash_threshold
= rehash_threshold
;
3793 h
->rehash_size
= rehash_size
;
3795 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3796 h
->hash
= Fmake_vector (size
, Qnil
);
3797 h
->next
= Fmake_vector (size
, Qnil
);
3798 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3800 /* Set up the free list. */
3801 for (i
= 0; i
< sz
- 1; ++i
)
3802 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3803 h
->next_free
= make_number (0);
3805 XSET_HASH_TABLE (table
, h
);
3806 eassert (HASH_TABLE_P (table
));
3807 eassert (XHASH_TABLE (table
) == h
);
3809 /* Maybe add this hash table to the list of all weak hash tables. */
3811 h
->next_weak
= NULL
;
3814 h
->next_weak
= weak_hash_tables
;
3815 weak_hash_tables
= h
;
3822 /* Return a copy of hash table H1. Keys and values are not copied,
3823 only the table itself is. */
3826 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3829 struct Lisp_Hash_Table
*h2
;
3831 h2
= allocate_hash_table ();
3833 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3834 h2
->hash
= Fcopy_sequence (h1
->hash
);
3835 h2
->next
= Fcopy_sequence (h1
->next
);
3836 h2
->index
= Fcopy_sequence (h1
->index
);
3837 XSET_HASH_TABLE (table
, h2
);
3839 /* Maybe add this hash table to the list of all weak hash tables. */
3840 if (!NILP (h2
->weak
))
3842 h2
->next_weak
= weak_hash_tables
;
3843 weak_hash_tables
= h2
;
3850 /* Resize hash table H if it's too full. If H cannot be resized
3851 because it's already too large, throw an error. */
3854 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3856 if (NILP (h
->next_free
))
3858 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3859 EMACS_INT new_size
, index_size
, nsize
;
3863 if (INTEGERP (h
->rehash_size
))
3864 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3867 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3868 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3870 new_size
= float_new_size
;
3871 if (new_size
<= old_size
)
3872 new_size
= old_size
+ 1;
3875 new_size
= INDEX_SIZE_BOUND
+ 1;
3877 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3878 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3879 ? next_almost_prime (index_float
)
3880 : INDEX_SIZE_BOUND
+ 1);
3881 nsize
= max (index_size
, 2 * new_size
);
3882 if (INDEX_SIZE_BOUND
< nsize
)
3883 error ("Hash table too large to resize");
3885 #ifdef ENABLE_CHECKING
3886 if (HASH_TABLE_P (Vpurify_flag
)
3887 && XHASH_TABLE (Vpurify_flag
) == h
)
3888 message ("Growing hash table to: %"pI
"d", new_size
);
3891 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3892 2 * (new_size
- old_size
), -1));
3893 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3894 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3895 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3897 /* Update the free list. Do it so that new entries are added at
3898 the end of the free list. This makes some operations like
3900 for (i
= old_size
; i
< new_size
- 1; ++i
)
3901 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3903 if (!NILP (h
->next_free
))
3905 Lisp_Object last
, next
;
3907 last
= h
->next_free
;
3908 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3912 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3915 XSETFASTINT (h
->next_free
, old_size
);
3918 for (i
= 0; i
< old_size
; ++i
)
3919 if (!NILP (HASH_HASH (h
, i
)))
3921 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3922 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3923 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3924 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3930 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3931 the hash code of KEY. Value is the index of the entry in H
3932 matching KEY, or -1 if not found. */
3935 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3937 EMACS_UINT hash_code
;
3938 ptrdiff_t start_of_bucket
;
3941 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3942 eassert ((hash_code
& ~INTMASK
) == 0);
3946 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3947 idx
= HASH_INDEX (h
, start_of_bucket
);
3951 ptrdiff_t i
= XFASTINT (idx
);
3952 if (EQ (key
, HASH_KEY (h
, i
))
3954 && hash_code
== XUINT (HASH_HASH (h
, i
))
3955 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3957 idx
= HASH_NEXT (h
, i
);
3960 return NILP (idx
) ? -1 : XFASTINT (idx
);
3964 /* Put an entry into hash table H that associates KEY with VALUE.
3965 HASH is a previously computed hash code of KEY.
3966 Value is the index of the entry in H matching KEY. */
3969 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3972 ptrdiff_t start_of_bucket
, i
;
3974 eassert ((hash
& ~INTMASK
) == 0);
3976 /* Increment count after resizing because resizing may fail. */
3977 maybe_resize_hash_table (h
);
3980 /* Store key/value in the key_and_value vector. */
3981 i
= XFASTINT (h
->next_free
);
3982 h
->next_free
= HASH_NEXT (h
, i
);
3983 set_hash_key_slot (h
, i
, key
);
3984 set_hash_value_slot (h
, i
, value
);
3986 /* Remember its hash code. */
3987 set_hash_hash_slot (h
, i
, make_number (hash
));
3989 /* Add new entry to its collision chain. */
3990 start_of_bucket
= hash
% ASIZE (h
->index
);
3991 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3992 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3997 /* Remove the entry matching KEY from hash table H, if there is one. */
4000 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4002 EMACS_UINT hash_code
;
4003 ptrdiff_t start_of_bucket
;
4004 Lisp_Object idx
, prev
;
4006 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4007 eassert ((hash_code
& ~INTMASK
) == 0);
4008 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4009 idx
= HASH_INDEX (h
, start_of_bucket
);
4014 ptrdiff_t i
= XFASTINT (idx
);
4016 if (EQ (key
, HASH_KEY (h
, i
))
4018 && hash_code
== XUINT (HASH_HASH (h
, i
))
4019 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4021 /* Take entry out of collision chain. */
4023 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4025 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4027 /* Clear slots in key_and_value and add the slots to
4029 set_hash_key_slot (h
, i
, Qnil
);
4030 set_hash_value_slot (h
, i
, Qnil
);
4031 set_hash_hash_slot (h
, i
, Qnil
);
4032 set_hash_next_slot (h
, i
, h
->next_free
);
4033 h
->next_free
= make_number (i
);
4035 eassert (h
->count
>= 0);
4041 idx
= HASH_NEXT (h
, i
);
4047 /* Clear hash table H. */
4050 hash_clear (struct Lisp_Hash_Table
*h
)
4054 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4056 for (i
= 0; i
< size
; ++i
)
4058 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4059 set_hash_key_slot (h
, i
, Qnil
);
4060 set_hash_value_slot (h
, i
, Qnil
);
4061 set_hash_hash_slot (h
, i
, Qnil
);
4064 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4065 ASET (h
->index
, i
, Qnil
);
4067 h
->next_free
= make_number (0);
4074 /************************************************************************
4076 ************************************************************************/
4078 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4079 entries from the table that don't survive the current GC.
4080 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4081 true if anything was marked. */
4084 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4086 ptrdiff_t n
= gc_asize (h
->index
);
4087 bool marked
= false;
4089 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4091 Lisp_Object idx
, next
, prev
;
4093 /* Follow collision chain, removing entries that
4094 don't survive this garbage collection. */
4096 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4098 ptrdiff_t i
= XFASTINT (idx
);
4099 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4100 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4103 if (EQ (h
->weak
, Qkey
))
4104 remove_p
= !key_known_to_survive_p
;
4105 else if (EQ (h
->weak
, Qvalue
))
4106 remove_p
= !value_known_to_survive_p
;
4107 else if (EQ (h
->weak
, Qkey_or_value
))
4108 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4109 else if (EQ (h
->weak
, Qkey_and_value
))
4110 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4114 next
= HASH_NEXT (h
, i
);
4116 if (remove_entries_p
)
4120 /* Take out of collision chain. */
4122 set_hash_index_slot (h
, bucket
, next
);
4124 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4126 /* Add to free list. */
4127 set_hash_next_slot (h
, i
, h
->next_free
);
4130 /* Clear key, value, and hash. */
4131 set_hash_key_slot (h
, i
, Qnil
);
4132 set_hash_value_slot (h
, i
, Qnil
);
4133 set_hash_hash_slot (h
, i
, Qnil
);
4146 /* Make sure key and value survive. */
4147 if (!key_known_to_survive_p
)
4149 mark_object (HASH_KEY (h
, i
));
4153 if (!value_known_to_survive_p
)
4155 mark_object (HASH_VALUE (h
, i
));
4166 /* Remove elements from weak hash tables that don't survive the
4167 current garbage collection. Remove weak tables that don't survive
4168 from Vweak_hash_tables. Called from gc_sweep. */
4170 NO_INLINE
/* For better stack traces */
4172 sweep_weak_hash_tables (void)
4174 struct Lisp_Hash_Table
*h
, *used
, *next
;
4177 /* Mark all keys and values that are in use. Keep on marking until
4178 there is no more change. This is necessary for cases like
4179 value-weak table A containing an entry X -> Y, where Y is used in a
4180 key-weak table B, Z -> Y. If B comes after A in the list of weak
4181 tables, X -> Y might be removed from A, although when looking at B
4182 one finds that it shouldn't. */
4186 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4188 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4189 marked
|= sweep_weak_table (h
, 0);
4194 /* Remove tables and entries that aren't used. */
4195 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4197 next
= h
->next_weak
;
4199 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4201 /* TABLE is marked as used. Sweep its contents. */
4203 sweep_weak_table (h
, 1);
4205 /* Add table to the list of used weak hash tables. */
4206 h
->next_weak
= used
;
4211 weak_hash_tables
= used
;
4216 /***********************************************************************
4217 Hash Code Computation
4218 ***********************************************************************/
4220 /* Maximum depth up to which to dive into Lisp structures. */
4222 #define SXHASH_MAX_DEPTH 3
4224 /* Maximum length up to which to take list and vector elements into
4227 #define SXHASH_MAX_LEN 7
4229 /* Return a hash for string PTR which has length LEN. The hash value
4230 can be any EMACS_UINT value. */
4233 hash_string (char const *ptr
, ptrdiff_t len
)
4235 char const *p
= ptr
;
4236 char const *end
= p
+ len
;
4238 EMACS_UINT hash
= 0;
4243 hash
= sxhash_combine (hash
, c
);
4249 /* Return a hash for string PTR which has length LEN. The hash
4250 code returned is guaranteed to fit in a Lisp integer. */
4253 sxhash_string (char const *ptr
, ptrdiff_t len
)
4255 EMACS_UINT hash
= hash_string (ptr
, len
);
4256 return SXHASH_REDUCE (hash
);
4259 /* Return a hash for the floating point value VAL. */
4262 sxhash_float (double val
)
4264 EMACS_UINT hash
= 0;
4266 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4267 + (sizeof val
% sizeof hash
!= 0))
4271 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4275 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4276 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4277 hash
= sxhash_combine (hash
, u
.word
[i
]);
4278 return SXHASH_REDUCE (hash
);
4281 /* Return a hash for list LIST. DEPTH is the current depth in the
4282 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4285 sxhash_list (Lisp_Object list
, int depth
)
4287 EMACS_UINT hash
= 0;
4290 if (depth
< SXHASH_MAX_DEPTH
)
4292 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4293 list
= XCDR (list
), ++i
)
4295 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4296 hash
= sxhash_combine (hash
, hash2
);
4301 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4302 hash
= sxhash_combine (hash
, hash2
);
4305 return SXHASH_REDUCE (hash
);
4309 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4310 the Lisp structure. */
4313 sxhash_vector (Lisp_Object vec
, int depth
)
4315 EMACS_UINT hash
= ASIZE (vec
);
4318 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4319 for (i
= 0; i
< n
; ++i
)
4321 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4322 hash
= sxhash_combine (hash
, hash2
);
4325 return SXHASH_REDUCE (hash
);
4328 /* Return a hash for bool-vector VECTOR. */
4331 sxhash_bool_vector (Lisp_Object vec
)
4333 EMACS_INT size
= bool_vector_size (vec
);
4334 EMACS_UINT hash
= size
;
4337 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4338 for (i
= 0; i
< n
; ++i
)
4339 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4341 return SXHASH_REDUCE (hash
);
4345 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4346 structure. Value is an unsigned integer clipped to INTMASK. */
4349 sxhash (Lisp_Object obj
, int depth
)
4353 if (depth
> SXHASH_MAX_DEPTH
)
4356 switch (XTYPE (obj
))
4368 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4371 /* This can be everything from a vector to an overlay. */
4372 case Lisp_Vectorlike
:
4374 /* According to the CL HyperSpec, two arrays are equal only if
4375 they are `eq', except for strings and bit-vectors. In
4376 Emacs, this works differently. We have to compare element
4378 hash
= sxhash_vector (obj
, depth
);
4379 else if (BOOL_VECTOR_P (obj
))
4380 hash
= sxhash_bool_vector (obj
);
4382 /* Others are `equal' if they are `eq', so let's take their
4388 hash
= sxhash_list (obj
, depth
);
4392 hash
= sxhash_float (XFLOAT_DATA (obj
));
4404 /***********************************************************************
4406 ***********************************************************************/
4408 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4409 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4410 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4413 return make_number (hashfn_eq (NULL
, obj
));
4416 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4417 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4418 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4421 return make_number (hashfn_eql (NULL
, obj
));
4424 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4425 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4426 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4429 return make_number (hashfn_equal (NULL
, obj
));
4432 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4433 doc
: /* Create and return a new hash table.
4435 Arguments are specified as keyword/argument pairs. The following
4436 arguments are defined:
4438 :test TEST -- TEST must be a symbol that specifies how to compare
4439 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4440 `equal'. User-supplied test and hash functions can be specified via
4441 `define-hash-table-test'.
4443 :size SIZE -- A hint as to how many elements will be put in the table.
4446 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4447 fills up. If REHASH-SIZE is an integer, increase the size by that
4448 amount. If it is a float, it must be > 1.0, and the new size is the
4449 old size multiplied by that factor. Default is 1.5.
4451 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4452 Resize the hash table when the ratio (number of entries / table size)
4453 is greater than or equal to THRESHOLD. Default is 0.8.
4455 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4456 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4457 returned is a weak table. Key/value pairs are removed from a weak
4458 hash table when there are no non-weak references pointing to their
4459 key, value, one of key or value, or both key and value, depending on
4460 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4463 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4464 (ptrdiff_t nargs
, Lisp_Object
*args
)
4466 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4467 struct hash_table_test testdesc
;
4471 /* The vector `used' is used to keep track of arguments that
4472 have been consumed. */
4473 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4474 memset (used
, 0, nargs
* sizeof *used
);
4476 /* See if there's a `:test TEST' among the arguments. */
4477 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4478 test
= i
? args
[i
] : Qeql
;
4480 testdesc
= hashtest_eq
;
4481 else if (EQ (test
, Qeql
))
4482 testdesc
= hashtest_eql
;
4483 else if (EQ (test
, Qequal
))
4484 testdesc
= hashtest_equal
;
4487 /* See if it is a user-defined test. */
4490 prop
= Fget (test
, Qhash_table_test
);
4491 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4492 signal_error ("Invalid hash table test", test
);
4493 testdesc
.name
= test
;
4494 testdesc
.user_cmp_function
= XCAR (prop
);
4495 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4496 testdesc
.hashfn
= hashfn_user_defined
;
4497 testdesc
.cmpfn
= cmpfn_user_defined
;
4500 /* See if there's a `:size SIZE' argument. */
4501 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4502 size
= i
? args
[i
] : Qnil
;
4504 size
= make_number (DEFAULT_HASH_SIZE
);
4505 else if (!INTEGERP (size
) || XINT (size
) < 0)
4506 signal_error ("Invalid hash table size", size
);
4508 /* Look for `:rehash-size SIZE'. */
4509 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4510 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4511 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4512 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4513 signal_error ("Invalid hash table rehash size", rehash_size
);
4515 /* Look for `:rehash-threshold THRESHOLD'. */
4516 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4517 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4518 if (! (FLOATP (rehash_threshold
)
4519 && 0 < XFLOAT_DATA (rehash_threshold
)
4520 && XFLOAT_DATA (rehash_threshold
) <= 1))
4521 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4523 /* Look for `:weakness WEAK'. */
4524 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4525 weak
= i
? args
[i
] : Qnil
;
4527 weak
= Qkey_and_value
;
4530 && !EQ (weak
, Qvalue
)
4531 && !EQ (weak
, Qkey_or_value
)
4532 && !EQ (weak
, Qkey_and_value
))
4533 signal_error ("Invalid hash table weakness", weak
);
4535 /* Now, all args should have been used up, or there's a problem. */
4536 for (i
= 0; i
< nargs
; ++i
)
4538 signal_error ("Invalid argument list", args
[i
]);
4541 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4545 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4546 doc
: /* Return a copy of hash table TABLE. */)
4549 return copy_hash_table (check_hash_table (table
));
4553 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4554 doc
: /* Return the number of elements in TABLE. */)
4557 return make_number (check_hash_table (table
)->count
);
4561 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4562 Shash_table_rehash_size
, 1, 1, 0,
4563 doc
: /* Return the current rehash size of TABLE. */)
4566 return check_hash_table (table
)->rehash_size
;
4570 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4571 Shash_table_rehash_threshold
, 1, 1, 0,
4572 doc
: /* Return the current rehash threshold of TABLE. */)
4575 return check_hash_table (table
)->rehash_threshold
;
4579 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4580 doc
: /* Return the size of TABLE.
4581 The size can be used as an argument to `make-hash-table' to create
4582 a hash table than can hold as many elements as TABLE holds
4583 without need for resizing. */)
4586 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4587 return make_number (HASH_TABLE_SIZE (h
));
4591 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4592 doc
: /* Return the test TABLE uses. */)
4595 return check_hash_table (table
)->test
.name
;
4599 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4601 doc
: /* Return the weakness of TABLE. */)
4604 return check_hash_table (table
)->weak
;
4608 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4609 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4612 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4616 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4617 doc
: /* Clear hash table TABLE and return it. */)
4620 hash_clear (check_hash_table (table
));
4621 /* Be compatible with XEmacs. */
4626 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4627 doc
: /* Look up KEY in TABLE and return its associated value.
4628 If KEY is not found, return DFLT which defaults to nil. */)
4629 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4631 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4632 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4633 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4637 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4638 doc
: /* Associate KEY with VALUE in hash table TABLE.
4639 If KEY is already present in table, replace its current value with
4640 VALUE. In any case, return VALUE. */)
4641 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4643 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4647 i
= hash_lookup (h
, key
, &hash
);
4649 set_hash_value_slot (h
, i
, value
);
4651 hash_put (h
, key
, value
, hash
);
4657 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4658 doc
: /* Remove KEY from TABLE. */)
4659 (Lisp_Object key
, Lisp_Object table
)
4661 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4662 hash_remove_from_table (h
, key
);
4667 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4668 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4669 FUNCTION is called with two arguments, KEY and VALUE.
4670 `maphash' always returns nil. */)
4671 (Lisp_Object function
, Lisp_Object table
)
4673 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4675 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4676 if (!NILP (HASH_HASH (h
, i
)))
4677 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4683 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4684 Sdefine_hash_table_test
, 3, 3, 0,
4685 doc
: /* Define a new hash table test with name NAME, a symbol.
4687 In hash tables created with NAME specified as test, use TEST to
4688 compare keys, and HASH for computing hash codes of keys.
4690 TEST must be a function taking two arguments and returning non-nil if
4691 both arguments are the same. HASH must be a function taking one
4692 argument and returning an object that is the hash code of the argument.
4693 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4694 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4695 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4697 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4702 /************************************************************************
4703 MD5, SHA-1, and SHA-2
4704 ************************************************************************/
4712 make_digest_string (Lisp_Object digest
, int digest_size
)
4714 unsigned char *p
= SDATA (digest
);
4716 for (int i
= digest_size
- 1; i
>= 0; i
--)
4718 static char const hexdigit
[16] = "0123456789abcdef";
4720 p
[2 * i
] = hexdigit
[p_i
>> 4];
4721 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4726 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4729 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4730 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4733 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4734 register EMACS_INT b
, e
;
4735 register struct buffer
*bp
;
4738 void *(*hash_func
) (const char *, size_t, void *);
4741 CHECK_SYMBOL (algorithm
);
4743 if (STRINGP (object
))
4745 if (NILP (coding_system
))
4747 /* Decide the coding-system to encode the data with. */
4749 if (STRING_MULTIBYTE (object
))
4750 /* use default, we can't guess correct value */
4751 coding_system
= preferred_coding_system ();
4753 coding_system
= Qraw_text
;
4756 if (NILP (Fcoding_system_p (coding_system
)))
4758 /* Invalid coding system. */
4760 if (!NILP (noerror
))
4761 coding_system
= Qraw_text
;
4763 xsignal1 (Qcoding_system_error
, coding_system
);
4766 if (STRING_MULTIBYTE (object
))
4767 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4769 size
= SCHARS (object
);
4770 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4772 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4773 end_byte
= (end_char
== size
4775 : string_char_to_byte (object
, end_char
));
4779 struct buffer
*prev
= current_buffer
;
4781 record_unwind_current_buffer ();
4783 CHECK_BUFFER (object
);
4785 bp
= XBUFFER (object
);
4786 set_buffer_internal (bp
);
4792 CHECK_NUMBER_COERCE_MARKER (start
);
4800 CHECK_NUMBER_COERCE_MARKER (end
);
4805 temp
= b
, b
= e
, e
= temp
;
4807 if (!(BEGV
<= b
&& e
<= ZV
))
4808 args_out_of_range (start
, end
);
4810 if (NILP (coding_system
))
4812 /* Decide the coding-system to encode the data with.
4813 See fileio.c:Fwrite-region */
4815 if (!NILP (Vcoding_system_for_write
))
4816 coding_system
= Vcoding_system_for_write
;
4819 bool force_raw_text
= 0;
4821 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4822 if (NILP (coding_system
)
4823 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4825 coding_system
= Qnil
;
4826 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4830 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4832 /* Check file-coding-system-alist. */
4833 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4834 Qwrite_region
, start
, end
,
4835 Fbuffer_file_name (object
));
4836 if (CONSP (val
) && !NILP (XCDR (val
)))
4837 coding_system
= XCDR (val
);
4840 if (NILP (coding_system
)
4841 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4843 /* If we still have not decided a coding system, use the
4844 default value of buffer-file-coding-system. */
4845 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4849 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4850 /* Confirm that VAL can surely encode the current region. */
4851 coding_system
= call4 (Vselect_safe_coding_system_function
,
4852 make_number (b
), make_number (e
),
4853 coding_system
, Qnil
);
4856 coding_system
= Qraw_text
;
4859 if (NILP (Fcoding_system_p (coding_system
)))
4861 /* Invalid coding system. */
4863 if (!NILP (noerror
))
4864 coding_system
= Qraw_text
;
4866 xsignal1 (Qcoding_system_error
, coding_system
);
4870 object
= make_buffer_string (b
, e
, 0);
4871 set_buffer_internal (prev
);
4872 /* Discard the unwind protect for recovering the current
4876 if (STRING_MULTIBYTE (object
))
4877 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4879 end_byte
= SBYTES (object
);
4882 if (EQ (algorithm
, Qmd5
))
4884 digest_size
= MD5_DIGEST_SIZE
;
4885 hash_func
= md5_buffer
;
4887 else if (EQ (algorithm
, Qsha1
))
4889 digest_size
= SHA1_DIGEST_SIZE
;
4890 hash_func
= sha1_buffer
;
4892 else if (EQ (algorithm
, Qsha224
))
4894 digest_size
= SHA224_DIGEST_SIZE
;
4895 hash_func
= sha224_buffer
;
4897 else if (EQ (algorithm
, Qsha256
))
4899 digest_size
= SHA256_DIGEST_SIZE
;
4900 hash_func
= sha256_buffer
;
4902 else if (EQ (algorithm
, Qsha384
))
4904 digest_size
= SHA384_DIGEST_SIZE
;
4905 hash_func
= sha384_buffer
;
4907 else if (EQ (algorithm
, Qsha512
))
4909 digest_size
= SHA512_DIGEST_SIZE
;
4910 hash_func
= sha512_buffer
;
4913 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4915 /* allocate 2 x digest_size so that it can be re-used to hold the
4917 digest
= make_uninit_string (digest_size
* 2);
4919 hash_func (SSDATA (object
) + start_byte
,
4920 end_byte
- start_byte
,
4924 return make_digest_string (digest
, digest_size
);
4926 return make_unibyte_string (SSDATA (digest
), digest_size
);
4929 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4930 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4932 A message digest is a cryptographic checksum of a document, and the
4933 algorithm to calculate it is defined in RFC 1321.
4935 The two optional arguments START and END are character positions
4936 specifying for which part of OBJECT the message digest should be
4937 computed. If nil or omitted, the digest is computed for the whole
4940 The MD5 message digest is computed from the result of encoding the
4941 text in a coding system, not directly from the internal Emacs form of
4942 the text. The optional fourth argument CODING-SYSTEM specifies which
4943 coding system to encode the text with. It should be the same coding
4944 system that you used or will use when actually writing the text into a
4947 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4948 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4949 system would be chosen by default for writing this text into a file.
4951 If OBJECT is a string, the most preferred coding system (see the
4952 command `prefer-coding-system') is used.
4954 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4955 guesswork fails. Normally, an error is signaled in such case. */)
4956 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4958 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4961 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4962 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4963 ALGORITHM is a symbol specifying the hash to use:
4964 md5, sha1, sha224, sha256, sha384 or sha512.
4966 The two optional arguments START and END are positions specifying for
4967 which part of OBJECT to compute the hash. If nil or omitted, uses the
4970 If BINARY is non-nil, returns a string in binary form. */)
4971 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4973 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4976 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
4977 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
4978 This hash is performed on the raw internal format of the buffer,
4979 disregarding any coding systems.
4980 If nil, use the current buffer." */ )
4981 (Lisp_Object buffer_or_name
)
4985 struct sha1_ctx ctx
;
4987 if (NILP (buffer_or_name
))
4988 buffer
= Fcurrent_buffer ();
4990 buffer
= Fget_buffer (buffer_or_name
);
4992 nsberror (buffer_or_name
);
4994 b
= XBUFFER (buffer
);
4995 sha1_init_ctx (&ctx
);
4997 /* Process the first part of the buffer. */
4998 sha1_process_bytes (BUF_BEG_ADDR (b
),
4999 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5002 /* If the gap is before the end of the buffer, process the last half
5004 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5005 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5006 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5009 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5010 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5011 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5018 DEFSYM (Qmd5
, "md5");
5019 DEFSYM (Qsha1
, "sha1");
5020 DEFSYM (Qsha224
, "sha224");
5021 DEFSYM (Qsha256
, "sha256");
5022 DEFSYM (Qsha384
, "sha384");
5023 DEFSYM (Qsha512
, "sha512");
5025 /* Hash table stuff. */
5026 DEFSYM (Qhash_table_p
, "hash-table-p");
5028 DEFSYM (Qeql
, "eql");
5029 DEFSYM (Qequal
, "equal");
5030 DEFSYM (QCtest
, ":test");
5031 DEFSYM (QCsize
, ":size");
5032 DEFSYM (QCrehash_size
, ":rehash-size");
5033 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5034 DEFSYM (QCweakness
, ":weakness");
5035 DEFSYM (Qkey
, "key");
5036 DEFSYM (Qvalue
, "value");
5037 DEFSYM (Qhash_table_test
, "hash-table-test");
5038 DEFSYM (Qkey_or_value
, "key-or-value");
5039 DEFSYM (Qkey_and_value
, "key-and-value");
5041 defsubr (&Ssxhash_eq
);
5042 defsubr (&Ssxhash_eql
);
5043 defsubr (&Ssxhash_equal
);
5044 defsubr (&Smake_hash_table
);
5045 defsubr (&Scopy_hash_table
);
5046 defsubr (&Shash_table_count
);
5047 defsubr (&Shash_table_rehash_size
);
5048 defsubr (&Shash_table_rehash_threshold
);
5049 defsubr (&Shash_table_size
);
5050 defsubr (&Shash_table_test
);
5051 defsubr (&Shash_table_weakness
);
5052 defsubr (&Shash_table_p
);
5053 defsubr (&Sclrhash
);
5054 defsubr (&Sgethash
);
5055 defsubr (&Sputhash
);
5056 defsubr (&Sremhash
);
5057 defsubr (&Smaphash
);
5058 defsubr (&Sdefine_hash_table_test
);
5060 DEFSYM (Qstring_lessp
, "string-lessp");
5061 DEFSYM (Qprovide
, "provide");
5062 DEFSYM (Qrequire
, "require");
5063 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5064 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5065 DEFSYM (Qwidget_type
, "widget-type");
5067 staticpro (&string_char_byte_cache_string
);
5068 string_char_byte_cache_string
= Qnil
;
5070 require_nesting_list
= Qnil
;
5071 staticpro (&require_nesting_list
);
5073 Fset (Qyes_or_no_p_history
, Qnil
);
5075 DEFVAR_LISP ("features", Vfeatures
,
5076 doc
: /* A list of symbols which are the features of the executing Emacs.
5077 Used by `featurep' and `require', and altered by `provide'. */);
5078 Vfeatures
= list1 (Qemacs
);
5079 DEFSYM (Qfeatures
, "features");
5080 /* Let people use lexically scoped vars named `features'. */
5081 Fmake_var_non_special (Qfeatures
);
5082 DEFSYM (Qsubfeatures
, "subfeatures");
5083 DEFSYM (Qfuncall
, "funcall");
5085 #ifdef HAVE_LANGINFO_CODESET
5086 DEFSYM (Qcodeset
, "codeset");
5087 DEFSYM (Qdays
, "days");
5088 DEFSYM (Qmonths
, "months");
5089 DEFSYM (Qpaper
, "paper");
5090 #endif /* HAVE_LANGINFO_CODESET */
5092 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5093 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5094 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5095 invoked by mouse clicks and mouse menu items.
5097 On some platforms, file selection dialogs are also enabled if this is
5101 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5102 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5103 This applies to commands from menus and tool bar buttons even when
5104 they are initiated from the keyboard. If `use-dialog-box' is nil,
5105 that disables the use of a file dialog, regardless of the value of
5107 use_file_dialog
= 1;
5109 defsubr (&Sidentity
);
5112 defsubr (&Ssafe_length
);
5113 defsubr (&Sstring_bytes
);
5114 defsubr (&Sstring_equal
);
5115 defsubr (&Scompare_strings
);
5116 defsubr (&Sstring_lessp
);
5117 defsubr (&Sstring_version_lessp
);
5118 defsubr (&Sstring_collate_lessp
);
5119 defsubr (&Sstring_collate_equalp
);
5122 defsubr (&Svconcat
);
5123 defsubr (&Scopy_sequence
);
5124 defsubr (&Sstring_make_multibyte
);
5125 defsubr (&Sstring_make_unibyte
);
5126 defsubr (&Sstring_as_multibyte
);
5127 defsubr (&Sstring_as_unibyte
);
5128 defsubr (&Sstring_to_multibyte
);
5129 defsubr (&Sstring_to_unibyte
);
5130 defsubr (&Scopy_alist
);
5131 defsubr (&Ssubstring
);
5132 defsubr (&Ssubstring_no_properties
);
5145 defsubr (&Snreverse
);
5146 defsubr (&Sreverse
);
5148 defsubr (&Splist_get
);
5150 defsubr (&Splist_put
);
5152 defsubr (&Slax_plist_get
);
5153 defsubr (&Slax_plist_put
);
5156 defsubr (&Sequal_including_properties
);
5157 defsubr (&Sfillarray
);
5158 defsubr (&Sclear_string
);
5163 defsubr (&Smapconcat
);
5164 defsubr (&Syes_or_no_p
);
5165 defsubr (&Sload_average
);
5166 defsubr (&Sfeaturep
);
5167 defsubr (&Srequire
);
5168 defsubr (&Sprovide
);
5169 defsubr (&Splist_member
);
5170 defsubr (&Swidget_put
);
5171 defsubr (&Swidget_get
);
5172 defsubr (&Swidget_apply
);
5173 defsubr (&Sbase64_encode_region
);
5174 defsubr (&Sbase64_decode_region
);
5175 defsubr (&Sbase64_encode_string
);
5176 defsubr (&Sbase64_decode_string
);
5178 defsubr (&Ssecure_hash
);
5179 defsubr (&Sbuffer_hash
);
5180 defsubr (&Slocale_info
);