1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2016 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
11 (at 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/>. */
28 #include "character.h"
30 #include "composite.h"
32 #include "intervals.h"
35 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
36 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
37 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
39 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
40 doc
: /* Return the argument unchanged. */
47 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
48 doc
: /* Return a pseudo-random number.
49 All integers representable in Lisp, i.e. between `most-negative-fixnum'
50 and `most-positive-fixnum', inclusive, are equally likely.
52 With positive integer LIMIT, return random number in interval [0,LIMIT).
53 With argument t, set the random number seed from the system's entropy
54 pool if available, otherwise from less-random volatile data such as the time.
55 With a string argument, set the seed based on the string's contents.
56 Other values of LIMIT are ignored.
58 See Info node `(elisp)Random Numbers' for more details. */)
65 else if (STRINGP (limit
))
66 seed_random (SSDATA (limit
), SBYTES (limit
));
69 if (INTEGERP (limit
) && 0 < XINT (limit
))
72 /* Return the remainder, except reject the rare case where
73 get_random returns a number so close to INTMASK that the
74 remainder isn't random. */
75 EMACS_INT remainder
= val
% XINT (limit
);
76 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
77 return make_number (remainder
);
80 return make_number (val
);
83 /* Heuristic on how many iterations of a tight loop can be safely done
84 before it's time to do a QUIT. This must be a power of 2. */
85 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
87 /* Random data-structure functions. */
90 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
92 CHECK_TYPE (NILP (x
), Qlistp
, y
);
95 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
96 doc
: /* Return the length of vector, list or string SEQUENCE.
97 A byte-code function object is also allowed.
98 If the string contains multibyte characters, this is not necessarily
99 the number of bytes in the string; it is the number of characters.
100 To get the number of bytes, use `string-bytes'. */)
101 (register Lisp_Object sequence
)
103 register Lisp_Object val
;
105 if (STRINGP (sequence
))
106 XSETFASTINT (val
, SCHARS (sequence
));
107 else if (VECTORP (sequence
))
108 XSETFASTINT (val
, ASIZE (sequence
));
109 else if (CHAR_TABLE_P (sequence
))
110 XSETFASTINT (val
, MAX_CHAR
);
111 else if (BOOL_VECTOR_P (sequence
))
112 XSETFASTINT (val
, bool_vector_size (sequence
));
113 else if (COMPILEDP (sequence
))
114 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
115 else if (CONSP (sequence
))
122 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
124 if (MOST_POSITIVE_FIXNUM
< i
)
125 error ("List too long");
128 sequence
= XCDR (sequence
);
130 while (CONSP (sequence
));
132 CHECK_LIST_END (sequence
, sequence
);
134 val
= make_number (i
);
136 else if (NILP (sequence
))
137 XSETFASTINT (val
, 0);
139 wrong_type_argument (Qsequencep
, sequence
);
144 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
145 doc
: /* Return the length of a list, but avoid error or infinite loop.
146 This function never gets an error. If LIST is not really a list,
147 it returns 0. If LIST is circular, it returns a finite value
148 which is at least the number of distinct elements. */)
151 Lisp_Object tail
, halftail
;
156 return make_number (0);
158 /* halftail is used to detect circular lists. */
159 for (tail
= halftail
= list
; ; )
164 if (EQ (tail
, halftail
))
167 if ((lolen
& 1) == 0)
169 halftail
= XCDR (halftail
);
170 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
174 hilen
+= UINTMAX_MAX
+ 1.0;
179 /* If the length does not fit into a fixnum, return a float.
180 On all known practical machines this returns an upper bound on
182 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
185 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
186 doc
: /* Return the number of bytes in STRING.
187 If STRING is multibyte, this may be greater than the length of STRING. */)
190 CHECK_STRING (string
);
191 return make_number (SBYTES (string
));
194 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
195 doc
: /* Return t if two strings have identical contents.
196 Case is significant, but text properties are ignored.
197 Symbols are also allowed; their print names are used instead. */)
198 (register Lisp_Object s1
, Lisp_Object s2
)
201 s1
= SYMBOL_NAME (s1
);
203 s2
= SYMBOL_NAME (s2
);
207 if (SCHARS (s1
) != SCHARS (s2
)
208 || SBYTES (s1
) != SBYTES (s2
)
209 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
214 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
215 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
216 The arguments START1, END1, START2, and END2, if non-nil, are
217 positions specifying which parts of STR1 or STR2 to compare. In
218 string STR1, compare the part between START1 (inclusive) and END1
219 (exclusive). If START1 is nil, it defaults to 0, the beginning of
220 the string; if END1 is nil, it defaults to the length of the string.
221 Likewise, in string STR2, compare the part between START2 and END2.
222 Like in `substring', negative values are counted from the end.
224 The strings are compared by the numeric values of their characters.
225 For instance, STR1 is "less than" STR2 if its first differing
226 character has a smaller numeric value. If IGNORE-CASE is non-nil,
227 characters are converted to lower-case before comparing them. Unibyte
228 strings are converted to multibyte for comparison.
230 The value is t if the strings (or specified portions) match.
231 If string STR1 is less, the value is a negative number N;
232 - 1 - N is the number of characters that match at the beginning.
233 If string STR1 is greater, the value is a positive number N;
234 N - 1 is the number of characters that match at the beginning. */)
235 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
236 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
238 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
243 /* For backward compatibility, silently bring too-large positive end
244 values into range. */
245 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
246 end1
= make_number (SCHARS (str1
));
247 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
248 end2
= make_number (SCHARS (str2
));
250 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
251 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
256 i1_byte
= string_char_to_byte (str1
, i1
);
257 i2_byte
= string_char_to_byte (str2
, i2
);
259 while (i1
< to1
&& i2
< to2
)
261 /* When we find a mismatch, we must compare the
262 characters, not just the bytes. */
265 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
266 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
271 if (! NILP (ignore_case
))
273 c1
= XINT (Fupcase (make_number (c1
)));
274 c2
= XINT (Fupcase (make_number (c2
)));
280 /* Note that I1 has already been incremented
281 past the character that we are comparing;
282 hence we don't add or subtract 1 here. */
284 return make_number (- i1
+ from1
);
286 return make_number (i1
- from1
);
290 return make_number (i1
- from1
+ 1);
292 return make_number (- i1
+ from1
- 1);
297 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
298 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
300 Symbols are also allowed; their print names are used instead. */)
301 (register Lisp_Object string1
, Lisp_Object string2
)
303 register ptrdiff_t end
;
304 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
306 if (SYMBOLP (string1
))
307 string1
= SYMBOL_NAME (string1
);
308 if (SYMBOLP (string2
))
309 string2
= SYMBOL_NAME (string2
);
310 CHECK_STRING (string1
);
311 CHECK_STRING (string2
);
313 i1
= i1_byte
= i2
= i2_byte
= 0;
315 end
= SCHARS (string1
);
316 if (end
> SCHARS (string2
))
317 end
= SCHARS (string2
);
321 /* When we find a mismatch, we must compare the
322 characters, not just the bytes. */
325 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
326 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
329 return c1
< c2
? Qt
: Qnil
;
331 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
334 /* Return the numerical value of a consecutive run of numerical
335 characters from STRING. The ISP and ISP_BYTE address pointer
336 pointers are increased and left at the next character after the
337 numerical characters. */
339 gather_number_from_string (int c
, Lisp_Object string
,
340 ptrdiff_t *isp
, ptrdiff_t *isp_byte
)
342 size_t number
= c
- '0';
348 if (STRING_MULTIBYTE (string
))
350 chp
= &SDATA (string
)[*isp_byte
];
351 c
= STRING_CHAR_AND_LENGTH (chp
, chlen
);
355 c
= SREF (string
, *isp_byte
);
359 /* If we're still in a number, add it to the sum and continue. */
360 /* FIXME: Integer overflow? */
361 if (c
>= '0' && c
<= '9')
363 number
= number
* 10;
366 (*isp_byte
) += chlen
;
371 /* Stop when we get to the end of the string anyway. */
377 DEFUN ("string-numeric-lessp", Fstring_numeric_lessp
,
378 Sstring_numeric_lessp
, 2, 2, 0,
379 doc
: /* Return non-nil if STRING1 is less than STRING2 in 'numeric' order.
380 Sequences of non-numerical characters are compared lexicographically,
381 while sequences of numerical characters are converted into numbers,
382 and then the numbers are compared. This means that \"foo2.png\" is
383 less than \"foo12.png\" according to this predicate.
385 Symbols are also allowed; their print names are used instead. */)
386 (register Lisp_Object string1
, Lisp_Object string2
)
389 ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
392 if (SYMBOLP (string1
))
393 string1
= SYMBOL_NAME (string1
);
394 if (SYMBOLP (string2
))
395 string2
= SYMBOL_NAME (string2
);
396 CHECK_STRING (string1
);
397 CHECK_STRING (string2
);
399 i1
= i1_byte
= i2
= i2_byte
= 0;
401 end
= SCHARS (string1
);
402 if (end
> SCHARS (string2
))
403 end
= SCHARS (string2
);
407 /* When we find a mismatch, we must compare the
408 characters, not just the bytes. */
411 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
412 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
414 if (c1
>= '0' && c1
<= '9' &&
415 c2
>= '0' && c2
<= '9')
416 /* Both strings are numbers, so compare them. */
418 num1
= gather_number_from_string (c1
, string1
, &i1
, &i1_byte
);
419 num2
= gather_number_from_string (c2
, string2
, &i2
, &i2_byte
);
422 else if (num1
> num2
)
426 return c1
< c2
? Qt
: Qnil
;
428 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
431 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
432 doc
: /* Return t if first arg string is less than second in collation order.
433 Symbols are also allowed; their print names are used instead.
435 This function obeys the conventions for collation order in your
436 locale settings. For example, punctuation and whitespace characters
437 might be considered less significant for sorting:
439 (sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
440 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
442 The optional argument LOCALE, a string, overrides the setting of your
443 current locale identifier for collation. The value is system
444 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
445 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
447 If IGNORE-CASE is non-nil, characters are converted to lower-case
448 before comparing them.
450 To emulate Unicode-compliant collation on MS-Windows systems,
451 bind `w32-collate-ignore-punctuation' to a non-nil value, since
452 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
454 If your system does not support a locale environment, this function
455 behaves like `string-lessp'. */)
456 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
458 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
459 /* Check parameters. */
461 s1
= SYMBOL_NAME (s1
);
463 s2
= SYMBOL_NAME (s2
);
467 CHECK_STRING (locale
);
469 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
471 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
472 return Fstring_lessp (s1
, s2
);
473 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
476 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
477 doc
: /* Return t if two strings have identical contents.
478 Symbols are also allowed; their print names are used instead.
480 This function obeys the conventions for collation order in your locale
481 settings. For example, characters with different coding points but
482 the same meaning might be considered as equal, like different grave
483 accent Unicode characters:
485 (string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
488 The optional argument LOCALE, a string, overrides the setting of your
489 current locale identifier for collation. The value is system
490 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
491 while it would be \"enu_USA.1252\" on MS Windows systems.
493 If IGNORE-CASE is non-nil, characters are converted to lower-case
494 before comparing them.
496 To emulate Unicode-compliant collation on MS-Windows systems,
497 bind `w32-collate-ignore-punctuation' to a non-nil value, since
498 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
500 If your system does not support a locale environment, this function
501 behaves like `string-equal'.
503 Do NOT use this function to compare file names for equality, only
504 for sorting them. */)
505 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
507 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
508 /* Check parameters. */
510 s1
= SYMBOL_NAME (s1
);
512 s2
= SYMBOL_NAME (s2
);
516 CHECK_STRING (locale
);
518 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
520 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
521 return Fstring_equal (s1
, s2
);
522 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
525 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
526 enum Lisp_Type target_type
, bool last_special
);
530 concat2 (Lisp_Object s1
, Lisp_Object s2
)
532 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
537 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
539 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
542 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
543 doc
: /* Concatenate all the arguments and make the result a list.
544 The result is a list whose elements are the elements of all the arguments.
545 Each argument may be a list, vector or string.
546 The last argument is not copied, just used as the tail of the new list.
547 usage: (append &rest SEQUENCES) */)
548 (ptrdiff_t nargs
, Lisp_Object
*args
)
550 return concat (nargs
, args
, Lisp_Cons
, 1);
553 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
554 doc
: /* Concatenate all the arguments and make the result a string.
555 The result is a string whose elements are the elements of all the arguments.
556 Each argument may be a string or a list or vector of characters (integers).
557 usage: (concat &rest SEQUENCES) */)
558 (ptrdiff_t nargs
, Lisp_Object
*args
)
560 return concat (nargs
, args
, Lisp_String
, 0);
563 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
564 doc
: /* Concatenate all the arguments and make the result a vector.
565 The result is a vector whose elements are the elements of all the arguments.
566 Each argument may be a list, vector or string.
567 usage: (vconcat &rest SEQUENCES) */)
568 (ptrdiff_t nargs
, Lisp_Object
*args
)
570 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
574 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
575 doc
: /* Return a copy of a list, vector, string or char-table.
576 The elements of a list or vector are not copied; they are shared
577 with the original. */)
580 if (NILP (arg
)) return arg
;
582 if (CHAR_TABLE_P (arg
))
584 return copy_char_table (arg
);
587 if (BOOL_VECTOR_P (arg
))
589 EMACS_INT nbits
= bool_vector_size (arg
);
590 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
591 Lisp_Object val
= make_uninit_bool_vector (nbits
);
592 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
596 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
597 wrong_type_argument (Qsequencep
, arg
);
599 return concat (1, &arg
, XTYPE (arg
), 0);
602 /* This structure holds information of an argument of `concat' that is
603 a string and has text properties to be copied. */
606 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
607 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
608 ptrdiff_t to
; /* refer to VAL (the target string) */
612 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
613 enum Lisp_Type target_type
, bool last_special
)
619 ptrdiff_t toindex_byte
= 0;
620 EMACS_INT result_len
;
621 EMACS_INT result_len_byte
;
623 Lisp_Object last_tail
;
626 /* When we make a multibyte string, we can't copy text properties
627 while concatenating each string because the length of resulting
628 string can't be decided until we finish the whole concatenation.
629 So, we record strings that have text properties to be copied
630 here, and copy the text properties after the concatenation. */
631 struct textprop_rec
*textprops
= NULL
;
632 /* Number of elements in textprops. */
633 ptrdiff_t num_textprops
= 0;
638 /* In append, the last arg isn't treated like the others */
639 if (last_special
&& nargs
> 0)
642 last_tail
= args
[nargs
];
647 /* Check each argument. */
648 for (argnum
= 0; argnum
< nargs
; argnum
++)
651 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
652 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
653 wrong_type_argument (Qsequencep
, this);
656 /* Compute total length in chars of arguments in RESULT_LEN.
657 If desired output is a string, also compute length in bytes
658 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
659 whether the result should be a multibyte string. */
663 for (argnum
= 0; argnum
< nargs
; argnum
++)
667 len
= XFASTINT (Flength (this));
668 if (target_type
== Lisp_String
)
670 /* We must count the number of bytes needed in the string
671 as well as the number of characters. */
675 ptrdiff_t this_len_byte
;
677 if (VECTORP (this) || COMPILEDP (this))
678 for (i
= 0; i
< len
; i
++)
681 CHECK_CHARACTER (ch
);
683 this_len_byte
= CHAR_BYTES (c
);
684 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
686 result_len_byte
+= this_len_byte
;
687 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
690 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
691 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
692 else if (CONSP (this))
693 for (; CONSP (this); this = XCDR (this))
696 CHECK_CHARACTER (ch
);
698 this_len_byte
= CHAR_BYTES (c
);
699 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
701 result_len_byte
+= this_len_byte
;
702 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
705 else if (STRINGP (this))
707 if (STRING_MULTIBYTE (this))
710 this_len_byte
= SBYTES (this);
713 this_len_byte
= count_size_as_multibyte (SDATA (this),
715 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
717 result_len_byte
+= this_len_byte
;
722 if (MOST_POSITIVE_FIXNUM
< result_len
)
723 memory_full (SIZE_MAX
);
726 if (! some_multibyte
)
727 result_len_byte
= result_len
;
729 /* Create the output object. */
730 if (target_type
== Lisp_Cons
)
731 val
= Fmake_list (make_number (result_len
), Qnil
);
732 else if (target_type
== Lisp_Vectorlike
)
733 val
= Fmake_vector (make_number (result_len
), Qnil
);
734 else if (some_multibyte
)
735 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
737 val
= make_uninit_string (result_len
);
739 /* In `append', if all but last arg are nil, return last arg. */
740 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
743 /* Copy the contents of the args into the result. */
745 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
747 toindex
= 0, toindex_byte
= 0;
751 SAFE_NALLOCA (textprops
, 1, nargs
);
753 for (argnum
= 0; argnum
< nargs
; argnum
++)
756 ptrdiff_t thisleni
= 0;
757 register ptrdiff_t thisindex
= 0;
758 register ptrdiff_t thisindex_byte
= 0;
762 thislen
= Flength (this), thisleni
= XINT (thislen
);
764 /* Between strings of the same kind, copy fast. */
765 if (STRINGP (this) && STRINGP (val
)
766 && STRING_MULTIBYTE (this) == some_multibyte
)
768 ptrdiff_t thislen_byte
= SBYTES (this);
770 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
771 if (string_intervals (this))
773 textprops
[num_textprops
].argnum
= argnum
;
774 textprops
[num_textprops
].from
= 0;
775 textprops
[num_textprops
++].to
= toindex
;
777 toindex_byte
+= thislen_byte
;
780 /* Copy a single-byte string to a multibyte string. */
781 else if (STRINGP (this) && STRINGP (val
))
783 if (string_intervals (this))
785 textprops
[num_textprops
].argnum
= argnum
;
786 textprops
[num_textprops
].from
= 0;
787 textprops
[num_textprops
++].to
= toindex
;
789 toindex_byte
+= copy_text (SDATA (this),
790 SDATA (val
) + toindex_byte
,
791 SCHARS (this), 0, 1);
795 /* Copy element by element. */
798 register Lisp_Object elt
;
800 /* Fetch next element of `this' arg into `elt', or break if
801 `this' is exhausted. */
802 if (NILP (this)) break;
804 elt
= XCAR (this), this = XCDR (this);
805 else if (thisindex
>= thisleni
)
807 else if (STRINGP (this))
810 if (STRING_MULTIBYTE (this))
811 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
816 c
= SREF (this, thisindex
); thisindex
++;
817 if (some_multibyte
&& !ASCII_CHAR_P (c
))
818 c
= BYTE8_TO_CHAR (c
);
820 XSETFASTINT (elt
, c
);
822 else if (BOOL_VECTOR_P (this))
824 elt
= bool_vector_ref (this, thisindex
);
829 elt
= AREF (this, thisindex
);
833 /* Store this element into the result. */
840 else if (VECTORP (val
))
842 ASET (val
, toindex
, elt
);
848 CHECK_CHARACTER (elt
);
851 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
853 SSET (val
, toindex_byte
++, c
);
859 XSETCDR (prev
, last_tail
);
861 if (num_textprops
> 0)
864 ptrdiff_t last_to_end
= -1;
866 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
868 this = args
[textprops
[argnum
].argnum
];
869 props
= text_property_list (this,
871 make_number (SCHARS (this)),
873 /* If successive arguments have properties, be sure that the
874 value of `composition' property be the copy. */
875 if (last_to_end
== textprops
[argnum
].to
)
876 make_composition_value_copy (props
);
877 add_text_properties_from_list (val
, props
,
878 make_number (textprops
[argnum
].to
));
879 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
887 static Lisp_Object string_char_byte_cache_string
;
888 static ptrdiff_t string_char_byte_cache_charpos
;
889 static ptrdiff_t string_char_byte_cache_bytepos
;
892 clear_string_char_byte_cache (void)
894 string_char_byte_cache_string
= Qnil
;
897 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
900 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
903 ptrdiff_t best_below
, best_below_byte
;
904 ptrdiff_t best_above
, best_above_byte
;
906 best_below
= best_below_byte
= 0;
907 best_above
= SCHARS (string
);
908 best_above_byte
= SBYTES (string
);
909 if (best_above
== best_above_byte
)
912 if (EQ (string
, string_char_byte_cache_string
))
914 if (string_char_byte_cache_charpos
< char_index
)
916 best_below
= string_char_byte_cache_charpos
;
917 best_below_byte
= string_char_byte_cache_bytepos
;
921 best_above
= string_char_byte_cache_charpos
;
922 best_above_byte
= string_char_byte_cache_bytepos
;
926 if (char_index
- best_below
< best_above
- char_index
)
928 unsigned char *p
= SDATA (string
) + best_below_byte
;
930 while (best_below
< char_index
)
932 p
+= BYTES_BY_CHAR_HEAD (*p
);
935 i_byte
= p
- SDATA (string
);
939 unsigned char *p
= SDATA (string
) + best_above_byte
;
941 while (best_above
> char_index
)
944 while (!CHAR_HEAD_P (*p
)) p
--;
947 i_byte
= p
- SDATA (string
);
950 string_char_byte_cache_bytepos
= i_byte
;
951 string_char_byte_cache_charpos
= char_index
;
952 string_char_byte_cache_string
= string
;
957 /* Return the character index corresponding to BYTE_INDEX in STRING. */
960 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
963 ptrdiff_t best_below
, best_below_byte
;
964 ptrdiff_t best_above
, best_above_byte
;
966 best_below
= best_below_byte
= 0;
967 best_above
= SCHARS (string
);
968 best_above_byte
= SBYTES (string
);
969 if (best_above
== best_above_byte
)
972 if (EQ (string
, string_char_byte_cache_string
))
974 if (string_char_byte_cache_bytepos
< byte_index
)
976 best_below
= string_char_byte_cache_charpos
;
977 best_below_byte
= string_char_byte_cache_bytepos
;
981 best_above
= string_char_byte_cache_charpos
;
982 best_above_byte
= string_char_byte_cache_bytepos
;
986 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
988 unsigned char *p
= SDATA (string
) + best_below_byte
;
989 unsigned char *pend
= SDATA (string
) + byte_index
;
993 p
+= BYTES_BY_CHAR_HEAD (*p
);
997 i_byte
= p
- SDATA (string
);
1001 unsigned char *p
= SDATA (string
) + best_above_byte
;
1002 unsigned char *pbeg
= SDATA (string
) + byte_index
;
1007 while (!CHAR_HEAD_P (*p
)) p
--;
1011 i_byte
= p
- SDATA (string
);
1014 string_char_byte_cache_bytepos
= i_byte
;
1015 string_char_byte_cache_charpos
= i
;
1016 string_char_byte_cache_string
= string
;
1021 /* Convert STRING to a multibyte string. */
1024 string_make_multibyte (Lisp_Object string
)
1031 if (STRING_MULTIBYTE (string
))
1034 nbytes
= count_size_as_multibyte (SDATA (string
),
1036 /* If all the chars are ASCII, they won't need any more bytes
1037 once converted. In that case, we can return STRING itself. */
1038 if (nbytes
== SBYTES (string
))
1041 buf
= SAFE_ALLOCA (nbytes
);
1042 copy_text (SDATA (string
), buf
, SBYTES (string
),
1045 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1052 /* Convert STRING (if unibyte) to a multibyte string without changing
1053 the number of characters. Characters 0200 trough 0237 are
1054 converted to eight-bit characters. */
1057 string_to_multibyte (Lisp_Object string
)
1064 if (STRING_MULTIBYTE (string
))
1067 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1068 /* If all the chars are ASCII, they won't need any more bytes once
1070 if (nbytes
== SBYTES (string
))
1071 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1073 buf
= SAFE_ALLOCA (nbytes
);
1074 memcpy (buf
, SDATA (string
), SBYTES (string
));
1075 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1077 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1084 /* Convert STRING to a single-byte string. */
1087 string_make_unibyte (Lisp_Object string
)
1094 if (! STRING_MULTIBYTE (string
))
1097 nchars
= SCHARS (string
);
1099 buf
= SAFE_ALLOCA (nchars
);
1100 copy_text (SDATA (string
), buf
, SBYTES (string
),
1103 ret
= make_unibyte_string ((char *) buf
, nchars
);
1109 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1111 doc
: /* Return the multibyte equivalent of STRING.
1112 If STRING is unibyte and contains non-ASCII characters, the function
1113 `unibyte-char-to-multibyte' is used to convert each unibyte character
1114 to a multibyte character. In this case, the returned string is a
1115 newly created string with no text properties. If STRING is multibyte
1116 or entirely ASCII, it is returned unchanged. In particular, when
1117 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1118 (When the characters are all ASCII, Emacs primitives will treat the
1119 string the same way whether it is unibyte or multibyte.) */)
1120 (Lisp_Object string
)
1122 CHECK_STRING (string
);
1124 return string_make_multibyte (string
);
1127 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1129 doc
: /* Return the unibyte equivalent of STRING.
1130 Multibyte character codes are converted to unibyte according to
1131 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1132 If the lookup in the translation table fails, this function takes just
1133 the low 8 bits of each character. */)
1134 (Lisp_Object string
)
1136 CHECK_STRING (string
);
1138 return string_make_unibyte (string
);
1141 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1143 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1144 If STRING is unibyte, the result is STRING itself.
1145 Otherwise it is a newly created string, with no text properties.
1146 If STRING is multibyte and contains a character of charset
1147 `eight-bit', it is converted to the corresponding single byte. */)
1148 (Lisp_Object string
)
1150 CHECK_STRING (string
);
1152 if (STRING_MULTIBYTE (string
))
1154 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1155 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1157 string
= make_unibyte_string ((char *) str
, bytes
);
1163 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1165 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1166 If STRING is multibyte, the result is STRING itself.
1167 Otherwise it is a newly created string, with no text properties.
1169 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1170 part of a correct utf-8 sequence), it is converted to the corresponding
1171 multibyte character of charset `eight-bit'.
1172 See also `string-to-multibyte'.
1174 Beware, this often doesn't really do what you think it does.
1175 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1176 If you're not sure, whether to use `string-as-multibyte' or
1177 `string-to-multibyte', use `string-to-multibyte'. */)
1178 (Lisp_Object string
)
1180 CHECK_STRING (string
);
1182 if (! STRING_MULTIBYTE (string
))
1184 Lisp_Object new_string
;
1185 ptrdiff_t nchars
, nbytes
;
1187 parse_str_as_multibyte (SDATA (string
),
1190 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1191 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1192 if (nbytes
!= SBYTES (string
))
1193 str_as_multibyte (SDATA (new_string
), nbytes
,
1194 SBYTES (string
), NULL
);
1195 string
= new_string
;
1196 set_string_intervals (string
, NULL
);
1201 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1203 doc
: /* Return a multibyte string with the same individual chars as STRING.
1204 If STRING is multibyte, the result is STRING itself.
1205 Otherwise it is a newly created string, with no text properties.
1207 If STRING is unibyte and contains an 8-bit byte, it is converted to
1208 the corresponding multibyte character of charset `eight-bit'.
1210 This differs from `string-as-multibyte' by converting each byte of a correct
1211 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1212 correct sequence. */)
1213 (Lisp_Object string
)
1215 CHECK_STRING (string
);
1217 return string_to_multibyte (string
);
1220 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1222 doc
: /* Return a unibyte string with the same individual chars as STRING.
1223 If STRING is unibyte, the result is STRING itself.
1224 Otherwise it is a newly created string, with no text properties,
1225 where each `eight-bit' character is converted to the corresponding byte.
1226 If STRING contains a non-ASCII, non-`eight-bit' character,
1227 an error is signaled. */)
1228 (Lisp_Object string
)
1230 CHECK_STRING (string
);
1232 if (STRING_MULTIBYTE (string
))
1234 ptrdiff_t chars
= SCHARS (string
);
1235 unsigned char *str
= xmalloc (chars
);
1236 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1238 if (converted
< chars
)
1239 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1240 string
= make_unibyte_string ((char *) str
, chars
);
1247 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1248 doc
: /* Return a copy of ALIST.
1249 This is an alist which represents the same mapping from objects to objects,
1250 but does not share the alist structure with ALIST.
1251 The objects mapped (cars and cdrs of elements of the alist)
1252 are shared, however.
1253 Elements of ALIST that are not conses are also shared. */)
1256 register Lisp_Object tem
;
1261 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1262 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1264 register Lisp_Object car
;
1268 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1273 /* Check that ARRAY can have a valid subarray [FROM..TO),
1274 given that its size is SIZE.
1275 If FROM is nil, use 0; if TO is nil, use SIZE.
1276 Count negative values backwards from the end.
1277 Set *IFROM and *ITO to the two indexes used. */
1280 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1281 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1285 if (INTEGERP (from
))
1291 else if (NILP (from
))
1294 wrong_type_argument (Qintegerp
, from
);
1305 wrong_type_argument (Qintegerp
, to
);
1307 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1308 args_out_of_range_3 (array
, from
, to
);
1314 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1315 doc
: /* Return a new string whose contents are a substring of STRING.
1316 The returned string consists of the characters between index FROM
1317 (inclusive) and index TO (exclusive) of STRING. FROM and TO are
1318 zero-indexed: 0 means the first character of STRING. Negative values
1319 are counted from the end of STRING. If TO is nil, the substring runs
1320 to the end of STRING.
1322 The STRING argument may also be a vector. In that case, the return
1323 value is a new vector that contains the elements between index FROM
1324 (inclusive) and index TO (exclusive) of that vector argument.
1326 With one argument, just copy STRING (with properties, if any). */)
1327 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1330 ptrdiff_t size
, ifrom
, ito
;
1332 size
= CHECK_VECTOR_OR_STRING (string
);
1333 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1335 if (STRINGP (string
))
1338 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1340 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1341 res
= make_specified_string (SSDATA (string
) + from_byte
,
1342 ito
- ifrom
, to_byte
- from_byte
,
1343 STRING_MULTIBYTE (string
));
1344 copy_text_properties (make_number (ifrom
), make_number (ito
),
1345 string
, make_number (0), res
, Qnil
);
1348 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1354 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1355 doc
: /* Return a substring of STRING, without text properties.
1356 It starts at index FROM and ends before TO.
1357 TO may be nil or omitted; then the substring runs to the end of STRING.
1358 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1359 If FROM or TO is negative, it counts from the end.
1361 With one argument, just copy STRING without its properties. */)
1362 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1364 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1366 CHECK_STRING (string
);
1368 size
= SCHARS (string
);
1369 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1371 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1373 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1374 return make_specified_string (SSDATA (string
) + from_byte
,
1375 to_char
- from_char
, to_byte
- from_byte
,
1376 STRING_MULTIBYTE (string
));
1379 /* Extract a substring of STRING, giving start and end positions
1380 both in characters and in bytes. */
1383 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1384 ptrdiff_t to
, ptrdiff_t to_byte
)
1387 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1389 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1390 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1392 if (STRINGP (string
))
1394 res
= make_specified_string (SSDATA (string
) + from_byte
,
1395 to
- from
, to_byte
- from_byte
,
1396 STRING_MULTIBYTE (string
));
1397 copy_text_properties (make_number (from
), make_number (to
),
1398 string
, make_number (0), res
, Qnil
);
1401 res
= Fvector (to
- from
, aref_addr (string
, from
));
1406 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1407 doc
: /* Take cdr N times on LIST, return the result. */)
1408 (Lisp_Object n
, Lisp_Object list
)
1413 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1416 CHECK_LIST_CONS (list
, list
);
1422 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1423 doc
: /* Return the Nth element of LIST.
1424 N counts from zero. If LIST is not that long, nil is returned. */)
1425 (Lisp_Object n
, Lisp_Object list
)
1427 return Fcar (Fnthcdr (n
, list
));
1430 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1431 doc
: /* Return element of SEQUENCE at index N. */)
1432 (register Lisp_Object sequence
, Lisp_Object n
)
1435 if (CONSP (sequence
) || NILP (sequence
))
1436 return Fcar (Fnthcdr (n
, sequence
));
1438 /* Faref signals a "not array" error, so check here. */
1439 CHECK_ARRAY (sequence
, Qsequencep
);
1440 return Faref (sequence
, n
);
1443 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1444 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1445 The value is actually the tail of LIST whose car is ELT. */)
1446 (register Lisp_Object elt
, Lisp_Object list
)
1448 register Lisp_Object tail
;
1449 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1451 register Lisp_Object tem
;
1452 CHECK_LIST_CONS (tail
, list
);
1454 if (! NILP (Fequal (elt
, tem
)))
1461 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1462 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1463 The value is actually the tail of LIST whose car is ELT. */)
1464 (register Lisp_Object elt
, Lisp_Object list
)
1468 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1472 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1476 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1487 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1488 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1489 The value is actually the tail of LIST whose car is ELT. */)
1490 (register Lisp_Object elt
, Lisp_Object list
)
1492 register Lisp_Object tail
;
1495 return Fmemq (elt
, list
);
1497 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1499 register Lisp_Object tem
;
1500 CHECK_LIST_CONS (tail
, list
);
1502 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1509 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1510 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1511 The value is actually the first element of LIST whose car is KEY.
1512 Elements of LIST that are not conses are ignored. */)
1513 (Lisp_Object key
, Lisp_Object list
)
1518 || (CONSP (XCAR (list
))
1519 && EQ (XCAR (XCAR (list
)), key
)))
1524 || (CONSP (XCAR (list
))
1525 && EQ (XCAR (XCAR (list
)), key
)))
1530 || (CONSP (XCAR (list
))
1531 && EQ (XCAR (XCAR (list
)), key
)))
1541 /* Like Fassq but never report an error and do not allow quits.
1542 Use only on lists known never to be circular. */
1545 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1548 && (!CONSP (XCAR (list
))
1549 || !EQ (XCAR (XCAR (list
)), key
)))
1552 return CAR_SAFE (list
);
1555 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1556 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1557 The value is actually the first element of LIST whose car equals KEY. */)
1558 (Lisp_Object key
, Lisp_Object list
)
1565 || (CONSP (XCAR (list
))
1566 && (car
= XCAR (XCAR (list
)),
1567 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1572 || (CONSP (XCAR (list
))
1573 && (car
= XCAR (XCAR (list
)),
1574 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1579 || (CONSP (XCAR (list
))
1580 && (car
= XCAR (XCAR (list
)),
1581 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1591 /* Like Fassoc but never report an error and do not allow quits.
1592 Use only on lists known never to be circular. */
1595 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1598 && (!CONSP (XCAR (list
))
1599 || (!EQ (XCAR (XCAR (list
)), key
)
1600 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1603 return CONSP (list
) ? XCAR (list
) : Qnil
;
1606 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1607 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1608 The value is actually the first element of LIST whose cdr is KEY. */)
1609 (register Lisp_Object key
, Lisp_Object list
)
1614 || (CONSP (XCAR (list
))
1615 && EQ (XCDR (XCAR (list
)), key
)))
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1626 || (CONSP (XCAR (list
))
1627 && EQ (XCDR (XCAR (list
)), key
)))
1637 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1638 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1639 The value is actually the first element of LIST whose cdr equals KEY. */)
1640 (Lisp_Object key
, Lisp_Object list
)
1647 || (CONSP (XCAR (list
))
1648 && (cdr
= XCDR (XCAR (list
)),
1649 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1654 || (CONSP (XCAR (list
))
1655 && (cdr
= XCDR (XCAR (list
)),
1656 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1661 || (CONSP (XCAR (list
))
1662 && (cdr
= XCDR (XCAR (list
)),
1663 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1673 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1674 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1675 More precisely, this function skips any members `eq' to ELT at the
1676 front of LIST, then removes members `eq' to ELT from the remaining
1677 sublist by modifying its list structure, then returns the resulting
1680 Write `(setq foo (delq element foo))' to be sure of correctly changing
1681 the value of a list `foo'. See also `remq', which does not modify the
1683 (register Lisp_Object elt
, Lisp_Object list
)
1685 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1688 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1690 Lisp_Object tem
= XCAR (tail
);
1696 Fsetcdr (prev
, XCDR (tail
));
1704 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1705 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1706 SEQ must be a sequence (i.e. a list, a vector, or a string).
1707 The return value is a sequence of the same type.
1709 If SEQ is a list, this behaves like `delq', except that it compares
1710 with `equal' instead of `eq'. In particular, it may remove elements
1711 by altering the list structure.
1713 If SEQ is not a list, deletion is never performed destructively;
1714 instead this function creates and returns a new vector or string.
1716 Write `(setq foo (delete element foo))' to be sure of correctly
1717 changing the value of a sequence `foo'. */)
1718 (Lisp_Object elt
, Lisp_Object seq
)
1724 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1725 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1728 if (n
!= ASIZE (seq
))
1730 struct Lisp_Vector
*p
= allocate_vector (n
);
1732 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1733 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1734 p
->contents
[n
++] = AREF (seq
, i
);
1736 XSETVECTOR (seq
, p
);
1739 else if (STRINGP (seq
))
1741 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1744 for (i
= nchars
= nbytes
= ibyte
= 0;
1746 ++i
, ibyte
+= cbytes
)
1748 if (STRING_MULTIBYTE (seq
))
1750 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1751 cbytes
= CHAR_BYTES (c
);
1759 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1766 if (nchars
!= SCHARS (seq
))
1770 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1771 if (!STRING_MULTIBYTE (seq
))
1772 STRING_SET_UNIBYTE (tem
);
1774 for (i
= nchars
= nbytes
= ibyte
= 0;
1776 ++i
, ibyte
+= cbytes
)
1778 if (STRING_MULTIBYTE (seq
))
1780 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1781 cbytes
= CHAR_BYTES (c
);
1789 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1791 unsigned char *from
= SDATA (seq
) + ibyte
;
1792 unsigned char *to
= SDATA (tem
) + nbytes
;
1798 for (n
= cbytes
; n
--; )
1808 Lisp_Object tail
, prev
;
1810 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1812 CHECK_LIST_CONS (tail
, seq
);
1814 if (!NILP (Fequal (elt
, XCAR (tail
))))
1819 Fsetcdr (prev
, XCDR (tail
));
1830 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1831 doc
: /* Reverse order of items in a list, vector or string SEQ.
1832 If SEQ is a list, it should be nil-terminated.
1833 This function may destructively modify SEQ to produce the value. */)
1838 else if (STRINGP (seq
))
1839 return Freverse (seq
);
1840 else if (CONSP (seq
))
1842 Lisp_Object prev
, tail
, next
;
1844 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1847 CHECK_LIST_CONS (tail
, tail
);
1849 Fsetcdr (tail
, prev
);
1854 else if (VECTORP (seq
))
1856 ptrdiff_t i
, size
= ASIZE (seq
);
1858 for (i
= 0; i
< size
/ 2; i
++)
1860 Lisp_Object tem
= AREF (seq
, i
);
1861 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1862 ASET (seq
, size
- i
- 1, tem
);
1865 else if (BOOL_VECTOR_P (seq
))
1867 ptrdiff_t i
, size
= bool_vector_size (seq
);
1869 for (i
= 0; i
< size
/ 2; i
++)
1871 bool tem
= bool_vector_bitref (seq
, i
);
1872 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1873 bool_vector_set (seq
, size
- i
- 1, tem
);
1877 wrong_type_argument (Qarrayp
, seq
);
1881 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1882 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1883 See also the function `nreverse', which is used more often. */)
1890 else if (CONSP (seq
))
1892 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1895 new = Fcons (XCAR (seq
), new);
1897 CHECK_LIST_END (seq
, seq
);
1899 else if (VECTORP (seq
))
1901 ptrdiff_t i
, size
= ASIZE (seq
);
1903 new = make_uninit_vector (size
);
1904 for (i
= 0; i
< size
; i
++)
1905 ASET (new, i
, AREF (seq
, size
- i
- 1));
1907 else if (BOOL_VECTOR_P (seq
))
1910 EMACS_INT nbits
= bool_vector_size (seq
);
1912 new = make_uninit_bool_vector (nbits
);
1913 for (i
= 0; i
< nbits
; i
++)
1914 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1916 else if (STRINGP (seq
))
1918 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1924 new = make_uninit_string (size
);
1925 for (i
= 0; i
< size
; i
++)
1926 SSET (new, i
, SREF (seq
, size
- i
- 1));
1930 unsigned char *p
, *q
;
1932 new = make_uninit_multibyte_string (size
, bytes
);
1933 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1934 while (q
> SDATA (new))
1938 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1940 CHAR_STRING (ch
, q
);
1945 wrong_type_argument (Qsequencep
, seq
);
1949 /* Sort LIST using PREDICATE, preserving original order of elements
1950 considered as equal. */
1953 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1955 Lisp_Object front
, back
;
1956 Lisp_Object len
, tem
;
1960 len
= Flength (list
);
1961 length
= XINT (len
);
1965 XSETINT (len
, (length
/ 2) - 1);
1966 tem
= Fnthcdr (len
, list
);
1968 Fsetcdr (tem
, Qnil
);
1970 front
= Fsort (front
, predicate
);
1971 back
= Fsort (back
, predicate
);
1972 return merge (front
, back
, predicate
);
1975 /* Using PRED to compare, return whether A and B are in order.
1976 Compare stably when A appeared before B in the input. */
1978 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1980 return NILP (call2 (pred
, b
, a
));
1983 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1984 into DEST. Argument arrays must be nonempty and must not overlap,
1985 except that B might be the last part of DEST. */
1987 merge_vectors (Lisp_Object pred
,
1988 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1989 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1990 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1992 eassume (0 < alen
&& 0 < blen
);
1993 Lisp_Object
const *alim
= a
+ alen
;
1994 Lisp_Object
const *blim
= b
+ blen
;
1998 if (inorder (pred
, a
[0], b
[0]))
2004 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
2013 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
2020 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
2021 temporary storage. LEN must be at least 2. */
2023 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
2024 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
2025 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
2028 ptrdiff_t halflen
= len
>> 1;
2029 sort_vector_copy (pred
, halflen
, vec
, tmp
);
2030 if (1 < len
- halflen
)
2031 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
2032 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
2035 /* Using PRED to compare, sort from LEN-length SRC into DST.
2036 Len must be positive. */
2038 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
2039 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
2040 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
2043 ptrdiff_t halflen
= len
>> 1;
2049 sort_vector_inplace (pred
, halflen
, src
, dest
);
2050 if (1 < len
- halflen
)
2051 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
2052 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
2056 /* Sort VECTOR in place using PREDICATE, preserving original order of
2057 elements considered as equal. */
2060 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
2062 ptrdiff_t len
= ASIZE (vector
);
2065 ptrdiff_t halflen
= len
>> 1;
2068 SAFE_ALLOCA_LISP (tmp
, halflen
);
2069 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
2070 tmp
[i
] = make_number (0);
2071 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2075 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2076 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2077 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2078 modified by side effects. PREDICATE is called with two elements of
2079 SEQ, and should return non-nil if the first element should sort before
2081 (Lisp_Object seq
, Lisp_Object predicate
)
2084 seq
= sort_list (seq
, predicate
);
2085 else if (VECTORP (seq
))
2086 sort_vector (seq
, predicate
);
2087 else if (!NILP (seq
))
2088 wrong_type_argument (Qsequencep
, seq
);
2093 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2095 Lisp_Object l1
= org_l1
;
2096 Lisp_Object l2
= org_l2
;
2097 Lisp_Object tail
= Qnil
;
2098 Lisp_Object value
= Qnil
;
2118 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2133 Fsetcdr (tail
, tem
);
2139 /* This does not check for quits. That is safe since it must terminate. */
2141 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2142 doc
: /* Extract a value from a property list.
2143 PLIST is a property list, which is a list of the form
2144 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2145 corresponding to the given PROP, or nil if PROP is not one of the
2146 properties on the list. This function never signals an error. */)
2147 (Lisp_Object plist
, Lisp_Object prop
)
2149 Lisp_Object tail
, halftail
;
2151 /* halftail is used to detect circular lists. */
2152 tail
= halftail
= plist
;
2153 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2155 if (EQ (prop
, XCAR (tail
)))
2156 return XCAR (XCDR (tail
));
2158 tail
= XCDR (XCDR (tail
));
2159 halftail
= XCDR (halftail
);
2160 if (EQ (tail
, halftail
))
2167 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2168 doc
: /* Return the value of SYMBOL's PROPNAME property.
2169 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2170 (Lisp_Object symbol
, Lisp_Object propname
)
2172 CHECK_SYMBOL (symbol
);
2173 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2176 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2177 doc
: /* Change value in PLIST of PROP to VAL.
2178 PLIST is a property list, which is a list of the form
2179 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2180 If PROP is already a property on the list, its value is set to VAL,
2181 otherwise the new PROP VAL pair is added. The new plist is returned;
2182 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2183 The PLIST is modified by side effects. */)
2184 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2186 register Lisp_Object tail
, prev
;
2187 Lisp_Object newcell
;
2189 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2190 tail
= XCDR (XCDR (tail
)))
2192 if (EQ (prop
, XCAR (tail
)))
2194 Fsetcar (XCDR (tail
), val
);
2201 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2205 Fsetcdr (XCDR (prev
), newcell
);
2209 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2210 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2211 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2212 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2214 CHECK_SYMBOL (symbol
);
2216 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2220 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2221 doc
: /* Extract a value from a property list, comparing with `equal'.
2222 PLIST is a property list, which is a list of the form
2223 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2224 corresponding to the given PROP, or nil if PROP is not
2225 one of the properties on the list. */)
2226 (Lisp_Object plist
, Lisp_Object prop
)
2231 CONSP (tail
) && CONSP (XCDR (tail
));
2232 tail
= XCDR (XCDR (tail
)))
2234 if (! NILP (Fequal (prop
, XCAR (tail
))))
2235 return XCAR (XCDR (tail
));
2240 CHECK_LIST_END (tail
, prop
);
2245 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2246 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2247 PLIST is a property list, which is a list of the form
2248 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2249 If PROP is already a property on the list, its value is set to VAL,
2250 otherwise the new PROP VAL pair is added. The new plist is returned;
2251 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2252 The PLIST is modified by side effects. */)
2253 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2255 register Lisp_Object tail
, prev
;
2256 Lisp_Object newcell
;
2258 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2259 tail
= XCDR (XCDR (tail
)))
2261 if (! NILP (Fequal (prop
, XCAR (tail
))))
2263 Fsetcar (XCDR (tail
), val
);
2270 newcell
= list2 (prop
, val
);
2274 Fsetcdr (XCDR (prev
), newcell
);
2278 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2279 doc
: /* Return t if the two args are the same Lisp object.
2280 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2281 (Lisp_Object obj1
, Lisp_Object obj2
)
2284 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2286 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2289 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2290 doc
: /* Return t if two Lisp objects have similar structure and contents.
2291 They must have the same data type.
2292 Conses are compared by comparing the cars and the cdrs.
2293 Vectors and strings are compared element by element.
2294 Numbers are compared by value, but integers cannot equal floats.
2295 (Use `=' if you want integers and floats to be able to be equal.)
2296 Symbols must match exactly. */)
2297 (register Lisp_Object o1
, Lisp_Object o2
)
2299 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2302 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2303 doc
: /* Return t if two Lisp objects have similar structure and contents.
2304 This is like `equal' except that it compares the text properties
2305 of strings. (`equal' ignores text properties.) */)
2306 (register Lisp_Object o1
, Lisp_Object o2
)
2308 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2311 /* DEPTH is current depth of recursion. Signal an error if it
2313 PROPS means compare string text properties too. */
2316 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2322 error ("Stack overflow in equal");
2324 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2327 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2329 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2331 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2333 { /* `o1' was seen already. */
2334 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2335 if (!NILP (Fmemq (o2
, o2s
)))
2338 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2341 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2351 if (XTYPE (o1
) != XTYPE (o2
))
2360 d1
= extract_float (o1
);
2361 d2
= extract_float (o2
);
2362 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2363 though they are not =. */
2364 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2368 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2372 /* FIXME: This inf-loops in a circular list! */
2376 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2380 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2381 depth
+ 1, props
, ht
)
2382 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2383 depth
+ 1, props
, ht
))
2385 o1
= XOVERLAY (o1
)->plist
;
2386 o2
= XOVERLAY (o2
)->plist
;
2391 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2392 && (XMARKER (o1
)->buffer
== 0
2393 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2397 case Lisp_Vectorlike
:
2400 ptrdiff_t size
= ASIZE (o1
);
2401 /* Pseudovectors have the type encoded in the size field, so this test
2402 actually checks that the objects have the same type as well as the
2404 if (ASIZE (o2
) != size
)
2406 /* Boolvectors are compared much like strings. */
2407 if (BOOL_VECTOR_P (o1
))
2409 EMACS_INT size
= bool_vector_size (o1
);
2410 if (size
!= bool_vector_size (o2
))
2412 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2413 bool_vector_bytes (size
)))
2417 if (WINDOW_CONFIGURATIONP (o1
))
2418 return compare_window_configurations (o1
, o2
, 0);
2420 /* Aside from them, only true vectors, char-tables, compiled
2421 functions, and fonts (font-spec, font-entity, font-object)
2422 are sensible to compare, so eliminate the others now. */
2423 if (size
& PSEUDOVECTOR_FLAG
)
2425 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2428 size
&= PSEUDOVECTOR_SIZE_MASK
;
2430 for (i
= 0; i
< size
; i
++)
2435 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2443 if (SCHARS (o1
) != SCHARS (o2
))
2445 if (SBYTES (o1
) != SBYTES (o2
))
2447 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2449 if (props
&& !compare_string_intervals (o1
, o2
))
2461 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2462 doc
: /* Store each element of ARRAY with ITEM.
2463 ARRAY is a vector, string, char-table, or bool-vector. */)
2464 (Lisp_Object array
, Lisp_Object item
)
2466 register ptrdiff_t size
, idx
;
2468 if (VECTORP (array
))
2469 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2470 ASET (array
, idx
, item
);
2471 else if (CHAR_TABLE_P (array
))
2475 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2476 set_char_table_contents (array
, i
, item
);
2477 set_char_table_defalt (array
, item
);
2479 else if (STRINGP (array
))
2481 register unsigned char *p
= SDATA (array
);
2483 CHECK_CHARACTER (item
);
2484 charval
= XFASTINT (item
);
2485 size
= SCHARS (array
);
2486 if (STRING_MULTIBYTE (array
))
2488 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2489 int len
= CHAR_STRING (charval
, str
);
2490 ptrdiff_t size_byte
= SBYTES (array
);
2493 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2494 error ("Attempt to change byte length of a string");
2495 for (idx
= 0; idx
< size_byte
; idx
++)
2496 *p
++ = str
[idx
% len
];
2499 for (idx
= 0; idx
< size
; idx
++)
2502 else if (BOOL_VECTOR_P (array
))
2503 return bool_vector_fill (array
, item
);
2505 wrong_type_argument (Qarrayp
, array
);
2509 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2511 doc
: /* Clear the contents of STRING.
2512 This makes STRING unibyte and may change its length. */)
2513 (Lisp_Object string
)
2516 CHECK_STRING (string
);
2517 len
= SBYTES (string
);
2518 memset (SDATA (string
), 0, len
);
2519 STRING_SET_CHARS (string
, len
);
2520 STRING_SET_UNIBYTE (string
);
2526 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2528 return CALLN (Fnconc
, s1
, s2
);
2531 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2532 doc
: /* Concatenate any number of lists by altering them.
2533 Only the last argument is not altered, and need not be a list.
2534 usage: (nconc &rest LISTS) */)
2535 (ptrdiff_t nargs
, Lisp_Object
*args
)
2538 register Lisp_Object tail
, tem
, val
;
2542 for (argnum
= 0; argnum
< nargs
; argnum
++)
2545 if (NILP (tem
)) continue;
2550 if (argnum
+ 1 == nargs
) break;
2552 CHECK_LIST_CONS (tem
, tem
);
2561 tem
= args
[argnum
+ 1];
2562 Fsetcdr (tail
, tem
);
2564 args
[argnum
+ 1] = tail
;
2570 /* This is the guts of all mapping functions.
2571 Apply FN to each element of SEQ, one by one,
2572 storing the results into elements of VALS, a C vector of Lisp_Objects.
2573 LENI is the length of VALS, which should also be the length of SEQ. */
2576 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2578 Lisp_Object tail
, dummy
;
2581 if (VECTORP (seq
) || COMPILEDP (seq
))
2583 for (i
= 0; i
< leni
; i
++)
2585 dummy
= call1 (fn
, AREF (seq
, i
));
2590 else if (BOOL_VECTOR_P (seq
))
2592 for (i
= 0; i
< leni
; i
++)
2594 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2599 else if (STRINGP (seq
))
2603 for (i
= 0, i_byte
= 0; i
< leni
;)
2606 ptrdiff_t i_before
= i
;
2608 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2609 XSETFASTINT (dummy
, c
);
2610 dummy
= call1 (fn
, dummy
);
2612 vals
[i_before
] = dummy
;
2615 else /* Must be a list, since Flength did not get an error */
2618 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2620 dummy
= call1 (fn
, XCAR (tail
));
2628 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2629 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2630 In between each pair of results, stick in SEPARATOR. Thus, " " as
2631 SEPARATOR results in spaces between the values returned by FUNCTION.
2632 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2633 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2643 len
= Flength (sequence
);
2644 if (CHAR_TABLE_P (sequence
))
2645 wrong_type_argument (Qlistp
, sequence
);
2647 nargs
= leni
+ leni
- 1;
2648 if (nargs
< 0) return empty_unibyte_string
;
2650 SAFE_ALLOCA_LISP (args
, nargs
);
2652 mapcar1 (leni
, args
, function
, sequence
);
2654 for (i
= leni
- 1; i
> 0; i
--)
2655 args
[i
+ i
] = args
[i
];
2657 for (i
= 1; i
< nargs
; i
+= 2)
2658 args
[i
] = separator
;
2660 ret
= Fconcat (nargs
, args
);
2666 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2667 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2668 The result is a list just as long as SEQUENCE.
2669 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2670 (Lisp_Object function
, Lisp_Object sequence
)
2672 register Lisp_Object len
;
2673 register EMACS_INT leni
;
2674 register Lisp_Object
*args
;
2678 len
= Flength (sequence
);
2679 if (CHAR_TABLE_P (sequence
))
2680 wrong_type_argument (Qlistp
, sequence
);
2681 leni
= XFASTINT (len
);
2683 SAFE_ALLOCA_LISP (args
, leni
);
2685 mapcar1 (leni
, args
, function
, sequence
);
2687 ret
= Flist (leni
, args
);
2693 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2694 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2695 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2696 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2697 (Lisp_Object function
, Lisp_Object sequence
)
2699 register EMACS_INT leni
;
2701 leni
= XFASTINT (Flength (sequence
));
2702 if (CHAR_TABLE_P (sequence
))
2703 wrong_type_argument (Qlistp
, sequence
);
2704 mapcar1 (leni
, 0, function
, sequence
);
2709 /* This is how C code calls `yes-or-no-p' and allows the user
2713 do_yes_or_no_p (Lisp_Object prompt
)
2715 return call1 (intern ("yes-or-no-p"), prompt
);
2718 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2719 doc
: /* Ask user a yes-or-no question.
2720 Return t if answer is yes, and nil if the answer is no.
2721 PROMPT is the string to display to ask the question. It should end in
2722 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2724 The user must confirm the answer with RET, and can edit it until it
2727 If dialog boxes are supported, a dialog box will be used
2728 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2729 (Lisp_Object prompt
)
2733 CHECK_STRING (prompt
);
2735 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2736 && use_dialog_box
&& ! NILP (last_input_event
))
2738 Lisp_Object pane
, menu
, obj
;
2739 redisplay_preserve_echo_area (4);
2740 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2741 Fcons (build_string ("No"), Qnil
));
2742 menu
= Fcons (prompt
, pane
);
2743 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2747 AUTO_STRING (yes_or_no
, "(yes or no) ");
2748 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2752 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2753 Qyes_or_no_p_history
, Qnil
,
2755 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2757 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2762 message1 ("Please answer yes or no.");
2763 Fsleep_for (make_number (2), Qnil
);
2767 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2768 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2770 Each of the three load averages is multiplied by 100, then converted
2773 When USE-FLOATS is non-nil, floats will be used instead of integers.
2774 These floats are not multiplied by 100.
2776 If the 5-minute or 15-minute load averages are not available, return a
2777 shortened list, containing only those averages which are available.
2779 An error is thrown if the load average can't be obtained. In some
2780 cases making it work would require Emacs being installed setuid or
2781 setgid so that it can read kernel information, and that usually isn't
2783 (Lisp_Object use_floats
)
2786 int loads
= getloadavg (load_ave
, 3);
2787 Lisp_Object ret
= Qnil
;
2790 error ("load-average not implemented for this operating system");
2794 Lisp_Object load
= (NILP (use_floats
)
2795 ? make_number (100.0 * load_ave
[loads
])
2796 : make_float (load_ave
[loads
]));
2797 ret
= Fcons (load
, ret
);
2803 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2804 doc
: /* Return t if FEATURE is present in this Emacs.
2806 Use this to conditionalize execution of lisp code based on the
2807 presence or absence of Emacs or environment extensions.
2808 Use `provide' to declare that a feature is available. This function
2809 looks at the value of the variable `features'. The optional argument
2810 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2811 (Lisp_Object feature
, Lisp_Object subfeature
)
2813 register Lisp_Object tem
;
2814 CHECK_SYMBOL (feature
);
2815 tem
= Fmemq (feature
, Vfeatures
);
2816 if (!NILP (tem
) && !NILP (subfeature
))
2817 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2818 return (NILP (tem
)) ? Qnil
: Qt
;
2821 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2822 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2823 The optional argument SUBFEATURES should be a list of symbols listing
2824 particular subfeatures supported in this version of FEATURE. */)
2825 (Lisp_Object feature
, Lisp_Object subfeatures
)
2827 register Lisp_Object tem
;
2828 CHECK_SYMBOL (feature
);
2829 CHECK_LIST (subfeatures
);
2830 if (!NILP (Vautoload_queue
))
2831 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2833 tem
= Fmemq (feature
, Vfeatures
);
2835 Vfeatures
= Fcons (feature
, Vfeatures
);
2836 if (!NILP (subfeatures
))
2837 Fput (feature
, Qsubfeatures
, subfeatures
);
2838 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2840 /* Run any load-hooks for this file. */
2841 tem
= Fassq (feature
, Vafter_load_alist
);
2843 Fmapc (Qfuncall
, XCDR (tem
));
2848 /* `require' and its subroutines. */
2850 /* List of features currently being require'd, innermost first. */
2852 static Lisp_Object require_nesting_list
;
2855 require_unwind (Lisp_Object old_value
)
2857 require_nesting_list
= old_value
;
2860 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2861 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2862 If FEATURE is not a member of the list `features', then the feature
2863 is not loaded; so load the file FILENAME.
2864 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2865 and `load' will try to load this name appended with the suffix `.elc',
2866 `.el', or the system-dependent suffix for dynamic module files, in that
2867 order. The name without appended suffix will not be used.
2868 See `get-load-suffixes' for the complete list of suffixes.
2869 If the optional third argument NOERROR is non-nil,
2870 then return nil if the file is not found instead of signaling an error.
2871 Normally the return value is FEATURE.
2872 The normal messages at start and end of loading FILENAME are suppressed. */)
2873 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2876 bool from_file
= load_in_progress
;
2878 CHECK_SYMBOL (feature
);
2880 /* Record the presence of `require' in this file
2881 even if the feature specified is already loaded.
2882 But not more than once in any file,
2883 and not when we aren't loading or reading from a file. */
2885 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2886 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2891 tem
= Fcons (Qrequire
, feature
);
2892 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2893 LOADHIST_ATTACH (tem
);
2895 tem
= Fmemq (feature
, Vfeatures
);
2899 ptrdiff_t count
= SPECPDL_INDEX ();
2902 /* This is to make sure that loadup.el gives a clear picture
2903 of what files are preloaded and when. */
2904 if (! NILP (Vpurify_flag
))
2905 error ("(require %s) while preparing to dump",
2906 SDATA (SYMBOL_NAME (feature
)));
2908 /* A certain amount of recursive `require' is legitimate,
2909 but if we require the same feature recursively 3 times,
2911 tem
= require_nesting_list
;
2912 while (! NILP (tem
))
2914 if (! NILP (Fequal (feature
, XCAR (tem
))))
2919 error ("Recursive `require' for feature `%s'",
2920 SDATA (SYMBOL_NAME (feature
)));
2922 /* Update the list for any nested `require's that occur. */
2923 record_unwind_protect (require_unwind
, require_nesting_list
);
2924 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2926 /* Value saved here is to be restored into Vautoload_queue */
2927 record_unwind_protect (un_autoload
, Vautoload_queue
);
2928 Vautoload_queue
= Qt
;
2930 /* Load the file. */
2931 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2932 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2934 /* If load failed entirely, return nil. */
2936 return unbind_to (count
, Qnil
);
2938 tem
= Fmemq (feature
, Vfeatures
);
2940 error ("Required feature `%s' was not provided",
2941 SDATA (SYMBOL_NAME (feature
)));
2943 /* Once loading finishes, don't undo it. */
2944 Vautoload_queue
= Qt
;
2945 feature
= unbind_to (count
, feature
);
2951 /* Primitives for work of the "widget" library.
2952 In an ideal world, this section would not have been necessary.
2953 However, lisp function calls being as slow as they are, it turns
2954 out that some functions in the widget library (wid-edit.el) are the
2955 bottleneck of Widget operation. Here is their translation to C,
2956 for the sole reason of efficiency. */
2958 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2959 doc
: /* Return non-nil if PLIST has the property PROP.
2960 PLIST is a property list, which is a list of the form
2961 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2962 Unlike `plist-get', this allows you to distinguish between a missing
2963 property and a property with the value nil.
2964 The value is actually the tail of PLIST whose car is PROP. */)
2965 (Lisp_Object plist
, Lisp_Object prop
)
2967 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2969 plist
= XCDR (plist
);
2970 plist
= CDR (plist
);
2976 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2977 doc
: /* In WIDGET, set PROPERTY to VALUE.
2978 The value can later be retrieved with `widget-get'. */)
2979 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2981 CHECK_CONS (widget
);
2982 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2986 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2987 doc
: /* In WIDGET, get the value of PROPERTY.
2988 The value could either be specified when the widget was created, or
2989 later with `widget-put'. */)
2990 (Lisp_Object widget
, Lisp_Object property
)
2998 CHECK_CONS (widget
);
2999 tmp
= Fplist_member (XCDR (widget
), property
);
3005 tmp
= XCAR (widget
);
3008 widget
= Fget (tmp
, Qwidget_type
);
3012 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3013 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3014 ARGS are passed as extra arguments to the function.
3015 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3016 (ptrdiff_t nargs
, Lisp_Object
*args
)
3018 Lisp_Object widget
= args
[0];
3019 Lisp_Object property
= args
[1];
3020 Lisp_Object propval
= Fwidget_get (widget
, property
);
3021 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
3022 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
3026 #ifdef HAVE_LANGINFO_CODESET
3027 #include <langinfo.h>
3030 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3031 doc
: /* Access locale data ITEM for the current C locale, if available.
3032 ITEM should be one of the following:
3034 `codeset', returning the character set as a string (locale item CODESET);
3036 `days', returning a 7-element vector of day names (locale items DAY_n);
3038 `months', returning a 12-element vector of month names (locale items MON_n);
3040 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3041 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3043 If the system can't provide such information through a call to
3044 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3046 See also Info node `(libc)Locales'.
3048 The data read from the system are decoded using `locale-coding-system'. */)
3052 #ifdef HAVE_LANGINFO_CODESET
3054 if (EQ (item
, Qcodeset
))
3056 str
= nl_langinfo (CODESET
);
3057 return build_string (str
);
3060 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3062 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3063 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3065 synchronize_system_time_locale ();
3066 for (i
= 0; i
< 7; i
++)
3068 str
= nl_langinfo (days
[i
]);
3069 val
= build_unibyte_string (str
);
3070 /* Fixme: Is this coding system necessarily right, even if
3071 it is consistent with CODESET? If not, what to do? */
3072 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3079 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3081 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3082 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3083 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3085 synchronize_system_time_locale ();
3086 for (i
= 0; i
< 12; i
++)
3088 str
= nl_langinfo (months
[i
]);
3089 val
= build_unibyte_string (str
);
3090 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3096 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3097 but is in the locale files. This could be used by ps-print. */
3099 else if (EQ (item
, Qpaper
))
3100 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3101 #endif /* PAPER_WIDTH */
3102 #endif /* HAVE_LANGINFO_CODESET*/
3106 /* base64 encode/decode functions (RFC 2045).
3107 Based on code from GNU recode. */
3109 #define MIME_LINE_LENGTH 76
3111 #define IS_ASCII(Character) \
3113 #define IS_BASE64(Character) \
3114 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3115 #define IS_BASE64_IGNORABLE(Character) \
3116 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3117 || (Character) == '\f' || (Character) == '\r')
3119 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3120 character or return retval if there are no characters left to
3122 #define READ_QUADRUPLET_BYTE(retval) \
3127 if (nchars_return) \
3128 *nchars_return = nchars; \
3133 while (IS_BASE64_IGNORABLE (c))
3135 /* Table of characters coding the 64 values. */
3136 static const char base64_value_to_char
[64] =
3138 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3139 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3140 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3141 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3142 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3143 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3144 '8', '9', '+', '/' /* 60-63 */
3147 /* Table of base64 values for first 128 characters. */
3148 static const short base64_char_to_value
[128] =
3150 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3151 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3152 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3153 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3154 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3155 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3156 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3157 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3158 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3159 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3160 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3161 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3162 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3165 /* The following diagram shows the logical steps by which three octets
3166 get transformed into four base64 characters.
3168 .--------. .--------. .--------.
3169 |aaaaaabb| |bbbbcccc| |ccdddddd|
3170 `--------' `--------' `--------'
3172 .--------+--------+--------+--------.
3173 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3174 `--------+--------+--------+--------'
3176 .--------+--------+--------+--------.
3177 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3178 `--------+--------+--------+--------'
3180 The octets are divided into 6 bit chunks, which are then encoded into
3181 base64 characters. */
3184 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3185 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3188 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3190 doc
: /* Base64-encode the region between BEG and END.
3191 Return the length of the encoded text.
3192 Optional third argument NO-LINE-BREAK means do not break long lines
3193 into shorter lines. */)
3194 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3197 ptrdiff_t allength
, length
;
3198 ptrdiff_t ibeg
, iend
, encoded_length
;
3199 ptrdiff_t old_pos
= PT
;
3202 validate_region (&beg
, &end
);
3204 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3205 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3206 move_gap_both (XFASTINT (beg
), ibeg
);
3208 /* We need to allocate enough room for encoding the text.
3209 We need 33 1/3% more space, plus a newline every 76
3210 characters, and then we round up. */
3211 length
= iend
- ibeg
;
3212 allength
= length
+ length
/3 + 1;
3213 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3215 encoded
= SAFE_ALLOCA (allength
);
3216 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3217 encoded
, length
, NILP (no_line_break
),
3218 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3219 if (encoded_length
> allength
)
3222 if (encoded_length
< 0)
3224 /* The encoding wasn't possible. */
3226 error ("Multibyte character in data for base64 encoding");
3229 /* Now we have encoded the region, so we insert the new contents
3230 and delete the old. (Insert first in order to preserve markers.) */
3231 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3232 insert (encoded
, encoded_length
);
3234 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3236 /* If point was outside of the region, restore it exactly; else just
3237 move to the beginning of the region. */
3238 if (old_pos
>= XFASTINT (end
))
3239 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3240 else if (old_pos
> XFASTINT (beg
))
3241 old_pos
= XFASTINT (beg
);
3244 /* We return the length of the encoded text. */
3245 return make_number (encoded_length
);
3248 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3250 doc
: /* Base64-encode STRING and return the result.
3251 Optional second argument NO-LINE-BREAK means do not break long lines
3252 into shorter lines. */)
3253 (Lisp_Object string
, Lisp_Object no_line_break
)
3255 ptrdiff_t allength
, length
, encoded_length
;
3257 Lisp_Object encoded_string
;
3260 CHECK_STRING (string
);
3262 /* We need to allocate enough room for encoding the text.
3263 We need 33 1/3% more space, plus a newline every 76
3264 characters, and then we round up. */
3265 length
= SBYTES (string
);
3266 allength
= length
+ length
/3 + 1;
3267 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3269 /* We need to allocate enough room for decoding the text. */
3270 encoded
= SAFE_ALLOCA (allength
);
3272 encoded_length
= base64_encode_1 (SSDATA (string
),
3273 encoded
, length
, NILP (no_line_break
),
3274 STRING_MULTIBYTE (string
));
3275 if (encoded_length
> allength
)
3278 if (encoded_length
< 0)
3280 /* The encoding wasn't possible. */
3281 error ("Multibyte character in data for base64 encoding");
3284 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3287 return encoded_string
;
3291 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3292 bool line_break
, bool multibyte
)
3305 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3306 if (CHAR_BYTE8_P (c
))
3307 c
= CHAR_TO_BYTE8 (c
);
3315 /* Wrap line every 76 characters. */
3319 if (counter
< MIME_LINE_LENGTH
/ 4)
3328 /* Process first byte of a triplet. */
3330 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3331 value
= (0x03 & c
) << 4;
3333 /* Process second byte of a triplet. */
3337 *e
++ = base64_value_to_char
[value
];
3345 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3346 if (CHAR_BYTE8_P (c
))
3347 c
= CHAR_TO_BYTE8 (c
);
3355 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3356 value
= (0x0f & c
) << 2;
3358 /* Process third byte of a triplet. */
3362 *e
++ = base64_value_to_char
[value
];
3369 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3370 if (CHAR_BYTE8_P (c
))
3371 c
= CHAR_TO_BYTE8 (c
);
3379 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3380 *e
++ = base64_value_to_char
[0x3f & c
];
3387 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3389 doc
: /* Base64-decode the region between BEG and END.
3390 Return the length of the decoded text.
3391 If the region can't be decoded, signal an error and don't modify the buffer. */)
3392 (Lisp_Object beg
, Lisp_Object end
)
3394 ptrdiff_t ibeg
, iend
, length
, allength
;
3396 ptrdiff_t old_pos
= PT
;
3397 ptrdiff_t decoded_length
;
3398 ptrdiff_t inserted_chars
;
3399 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3402 validate_region (&beg
, &end
);
3404 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3405 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3407 length
= iend
- ibeg
;
3409 /* We need to allocate enough room for decoding the text. If we are
3410 working on a multibyte buffer, each decoded code may occupy at
3412 allength
= multibyte
? length
* 2 : length
;
3413 decoded
= SAFE_ALLOCA (allength
);
3415 move_gap_both (XFASTINT (beg
), ibeg
);
3416 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3418 multibyte
, &inserted_chars
);
3419 if (decoded_length
> allength
)
3422 if (decoded_length
< 0)
3424 /* The decoding wasn't possible. */
3425 error ("Invalid base64 data");
3428 /* Now we have decoded the region, so we insert the new contents
3429 and delete the old. (Insert first in order to preserve markers.) */
3430 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3431 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3434 /* Delete the original text. */
3435 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3436 iend
+ decoded_length
, 1);
3438 /* If point was outside of the region, restore it exactly; else just
3439 move to the beginning of the region. */
3440 if (old_pos
>= XFASTINT (end
))
3441 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3442 else if (old_pos
> XFASTINT (beg
))
3443 old_pos
= XFASTINT (beg
);
3444 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3446 return make_number (inserted_chars
);
3449 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3451 doc
: /* Base64-decode STRING and return the result. */)
3452 (Lisp_Object string
)
3455 ptrdiff_t length
, decoded_length
;
3456 Lisp_Object decoded_string
;
3459 CHECK_STRING (string
);
3461 length
= SBYTES (string
);
3462 /* We need to allocate enough room for decoding the text. */
3463 decoded
= SAFE_ALLOCA (length
);
3465 /* The decoded result should be unibyte. */
3466 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3468 if (decoded_length
> length
)
3470 else if (decoded_length
>= 0)
3471 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3473 decoded_string
= Qnil
;
3476 if (!STRINGP (decoded_string
))
3477 error ("Invalid base64 data");
3479 return decoded_string
;
3482 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3483 MULTIBYTE, the decoded result should be in multibyte
3484 form. If NCHARS_RETURN is not NULL, store the number of produced
3485 characters in *NCHARS_RETURN. */
3488 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3489 bool multibyte
, ptrdiff_t *nchars_return
)
3491 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3494 unsigned long value
;
3495 ptrdiff_t nchars
= 0;
3499 /* Process first byte of a quadruplet. */
3501 READ_QUADRUPLET_BYTE (e
-to
);
3505 value
= base64_char_to_value
[c
] << 18;
3507 /* Process second byte of a quadruplet. */
3509 READ_QUADRUPLET_BYTE (-1);
3513 value
|= base64_char_to_value
[c
] << 12;
3515 c
= (unsigned char) (value
>> 16);
3516 if (multibyte
&& c
>= 128)
3517 e
+= BYTE8_STRING (c
, e
);
3522 /* Process third byte of a quadruplet. */
3524 READ_QUADRUPLET_BYTE (-1);
3528 READ_QUADRUPLET_BYTE (-1);
3537 value
|= base64_char_to_value
[c
] << 6;
3539 c
= (unsigned char) (0xff & value
>> 8);
3540 if (multibyte
&& c
>= 128)
3541 e
+= BYTE8_STRING (c
, e
);
3546 /* Process fourth byte of a quadruplet. */
3548 READ_QUADRUPLET_BYTE (-1);
3555 value
|= base64_char_to_value
[c
];
3557 c
= (unsigned char) (0xff & value
);
3558 if (multibyte
&& c
>= 128)
3559 e
+= BYTE8_STRING (c
, e
);
3568 /***********************************************************************
3570 ***** Hash Tables *****
3572 ***********************************************************************/
3574 /* Implemented by gerd@gnu.org. This hash table implementation was
3575 inspired by CMUCL hash tables. */
3579 1. For small tables, association lists are probably faster than
3580 hash tables because they have lower overhead.
3582 For uses of hash tables where the O(1) behavior of table
3583 operations is not a requirement, it might therefore be a good idea
3584 not to hash. Instead, we could just do a linear search in the
3585 key_and_value vector of the hash table. This could be done
3586 if a `:linear-search t' argument is given to make-hash-table. */
3589 /* The list of all weak hash tables. Don't staticpro this one. */
3591 static struct Lisp_Hash_Table
*weak_hash_tables
;
3594 /***********************************************************************
3596 ***********************************************************************/
3599 CHECK_HASH_TABLE (Lisp_Object x
)
3601 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3605 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3607 h
->key_and_value
= key_and_value
;
3610 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3615 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3617 gc_aset (h
->next
, idx
, val
);
3620 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3625 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3627 gc_aset (h
->hash
, idx
, val
);
3630 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3635 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3637 gc_aset (h
->index
, idx
, val
);
3640 /* If OBJ is a Lisp hash table, return a pointer to its struct
3641 Lisp_Hash_Table. Otherwise, signal an error. */
3643 static struct Lisp_Hash_Table
*
3644 check_hash_table (Lisp_Object obj
)
3646 CHECK_HASH_TABLE (obj
);
3647 return XHASH_TABLE (obj
);
3651 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3652 number. A number is "almost" a prime number if it is not divisible
3653 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3656 next_almost_prime (EMACS_INT n
)
3658 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3659 for (n
|= 1; ; n
+= 2)
3660 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3665 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3666 which USED[I] is non-zero. If found at index I in ARGS, set
3667 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3668 0. This function is used to extract a keyword/argument pair from
3669 a DEFUN parameter list. */
3672 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3676 for (i
= 1; i
< nargs
; i
++)
3677 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3688 /* Return a Lisp vector which has the same contents as VEC but has
3689 at least INCR_MIN more entries, where INCR_MIN is positive.
3690 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3691 than NITEMS_MAX. Entries in the resulting
3692 vector that are not copied from VEC are set to nil. */
3695 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3697 struct Lisp_Vector
*v
;
3698 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3699 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3700 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3701 ? nitems_max
: C_language_max
);
3702 eassert (VECTORP (vec
));
3703 eassert (0 < incr_min
&& -1 <= nitems_max
);
3704 old_size
= ASIZE (vec
);
3705 incr_max
= n_max
- old_size
;
3706 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3707 if (incr_max
< incr
)
3708 memory_full (SIZE_MAX
);
3709 new_size
= old_size
+ incr
;
3710 v
= allocate_vector (new_size
);
3711 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3712 memclear (v
->contents
+ old_size
, incr
* word_size
);
3713 XSETVECTOR (vec
, v
);
3718 /***********************************************************************
3720 ***********************************************************************/
3722 struct hash_table_test hashtest_eq
, hashtest_eql
, hashtest_equal
;
3724 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3725 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3726 KEY2 are the same. */
3729 cmpfn_eql (struct hash_table_test
*ht
,
3733 return (FLOATP (key1
)
3735 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3739 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3740 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3741 KEY2 are the same. */
3744 cmpfn_equal (struct hash_table_test
*ht
,
3748 return !NILP (Fequal (key1
, key2
));
3752 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3753 HASH2 in hash table H using H->user_cmp_function. Value is true
3754 if KEY1 and KEY2 are the same. */
3757 cmpfn_user_defined (struct hash_table_test
*ht
,
3761 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3765 /* Value is a hash code for KEY for use in hash table H which uses
3766 `eq' to compare keys. The hash code returned is guaranteed to fit
3767 in a Lisp integer. */
3770 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3772 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3776 /* Value is a hash code for KEY for use in hash table H which uses
3777 `eql' to compare keys. The hash code returned is guaranteed to fit
3778 in a Lisp integer. */
3781 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3785 hash
= sxhash (key
, 0);
3787 hash
= XHASH (key
) ^ XTYPE (key
);
3791 /* Value is a hash code for KEY for use in hash table H which uses
3792 `equal' to compare keys. The hash code returned is guaranteed to fit
3793 in a Lisp integer. */
3796 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3798 EMACS_UINT hash
= sxhash (key
, 0);
3802 /* Value is a hash code for KEY for use in hash table H which uses as
3803 user-defined function to compare keys. The hash code returned is
3804 guaranteed to fit in a Lisp integer. */
3807 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3809 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3810 return hashfn_eq (ht
, hash
);
3813 /* Allocate basically initialized hash table. */
3815 static struct Lisp_Hash_Table
*
3816 allocate_hash_table (void)
3818 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3819 count
, PVEC_HASH_TABLE
);
3822 /* An upper bound on the size of a hash table index. It must fit in
3823 ptrdiff_t and be a valid Emacs fixnum. */
3824 #define INDEX_SIZE_BOUND \
3825 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3827 /* Create and initialize a new hash table.
3829 TEST specifies the test the hash table will use to compare keys.
3830 It must be either one of the predefined tests `eq', `eql' or
3831 `equal' or a symbol denoting a user-defined test named TEST with
3832 test and hash functions USER_TEST and USER_HASH.
3834 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3836 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3837 new size when it becomes full is computed by adding REHASH_SIZE to
3838 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3839 table's new size is computed by multiplying its old size with
3842 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3843 be resized when the ratio of (number of entries in the table) /
3844 (table size) is >= REHASH_THRESHOLD.
3846 WEAK specifies the weakness of the table. If non-nil, it must be
3847 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3850 make_hash_table (struct hash_table_test test
,
3851 Lisp_Object size
, Lisp_Object rehash_size
,
3852 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3854 struct Lisp_Hash_Table
*h
;
3856 EMACS_INT index_size
, sz
;
3860 /* Preconditions. */
3861 eassert (SYMBOLP (test
.name
));
3862 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3863 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3864 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3865 eassert (FLOATP (rehash_threshold
)
3866 && 0 < XFLOAT_DATA (rehash_threshold
)
3867 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3869 if (XFASTINT (size
) == 0)
3870 size
= make_number (1);
3872 sz
= XFASTINT (size
);
3873 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3874 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3875 ? next_almost_prime (index_float
)
3876 : INDEX_SIZE_BOUND
+ 1);
3877 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3878 error ("Hash table too large");
3880 /* Allocate a table and initialize it. */
3881 h
= allocate_hash_table ();
3883 /* Initialize hash table slots. */
3886 h
->rehash_threshold
= rehash_threshold
;
3887 h
->rehash_size
= rehash_size
;
3889 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3890 h
->hash
= Fmake_vector (size
, Qnil
);
3891 h
->next
= Fmake_vector (size
, Qnil
);
3892 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3894 /* Set up the free list. */
3895 for (i
= 0; i
< sz
- 1; ++i
)
3896 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3897 h
->next_free
= make_number (0);
3899 XSET_HASH_TABLE (table
, h
);
3900 eassert (HASH_TABLE_P (table
));
3901 eassert (XHASH_TABLE (table
) == h
);
3903 /* Maybe add this hash table to the list of all weak hash tables. */
3905 h
->next_weak
= NULL
;
3908 h
->next_weak
= weak_hash_tables
;
3909 weak_hash_tables
= h
;
3916 /* Return a copy of hash table H1. Keys and values are not copied,
3917 only the table itself is. */
3920 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3923 struct Lisp_Hash_Table
*h2
;
3925 h2
= allocate_hash_table ();
3927 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3928 h2
->hash
= Fcopy_sequence (h1
->hash
);
3929 h2
->next
= Fcopy_sequence (h1
->next
);
3930 h2
->index
= Fcopy_sequence (h1
->index
);
3931 XSET_HASH_TABLE (table
, h2
);
3933 /* Maybe add this hash table to the list of all weak hash tables. */
3934 if (!NILP (h2
->weak
))
3936 h2
->next_weak
= weak_hash_tables
;
3937 weak_hash_tables
= h2
;
3944 /* Resize hash table H if it's too full. If H cannot be resized
3945 because it's already too large, throw an error. */
3948 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3950 if (NILP (h
->next_free
))
3952 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3953 EMACS_INT new_size
, index_size
, nsize
;
3957 if (INTEGERP (h
->rehash_size
))
3958 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3961 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3962 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3964 new_size
= float_new_size
;
3965 if (new_size
<= old_size
)
3966 new_size
= old_size
+ 1;
3969 new_size
= INDEX_SIZE_BOUND
+ 1;
3971 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3972 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3973 ? next_almost_prime (index_float
)
3974 : INDEX_SIZE_BOUND
+ 1);
3975 nsize
= max (index_size
, 2 * new_size
);
3976 if (INDEX_SIZE_BOUND
< nsize
)
3977 error ("Hash table too large to resize");
3979 #ifdef ENABLE_CHECKING
3980 if (HASH_TABLE_P (Vpurify_flag
)
3981 && XHASH_TABLE (Vpurify_flag
) == h
)
3982 message ("Growing hash table to: %"pI
"d", new_size
);
3985 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3986 2 * (new_size
- old_size
), -1));
3987 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3988 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3989 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3991 /* Update the free list. Do it so that new entries are added at
3992 the end of the free list. This makes some operations like
3994 for (i
= old_size
; i
< new_size
- 1; ++i
)
3995 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3997 if (!NILP (h
->next_free
))
3999 Lisp_Object last
, next
;
4001 last
= h
->next_free
;
4002 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4006 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
4009 XSETFASTINT (h
->next_free
, old_size
);
4012 for (i
= 0; i
< old_size
; ++i
)
4013 if (!NILP (HASH_HASH (h
, i
)))
4015 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4016 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4017 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4018 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4024 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4025 the hash code of KEY. Value is the index of the entry in H
4026 matching KEY, or -1 if not found. */
4029 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4031 EMACS_UINT hash_code
;
4032 ptrdiff_t start_of_bucket
;
4035 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4036 eassert ((hash_code
& ~INTMASK
) == 0);
4040 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4041 idx
= HASH_INDEX (h
, start_of_bucket
);
4045 ptrdiff_t i
= XFASTINT (idx
);
4046 if (EQ (key
, HASH_KEY (h
, i
))
4048 && hash_code
== XUINT (HASH_HASH (h
, i
))
4049 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4051 idx
= HASH_NEXT (h
, i
);
4054 return NILP (idx
) ? -1 : XFASTINT (idx
);
4058 /* Put an entry into hash table H that associates KEY with VALUE.
4059 HASH is a previously computed hash code of KEY.
4060 Value is the index of the entry in H matching KEY. */
4063 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4066 ptrdiff_t start_of_bucket
, i
;
4068 eassert ((hash
& ~INTMASK
) == 0);
4070 /* Increment count after resizing because resizing may fail. */
4071 maybe_resize_hash_table (h
);
4074 /* Store key/value in the key_and_value vector. */
4075 i
= XFASTINT (h
->next_free
);
4076 h
->next_free
= HASH_NEXT (h
, i
);
4077 set_hash_key_slot (h
, i
, key
);
4078 set_hash_value_slot (h
, i
, value
);
4080 /* Remember its hash code. */
4081 set_hash_hash_slot (h
, i
, make_number (hash
));
4083 /* Add new entry to its collision chain. */
4084 start_of_bucket
= hash
% ASIZE (h
->index
);
4085 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4086 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4091 /* Remove the entry matching KEY from hash table H, if there is one. */
4094 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4096 EMACS_UINT hash_code
;
4097 ptrdiff_t start_of_bucket
;
4098 Lisp_Object idx
, prev
;
4100 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4101 eassert ((hash_code
& ~INTMASK
) == 0);
4102 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4103 idx
= HASH_INDEX (h
, start_of_bucket
);
4108 ptrdiff_t i
= XFASTINT (idx
);
4110 if (EQ (key
, HASH_KEY (h
, i
))
4112 && hash_code
== XUINT (HASH_HASH (h
, i
))
4113 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4115 /* Take entry out of collision chain. */
4117 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4119 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4121 /* Clear slots in key_and_value and add the slots to
4123 set_hash_key_slot (h
, i
, Qnil
);
4124 set_hash_value_slot (h
, i
, Qnil
);
4125 set_hash_hash_slot (h
, i
, Qnil
);
4126 set_hash_next_slot (h
, i
, h
->next_free
);
4127 h
->next_free
= make_number (i
);
4129 eassert (h
->count
>= 0);
4135 idx
= HASH_NEXT (h
, i
);
4141 /* Clear hash table H. */
4144 hash_clear (struct Lisp_Hash_Table
*h
)
4148 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4150 for (i
= 0; i
< size
; ++i
)
4152 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4153 set_hash_key_slot (h
, i
, Qnil
);
4154 set_hash_value_slot (h
, i
, Qnil
);
4155 set_hash_hash_slot (h
, i
, Qnil
);
4158 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4159 ASET (h
->index
, i
, Qnil
);
4161 h
->next_free
= make_number (0);
4168 /************************************************************************
4170 ************************************************************************/
4172 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4173 entries from the table that don't survive the current GC.
4174 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4175 true if anything was marked. */
4178 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4180 ptrdiff_t n
= gc_asize (h
->index
);
4181 bool marked
= false;
4183 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4185 Lisp_Object idx
, next
, prev
;
4187 /* Follow collision chain, removing entries that
4188 don't survive this garbage collection. */
4190 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4192 ptrdiff_t i
= XFASTINT (idx
);
4193 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4194 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4197 if (EQ (h
->weak
, Qkey
))
4198 remove_p
= !key_known_to_survive_p
;
4199 else if (EQ (h
->weak
, Qvalue
))
4200 remove_p
= !value_known_to_survive_p
;
4201 else if (EQ (h
->weak
, Qkey_or_value
))
4202 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4203 else if (EQ (h
->weak
, Qkey_and_value
))
4204 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4208 next
= HASH_NEXT (h
, i
);
4210 if (remove_entries_p
)
4214 /* Take out of collision chain. */
4216 set_hash_index_slot (h
, bucket
, next
);
4218 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4220 /* Add to free list. */
4221 set_hash_next_slot (h
, i
, h
->next_free
);
4224 /* Clear key, value, and hash. */
4225 set_hash_key_slot (h
, i
, Qnil
);
4226 set_hash_value_slot (h
, i
, Qnil
);
4227 set_hash_hash_slot (h
, i
, Qnil
);
4240 /* Make sure key and value survive. */
4241 if (!key_known_to_survive_p
)
4243 mark_object (HASH_KEY (h
, i
));
4247 if (!value_known_to_survive_p
)
4249 mark_object (HASH_VALUE (h
, i
));
4260 /* Remove elements from weak hash tables that don't survive the
4261 current garbage collection. Remove weak tables that don't survive
4262 from Vweak_hash_tables. Called from gc_sweep. */
4264 NO_INLINE
/* For better stack traces */
4266 sweep_weak_hash_tables (void)
4268 struct Lisp_Hash_Table
*h
, *used
, *next
;
4271 /* Mark all keys and values that are in use. Keep on marking until
4272 there is no more change. This is necessary for cases like
4273 value-weak table A containing an entry X -> Y, where Y is used in a
4274 key-weak table B, Z -> Y. If B comes after A in the list of weak
4275 tables, X -> Y might be removed from A, although when looking at B
4276 one finds that it shouldn't. */
4280 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4282 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4283 marked
|= sweep_weak_table (h
, 0);
4288 /* Remove tables and entries that aren't used. */
4289 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4291 next
= h
->next_weak
;
4293 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4295 /* TABLE is marked as used. Sweep its contents. */
4297 sweep_weak_table (h
, 1);
4299 /* Add table to the list of used weak hash tables. */
4300 h
->next_weak
= used
;
4305 weak_hash_tables
= used
;
4310 /***********************************************************************
4311 Hash Code Computation
4312 ***********************************************************************/
4314 /* Maximum depth up to which to dive into Lisp structures. */
4316 #define SXHASH_MAX_DEPTH 3
4318 /* Maximum length up to which to take list and vector elements into
4321 #define SXHASH_MAX_LEN 7
4323 /* Return a hash for string PTR which has length LEN. The hash value
4324 can be any EMACS_UINT value. */
4327 hash_string (char const *ptr
, ptrdiff_t len
)
4329 char const *p
= ptr
;
4330 char const *end
= p
+ len
;
4332 EMACS_UINT hash
= 0;
4337 hash
= sxhash_combine (hash
, c
);
4343 /* Return a hash for string PTR which has length LEN. The hash
4344 code returned is guaranteed to fit in a Lisp integer. */
4347 sxhash_string (char const *ptr
, ptrdiff_t len
)
4349 EMACS_UINT hash
= hash_string (ptr
, len
);
4350 return SXHASH_REDUCE (hash
);
4353 /* Return a hash for the floating point value VAL. */
4356 sxhash_float (double val
)
4358 EMACS_UINT hash
= 0;
4360 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4361 + (sizeof val
% sizeof hash
!= 0))
4365 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4369 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4370 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4371 hash
= sxhash_combine (hash
, u
.word
[i
]);
4372 return SXHASH_REDUCE (hash
);
4375 /* Return a hash for list LIST. DEPTH is the current depth in the
4376 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4379 sxhash_list (Lisp_Object list
, int depth
)
4381 EMACS_UINT hash
= 0;
4384 if (depth
< SXHASH_MAX_DEPTH
)
4386 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4387 list
= XCDR (list
), ++i
)
4389 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4390 hash
= sxhash_combine (hash
, hash2
);
4395 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4396 hash
= sxhash_combine (hash
, hash2
);
4399 return SXHASH_REDUCE (hash
);
4403 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4404 the Lisp structure. */
4407 sxhash_vector (Lisp_Object vec
, int depth
)
4409 EMACS_UINT hash
= ASIZE (vec
);
4412 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4413 for (i
= 0; i
< n
; ++i
)
4415 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4416 hash
= sxhash_combine (hash
, hash2
);
4419 return SXHASH_REDUCE (hash
);
4422 /* Return a hash for bool-vector VECTOR. */
4425 sxhash_bool_vector (Lisp_Object vec
)
4427 EMACS_INT size
= bool_vector_size (vec
);
4428 EMACS_UINT hash
= size
;
4431 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4432 for (i
= 0; i
< n
; ++i
)
4433 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4435 return SXHASH_REDUCE (hash
);
4439 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4440 structure. Value is an unsigned integer clipped to INTMASK. */
4443 sxhash (Lisp_Object obj
, int depth
)
4447 if (depth
> SXHASH_MAX_DEPTH
)
4450 switch (XTYPE (obj
))
4462 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4465 /* This can be everything from a vector to an overlay. */
4466 case Lisp_Vectorlike
:
4468 /* According to the CL HyperSpec, two arrays are equal only if
4469 they are `eq', except for strings and bit-vectors. In
4470 Emacs, this works differently. We have to compare element
4472 hash
= sxhash_vector (obj
, depth
);
4473 else if (BOOL_VECTOR_P (obj
))
4474 hash
= sxhash_bool_vector (obj
);
4476 /* Others are `equal' if they are `eq', so let's take their
4482 hash
= sxhash_list (obj
, depth
);
4486 hash
= sxhash_float (XFLOAT_DATA (obj
));
4498 /***********************************************************************
4500 ***********************************************************************/
4503 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4504 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4507 EMACS_UINT hash
= sxhash (obj
, 0);
4508 return make_number (hash
);
4512 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4513 doc
: /* Create and return a new hash table.
4515 Arguments are specified as keyword/argument pairs. The following
4516 arguments are defined:
4518 :test TEST -- TEST must be a symbol that specifies how to compare
4519 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4520 `equal'. User-supplied test and hash functions can be specified via
4521 `define-hash-table-test'.
4523 :size SIZE -- A hint as to how many elements will be put in the table.
4526 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4527 fills up. If REHASH-SIZE is an integer, increase the size by that
4528 amount. If it is a float, it must be > 1.0, and the new size is the
4529 old size multiplied by that factor. Default is 1.5.
4531 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4532 Resize the hash table when the ratio (number of entries / table size)
4533 is greater than or equal to THRESHOLD. Default is 0.8.
4535 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4536 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4537 returned is a weak table. Key/value pairs are removed from a weak
4538 hash table when there are no non-weak references pointing to their
4539 key, value, one of key or value, or both key and value, depending on
4540 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4543 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4544 (ptrdiff_t nargs
, Lisp_Object
*args
)
4546 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4547 struct hash_table_test testdesc
;
4551 /* The vector `used' is used to keep track of arguments that
4552 have been consumed. */
4553 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4554 memset (used
, 0, nargs
* sizeof *used
);
4556 /* See if there's a `:test TEST' among the arguments. */
4557 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4558 test
= i
? args
[i
] : Qeql
;
4560 testdesc
= hashtest_eq
;
4561 else if (EQ (test
, Qeql
))
4562 testdesc
= hashtest_eql
;
4563 else if (EQ (test
, Qequal
))
4564 testdesc
= hashtest_equal
;
4567 /* See if it is a user-defined test. */
4570 prop
= Fget (test
, Qhash_table_test
);
4571 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4572 signal_error ("Invalid hash table test", test
);
4573 testdesc
.name
= test
;
4574 testdesc
.user_cmp_function
= XCAR (prop
);
4575 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4576 testdesc
.hashfn
= hashfn_user_defined
;
4577 testdesc
.cmpfn
= cmpfn_user_defined
;
4580 /* See if there's a `:size SIZE' argument. */
4581 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4582 size
= i
? args
[i
] : Qnil
;
4584 size
= make_number (DEFAULT_HASH_SIZE
);
4585 else if (!INTEGERP (size
) || XINT (size
) < 0)
4586 signal_error ("Invalid hash table size", size
);
4588 /* Look for `:rehash-size SIZE'. */
4589 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4590 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4591 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4592 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4593 signal_error ("Invalid hash table rehash size", rehash_size
);
4595 /* Look for `:rehash-threshold THRESHOLD'. */
4596 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4597 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4598 if (! (FLOATP (rehash_threshold
)
4599 && 0 < XFLOAT_DATA (rehash_threshold
)
4600 && XFLOAT_DATA (rehash_threshold
) <= 1))
4601 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4603 /* Look for `:weakness WEAK'. */
4604 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4605 weak
= i
? args
[i
] : Qnil
;
4607 weak
= Qkey_and_value
;
4610 && !EQ (weak
, Qvalue
)
4611 && !EQ (weak
, Qkey_or_value
)
4612 && !EQ (weak
, Qkey_and_value
))
4613 signal_error ("Invalid hash table weakness", weak
);
4615 /* Now, all args should have been used up, or there's a problem. */
4616 for (i
= 0; i
< nargs
; ++i
)
4618 signal_error ("Invalid argument list", args
[i
]);
4621 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4625 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4626 doc
: /* Return a copy of hash table TABLE. */)
4629 return copy_hash_table (check_hash_table (table
));
4633 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4634 doc
: /* Return the number of elements in TABLE. */)
4637 return make_number (check_hash_table (table
)->count
);
4641 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4642 Shash_table_rehash_size
, 1, 1, 0,
4643 doc
: /* Return the current rehash size of TABLE. */)
4646 return check_hash_table (table
)->rehash_size
;
4650 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4651 Shash_table_rehash_threshold
, 1, 1, 0,
4652 doc
: /* Return the current rehash threshold of TABLE. */)
4655 return check_hash_table (table
)->rehash_threshold
;
4659 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4660 doc
: /* Return the size of TABLE.
4661 The size can be used as an argument to `make-hash-table' to create
4662 a hash table than can hold as many elements as TABLE holds
4663 without need for resizing. */)
4666 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4667 return make_number (HASH_TABLE_SIZE (h
));
4671 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4672 doc
: /* Return the test TABLE uses. */)
4675 return check_hash_table (table
)->test
.name
;
4679 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4681 doc
: /* Return the weakness of TABLE. */)
4684 return check_hash_table (table
)->weak
;
4688 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4689 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4692 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4696 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4697 doc
: /* Clear hash table TABLE and return it. */)
4700 hash_clear (check_hash_table (table
));
4701 /* Be compatible with XEmacs. */
4706 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4707 doc
: /* Look up KEY in TABLE and return its associated value.
4708 If KEY is not found, return DFLT which defaults to nil. */)
4709 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4711 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4712 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4713 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4717 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4718 doc
: /* Associate KEY with VALUE in hash table TABLE.
4719 If KEY is already present in table, replace its current value with
4720 VALUE. In any case, return VALUE. */)
4721 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4723 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4727 i
= hash_lookup (h
, key
, &hash
);
4729 set_hash_value_slot (h
, i
, value
);
4731 hash_put (h
, key
, value
, hash
);
4737 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4738 doc
: /* Remove KEY from TABLE. */)
4739 (Lisp_Object key
, Lisp_Object table
)
4741 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4742 hash_remove_from_table (h
, key
);
4747 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4748 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4749 FUNCTION is called with two arguments, KEY and VALUE.
4750 `maphash' always returns nil. */)
4751 (Lisp_Object function
, Lisp_Object table
)
4753 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4755 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4756 if (!NILP (HASH_HASH (h
, i
)))
4757 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4763 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4764 Sdefine_hash_table_test
, 3, 3, 0,
4765 doc
: /* Define a new hash table test with name NAME, a symbol.
4767 In hash tables created with NAME specified as test, use TEST to
4768 compare keys, and HASH for computing hash codes of keys.
4770 TEST must be a function taking two arguments and returning non-nil if
4771 both arguments are the same. HASH must be a function taking one
4772 argument and returning an object that is the hash code of the argument.
4773 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4774 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4775 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4777 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4782 /************************************************************************
4783 MD5, SHA-1, and SHA-2
4784 ************************************************************************/
4791 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4794 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4795 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4799 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4800 register EMACS_INT b
, e
;
4801 register struct buffer
*bp
;
4804 void *(*hash_func
) (const char *, size_t, void *);
4807 CHECK_SYMBOL (algorithm
);
4809 if (STRINGP (object
))
4811 if (NILP (coding_system
))
4813 /* Decide the coding-system to encode the data with. */
4815 if (STRING_MULTIBYTE (object
))
4816 /* use default, we can't guess correct value */
4817 coding_system
= preferred_coding_system ();
4819 coding_system
= Qraw_text
;
4822 if (NILP (Fcoding_system_p (coding_system
)))
4824 /* Invalid coding system. */
4826 if (!NILP (noerror
))
4827 coding_system
= Qraw_text
;
4829 xsignal1 (Qcoding_system_error
, coding_system
);
4832 if (STRING_MULTIBYTE (object
))
4833 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4835 size
= SCHARS (object
);
4836 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4838 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4839 end_byte
= (end_char
== size
4841 : string_char_to_byte (object
, end_char
));
4845 struct buffer
*prev
= current_buffer
;
4847 record_unwind_current_buffer ();
4849 CHECK_BUFFER (object
);
4851 bp
= XBUFFER (object
);
4852 set_buffer_internal (bp
);
4858 CHECK_NUMBER_COERCE_MARKER (start
);
4866 CHECK_NUMBER_COERCE_MARKER (end
);
4871 temp
= b
, b
= e
, e
= temp
;
4873 if (!(BEGV
<= b
&& e
<= ZV
))
4874 args_out_of_range (start
, end
);
4876 if (NILP (coding_system
))
4878 /* Decide the coding-system to encode the data with.
4879 See fileio.c:Fwrite-region */
4881 if (!NILP (Vcoding_system_for_write
))
4882 coding_system
= Vcoding_system_for_write
;
4885 bool force_raw_text
= 0;
4887 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4888 if (NILP (coding_system
)
4889 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4891 coding_system
= Qnil
;
4892 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4896 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4898 /* Check file-coding-system-alist. */
4899 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4900 Qwrite_region
, start
, end
,
4901 Fbuffer_file_name (object
));
4902 if (CONSP (val
) && !NILP (XCDR (val
)))
4903 coding_system
= XCDR (val
);
4906 if (NILP (coding_system
)
4907 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4909 /* If we still have not decided a coding system, use the
4910 default value of buffer-file-coding-system. */
4911 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4915 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4916 /* Confirm that VAL can surely encode the current region. */
4917 coding_system
= call4 (Vselect_safe_coding_system_function
,
4918 make_number (b
), make_number (e
),
4919 coding_system
, Qnil
);
4922 coding_system
= Qraw_text
;
4925 if (NILP (Fcoding_system_p (coding_system
)))
4927 /* Invalid coding system. */
4929 if (!NILP (noerror
))
4930 coding_system
= Qraw_text
;
4932 xsignal1 (Qcoding_system_error
, coding_system
);
4936 object
= make_buffer_string (b
, e
, 0);
4937 set_buffer_internal (prev
);
4938 /* Discard the unwind protect for recovering the current
4942 if (STRING_MULTIBYTE (object
))
4943 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4945 end_byte
= SBYTES (object
);
4948 if (EQ (algorithm
, Qmd5
))
4950 digest_size
= MD5_DIGEST_SIZE
;
4951 hash_func
= md5_buffer
;
4953 else if (EQ (algorithm
, Qsha1
))
4955 digest_size
= SHA1_DIGEST_SIZE
;
4956 hash_func
= sha1_buffer
;
4958 else if (EQ (algorithm
, Qsha224
))
4960 digest_size
= SHA224_DIGEST_SIZE
;
4961 hash_func
= sha224_buffer
;
4963 else if (EQ (algorithm
, Qsha256
))
4965 digest_size
= SHA256_DIGEST_SIZE
;
4966 hash_func
= sha256_buffer
;
4968 else if (EQ (algorithm
, Qsha384
))
4970 digest_size
= SHA384_DIGEST_SIZE
;
4971 hash_func
= sha384_buffer
;
4973 else if (EQ (algorithm
, Qsha512
))
4975 digest_size
= SHA512_DIGEST_SIZE
;
4976 hash_func
= sha512_buffer
;
4979 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4981 /* allocate 2 x digest_size so that it can be re-used to hold the
4983 digest
= make_uninit_string (digest_size
* 2);
4985 hash_func (SSDATA (object
) + start_byte
,
4986 end_byte
- start_byte
,
4991 unsigned char *p
= SDATA (digest
);
4992 for (i
= digest_size
- 1; i
>= 0; i
--)
4994 static char const hexdigit
[16] = "0123456789abcdef";
4996 p
[2 * i
] = hexdigit
[p_i
>> 4];
4997 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5002 return make_unibyte_string (SSDATA (digest
), digest_size
);
5005 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5006 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5008 A message digest is a cryptographic checksum of a document, and the
5009 algorithm to calculate it is defined in RFC 1321.
5011 The two optional arguments START and END are character positions
5012 specifying for which part of OBJECT the message digest should be
5013 computed. If nil or omitted, the digest is computed for the whole
5016 The MD5 message digest is computed from the result of encoding the
5017 text in a coding system, not directly from the internal Emacs form of
5018 the text. The optional fourth argument CODING-SYSTEM specifies which
5019 coding system to encode the text with. It should be the same coding
5020 system that you used or will use when actually writing the text into a
5023 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5024 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5025 system would be chosen by default for writing this text into a file.
5027 If OBJECT is a string, the most preferred coding system (see the
5028 command `prefer-coding-system') is used.
5030 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5031 guesswork fails. Normally, an error is signaled in such case. */)
5032 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5034 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5037 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5038 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5039 ALGORITHM is a symbol specifying the hash to use:
5040 md5, sha1, sha224, sha256, sha384 or sha512.
5042 The two optional arguments START and END are positions specifying for
5043 which part of OBJECT to compute the hash. If nil or omitted, uses the
5046 If BINARY is non-nil, returns a string in binary form. */)
5047 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5049 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5055 DEFSYM (Qmd5
, "md5");
5056 DEFSYM (Qsha1
, "sha1");
5057 DEFSYM (Qsha224
, "sha224");
5058 DEFSYM (Qsha256
, "sha256");
5059 DEFSYM (Qsha384
, "sha384");
5060 DEFSYM (Qsha512
, "sha512");
5062 /* Hash table stuff. */
5063 DEFSYM (Qhash_table_p
, "hash-table-p");
5065 DEFSYM (Qeql
, "eql");
5066 DEFSYM (Qequal
, "equal");
5067 DEFSYM (QCtest
, ":test");
5068 DEFSYM (QCsize
, ":size");
5069 DEFSYM (QCrehash_size
, ":rehash-size");
5070 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5071 DEFSYM (QCweakness
, ":weakness");
5072 DEFSYM (Qkey
, "key");
5073 DEFSYM (Qvalue
, "value");
5074 DEFSYM (Qhash_table_test
, "hash-table-test");
5075 DEFSYM (Qkey_or_value
, "key-or-value");
5076 DEFSYM (Qkey_and_value
, "key-and-value");
5079 defsubr (&Smake_hash_table
);
5080 defsubr (&Scopy_hash_table
);
5081 defsubr (&Shash_table_count
);
5082 defsubr (&Shash_table_rehash_size
);
5083 defsubr (&Shash_table_rehash_threshold
);
5084 defsubr (&Shash_table_size
);
5085 defsubr (&Shash_table_test
);
5086 defsubr (&Shash_table_weakness
);
5087 defsubr (&Shash_table_p
);
5088 defsubr (&Sclrhash
);
5089 defsubr (&Sgethash
);
5090 defsubr (&Sputhash
);
5091 defsubr (&Sremhash
);
5092 defsubr (&Smaphash
);
5093 defsubr (&Sdefine_hash_table_test
);
5095 DEFSYM (Qstring_lessp
, "string-lessp");
5096 DEFSYM (Qprovide
, "provide");
5097 DEFSYM (Qrequire
, "require");
5098 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5099 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5100 DEFSYM (Qwidget_type
, "widget-type");
5102 staticpro (&string_char_byte_cache_string
);
5103 string_char_byte_cache_string
= Qnil
;
5105 require_nesting_list
= Qnil
;
5106 staticpro (&require_nesting_list
);
5108 Fset (Qyes_or_no_p_history
, Qnil
);
5110 DEFVAR_LISP ("features", Vfeatures
,
5111 doc
: /* A list of symbols which are the features of the executing Emacs.
5112 Used by `featurep' and `require', and altered by `provide'. */);
5113 Vfeatures
= list1 (Qemacs
);
5114 DEFSYM (Qsubfeatures
, "subfeatures");
5115 DEFSYM (Qfuncall
, "funcall");
5117 #ifdef HAVE_LANGINFO_CODESET
5118 DEFSYM (Qcodeset
, "codeset");
5119 DEFSYM (Qdays
, "days");
5120 DEFSYM (Qmonths
, "months");
5121 DEFSYM (Qpaper
, "paper");
5122 #endif /* HAVE_LANGINFO_CODESET */
5124 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5125 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5126 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5127 invoked by mouse clicks and mouse menu items.
5129 On some platforms, file selection dialogs are also enabled if this is
5133 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5134 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5135 This applies to commands from menus and tool bar buttons even when
5136 they are initiated from the keyboard. If `use-dialog-box' is nil,
5137 that disables the use of a file dialog, regardless of the value of
5139 use_file_dialog
= 1;
5141 defsubr (&Sidentity
);
5144 defsubr (&Ssafe_length
);
5145 defsubr (&Sstring_bytes
);
5146 defsubr (&Sstring_equal
);
5147 defsubr (&Scompare_strings
);
5148 defsubr (&Sstring_lessp
);
5149 defsubr (&Sstring_numeric_lessp
);
5150 defsubr (&Sstring_collate_lessp
);
5151 defsubr (&Sstring_collate_equalp
);
5154 defsubr (&Svconcat
);
5155 defsubr (&Scopy_sequence
);
5156 defsubr (&Sstring_make_multibyte
);
5157 defsubr (&Sstring_make_unibyte
);
5158 defsubr (&Sstring_as_multibyte
);
5159 defsubr (&Sstring_as_unibyte
);
5160 defsubr (&Sstring_to_multibyte
);
5161 defsubr (&Sstring_to_unibyte
);
5162 defsubr (&Scopy_alist
);
5163 defsubr (&Ssubstring
);
5164 defsubr (&Ssubstring_no_properties
);
5177 defsubr (&Snreverse
);
5178 defsubr (&Sreverse
);
5180 defsubr (&Splist_get
);
5182 defsubr (&Splist_put
);
5184 defsubr (&Slax_plist_get
);
5185 defsubr (&Slax_plist_put
);
5188 defsubr (&Sequal_including_properties
);
5189 defsubr (&Sfillarray
);
5190 defsubr (&Sclear_string
);
5194 defsubr (&Smapconcat
);
5195 defsubr (&Syes_or_no_p
);
5196 defsubr (&Sload_average
);
5197 defsubr (&Sfeaturep
);
5198 defsubr (&Srequire
);
5199 defsubr (&Sprovide
);
5200 defsubr (&Splist_member
);
5201 defsubr (&Swidget_put
);
5202 defsubr (&Swidget_get
);
5203 defsubr (&Swidget_apply
);
5204 defsubr (&Sbase64_encode_region
);
5205 defsubr (&Sbase64_decode_region
);
5206 defsubr (&Sbase64_encode_string
);
5207 defsubr (&Sbase64_decode_string
);
5209 defsubr (&Ssecure_hash
);
5210 defsubr (&Slocale_info
);
5212 hashtest_eq
.name
= Qeq
;
5213 hashtest_eq
.user_hash_function
= Qnil
;
5214 hashtest_eq
.user_cmp_function
= Qnil
;
5215 hashtest_eq
.cmpfn
= 0;
5216 hashtest_eq
.hashfn
= hashfn_eq
;
5218 hashtest_eql
.name
= Qeql
;
5219 hashtest_eql
.user_hash_function
= Qnil
;
5220 hashtest_eql
.user_cmp_function
= Qnil
;
5221 hashtest_eql
.cmpfn
= cmpfn_eql
;
5222 hashtest_eql
.hashfn
= hashfn_eql
;
5224 hashtest_equal
.name
= Qequal
;
5225 hashtest_equal
.user_hash_function
= Qnil
;
5226 hashtest_equal
.user_cmp_function
= Qnil
;
5227 hashtest_equal
.cmpfn
= cmpfn_equal
;
5228 hashtest_equal
.hashfn
= hashfn_equal
;