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/>. */
29 #include "character.h"
31 #include "composite.h"
33 #include "intervals.h"
36 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
37 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
38 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
40 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
41 doc
: /* Return the argument unchanged. */
48 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
49 doc
: /* Return a pseudo-random number.
50 All integers representable in Lisp, i.e. between `most-negative-fixnum'
51 and `most-positive-fixnum', inclusive, are equally likely.
53 With positive integer LIMIT, return random number in interval [0,LIMIT).
54 With argument t, set the random number seed from the system's entropy
55 pool if available, otherwise from less-random volatile data such as the time.
56 With a string argument, set the seed based on the string's contents.
57 Other values of LIMIT are ignored.
59 See Info node `(elisp)Random Numbers' for more details. */)
66 else if (STRINGP (limit
))
67 seed_random (SSDATA (limit
), SBYTES (limit
));
70 if (INTEGERP (limit
) && 0 < XINT (limit
))
73 /* Return the remainder, except reject the rare case where
74 get_random returns a number so close to INTMASK that the
75 remainder isn't random. */
76 EMACS_INT remainder
= val
% XINT (limit
);
77 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
78 return make_number (remainder
);
81 return make_number (val
);
84 /* Heuristic on how many iterations of a tight loop can be safely done
85 before it's time to do a QUIT. This must be a power of 2. */
86 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
88 /* Random data-structure functions. */
91 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
93 CHECK_TYPE (NILP (x
), Qlistp
, y
);
96 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
97 doc
: /* Return the length of vector, list or string SEQUENCE.
98 A byte-code function object is also allowed.
99 If the string contains multibyte characters, this is not necessarily
100 the number of bytes in the string; it is the number of characters.
101 To get the number of bytes, use `string-bytes'. */)
102 (register Lisp_Object sequence
)
104 register Lisp_Object val
;
106 if (STRINGP (sequence
))
107 XSETFASTINT (val
, SCHARS (sequence
));
108 else if (VECTORP (sequence
))
109 XSETFASTINT (val
, ASIZE (sequence
));
110 else if (CHAR_TABLE_P (sequence
))
111 XSETFASTINT (val
, MAX_CHAR
);
112 else if (BOOL_VECTOR_P (sequence
))
113 XSETFASTINT (val
, bool_vector_size (sequence
));
114 else if (COMPILEDP (sequence
))
115 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
116 else if (CONSP (sequence
))
123 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
125 if (MOST_POSITIVE_FIXNUM
< i
)
126 error ("List too long");
129 sequence
= XCDR (sequence
);
131 while (CONSP (sequence
));
133 CHECK_LIST_END (sequence
, sequence
);
135 val
= make_number (i
);
137 else if (NILP (sequence
))
138 XSETFASTINT (val
, 0);
140 wrong_type_argument (Qsequencep
, sequence
);
145 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
146 doc
: /* Return the length of a list, but avoid error or infinite loop.
147 This function never gets an error. If LIST is not really a list,
148 it returns 0. If LIST is circular, it returns a finite value
149 which is at least the number of distinct elements. */)
152 Lisp_Object tail
, halftail
;
157 return make_number (0);
159 /* halftail is used to detect circular lists. */
160 for (tail
= halftail
= list
; ; )
165 if (EQ (tail
, halftail
))
168 if ((lolen
& 1) == 0)
170 halftail
= XCDR (halftail
);
171 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
175 hilen
+= UINTMAX_MAX
+ 1.0;
180 /* If the length does not fit into a fixnum, return a float.
181 On all known practical machines this returns an upper bound on
183 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
186 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
187 doc
: /* Return the number of bytes in STRING.
188 If STRING is multibyte, this may be greater than the length of STRING. */)
191 CHECK_STRING (string
);
192 return make_number (SBYTES (string
));
195 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
196 doc
: /* Return t if two strings have identical contents.
197 Case is significant, but text properties are ignored.
198 Symbols are also allowed; their print names are used instead. */)
199 (register Lisp_Object s1
, Lisp_Object s2
)
202 s1
= SYMBOL_NAME (s1
);
204 s2
= SYMBOL_NAME (s2
);
208 if (SCHARS (s1
) != SCHARS (s2
)
209 || SBYTES (s1
) != SBYTES (s2
)
210 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
215 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
216 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
217 The arguments START1, END1, START2, and END2, if non-nil, are
218 positions specifying which parts of STR1 or STR2 to compare. In
219 string STR1, compare the part between START1 (inclusive) and END1
220 (exclusive). If START1 is nil, it defaults to 0, the beginning of
221 the string; if END1 is nil, it defaults to the length of the string.
222 Likewise, in string STR2, compare the part between START2 and END2.
223 Like in `substring', negative values are counted from the end.
225 The strings are compared by the numeric values of their characters.
226 For instance, STR1 is "less than" STR2 if its first differing
227 character has a smaller numeric value. If IGNORE-CASE is non-nil,
228 characters are converted to lower-case before comparing them. Unibyte
229 strings are converted to multibyte for comparison.
231 The value is t if the strings (or specified portions) match.
232 If string STR1 is less, the value is a negative number N;
233 - 1 - N is the number of characters that match at the beginning.
234 If string STR1 is greater, the value is a positive number N;
235 N - 1 is the number of characters that match at the beginning. */)
236 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
237 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
239 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
244 /* For backward compatibility, silently bring too-large positive end
245 values into range. */
246 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
247 end1
= make_number (SCHARS (str1
));
248 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
249 end2
= make_number (SCHARS (str2
));
251 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
252 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
257 i1_byte
= string_char_to_byte (str1
, i1
);
258 i2_byte
= string_char_to_byte (str2
, i2
);
260 while (i1
< to1
&& i2
< to2
)
262 /* When we find a mismatch, we must compare the
263 characters, not just the bytes. */
266 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
267 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
272 if (! NILP (ignore_case
))
274 c1
= XINT (Fupcase (make_number (c1
)));
275 c2
= XINT (Fupcase (make_number (c2
)));
281 /* Note that I1 has already been incremented
282 past the character that we are comparing;
283 hence we don't add or subtract 1 here. */
285 return make_number (- i1
+ from1
);
287 return make_number (i1
- from1
);
291 return make_number (i1
- from1
+ 1);
293 return make_number (- i1
+ from1
- 1);
298 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
299 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
301 Symbols are also allowed; their print names are used instead. */)
302 (register Lisp_Object string1
, Lisp_Object string2
)
304 register ptrdiff_t end
;
305 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
307 if (SYMBOLP (string1
))
308 string1
= SYMBOL_NAME (string1
);
309 if (SYMBOLP (string2
))
310 string2
= SYMBOL_NAME (string2
);
311 CHECK_STRING (string1
);
312 CHECK_STRING (string2
);
314 i1
= i1_byte
= i2
= i2_byte
= 0;
316 end
= SCHARS (string1
);
317 if (end
> SCHARS (string2
))
318 end
= SCHARS (string2
);
322 /* When we find a mismatch, we must compare the
323 characters, not just the bytes. */
326 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
327 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
330 return c1
< c2
? Qt
: Qnil
;
332 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
335 /* Return the numerical value of a consecutive run of numerical
336 characters from STRING. The ISP and ISP_BYTE address pointer
337 pointers are increased and left at the next character after the
338 numerical characters. */
340 gather_number_from_string (Lisp_Object string
,
341 ptrdiff_t *isp
, ptrdiff_t *isp_byte
)
344 char *s
= SSDATA (string
);
348 number
= strtoumax (s
+ *isp_byte
, &end
, 10);
350 /* If we have an integer overflow, then we fall back on lexical
355 size_t diff
= end
- (s
+ *isp_byte
);
362 DEFUN ("string-numeric-lessp", Fstring_numeric_lessp
,
363 Sstring_numeric_lessp
, 2, 2, 0,
364 doc
: /* Return non-nil if STRING1 is less than STRING2 in 'numeric' order.
365 Sequences of non-numerical characters are compared lexicographically,
366 while sequences of numerical characters are converted into numbers,
367 and then the numbers are compared. This means that \"foo2.png\" is
368 less than \"foo12.png\" according to this predicate.
370 Symbols are also allowed; their print names are used instead. */)
371 (register Lisp_Object string1
, Lisp_Object string2
)
374 ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
379 if (SYMBOLP (string1
))
380 string1
= SYMBOL_NAME (string1
);
381 if (SYMBOLP (string2
))
382 string2
= SYMBOL_NAME (string2
);
383 CHECK_STRING (string1
);
384 CHECK_STRING (string2
);
386 i1
= i1_byte
= i2
= i2_byte
= 0;
388 end
= SCHARS (string1
);
389 if (end
> SCHARS (string2
))
390 end
= SCHARS (string2
);
394 /* When we find a mismatch, we must compare the
395 characters, not just the bytes. */
398 if (STRING_MULTIBYTE (string1
))
400 chp
= &SDATA (string1
)[i1_byte
];
401 c1
= STRING_CHAR_AND_LENGTH (chp
, chlen1
);
405 c1
= SREF (string1
, i1_byte
);
409 if (STRING_MULTIBYTE (string2
))
411 chp
= &SDATA (string1
)[i2_byte
];
412 c2
= STRING_CHAR_AND_LENGTH (chp
, chlen2
);
416 c2
= SREF (string2
, i2_byte
);
420 if (c1
>= '0' && c1
<= '9' &&
421 c2
>= '0' && c2
<= '9')
422 /* Both strings are numbers, so compare them. */
424 num1
= gather_number_from_string (string1
, &i1
, &i1_byte
);
425 num2
= gather_number_from_string (string2
, &i2
, &i2_byte
);
426 /* If we have an integer overflow, then resort to sorting
427 the entire string lexicographically. */
428 if (num1
== -1 || num2
== -1)
429 return Fstring_lessp (string1
, string2
);
430 else if (num1
< num2
)
432 else if (num1
> num2
)
438 return c1
< c2
? Qt
: Qnil
;
446 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
449 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
450 doc
: /* Return t if first arg string is less than second in collation order.
451 Symbols are also allowed; their print names are used instead.
453 This function obeys the conventions for collation order in your
454 locale settings. For example, punctuation and whitespace characters
455 might be considered less significant for sorting:
457 (sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
458 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
460 The optional argument LOCALE, a string, overrides the setting of your
461 current locale identifier for collation. The value is system
462 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
463 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
465 If IGNORE-CASE is non-nil, characters are converted to lower-case
466 before comparing them.
468 To emulate Unicode-compliant collation on MS-Windows systems,
469 bind `w32-collate-ignore-punctuation' to a non-nil value, since
470 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
472 If your system does not support a locale environment, this function
473 behaves like `string-lessp'. */)
474 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
476 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
477 /* Check parameters. */
479 s1
= SYMBOL_NAME (s1
);
481 s2
= SYMBOL_NAME (s2
);
485 CHECK_STRING (locale
);
487 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
489 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
490 return Fstring_lessp (s1
, s2
);
491 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
494 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
495 doc
: /* Return t if two strings have identical contents.
496 Symbols are also allowed; their print names are used instead.
498 This function obeys the conventions for collation order in your locale
499 settings. For example, characters with different coding points but
500 the same meaning might be considered as equal, like different grave
501 accent Unicode characters:
503 (string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
506 The optional argument LOCALE, a string, overrides the setting of your
507 current locale identifier for collation. The value is system
508 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
509 while it would be \"enu_USA.1252\" on MS Windows systems.
511 If IGNORE-CASE is non-nil, characters are converted to lower-case
512 before comparing them.
514 To emulate Unicode-compliant collation on MS-Windows systems,
515 bind `w32-collate-ignore-punctuation' to a non-nil value, since
516 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
518 If your system does not support a locale environment, this function
519 behaves like `string-equal'.
521 Do NOT use this function to compare file names for equality, only
522 for sorting them. */)
523 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
525 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
526 /* Check parameters. */
528 s1
= SYMBOL_NAME (s1
);
530 s2
= SYMBOL_NAME (s2
);
534 CHECK_STRING (locale
);
536 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
538 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
539 return Fstring_equal (s1
, s2
);
540 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
543 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
544 enum Lisp_Type target_type
, bool last_special
);
548 concat2 (Lisp_Object s1
, Lisp_Object s2
)
550 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
555 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
557 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
560 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
561 doc
: /* Concatenate all the arguments and make the result a list.
562 The result is a list whose elements are the elements of all the arguments.
563 Each argument may be a list, vector or string.
564 The last argument is not copied, just used as the tail of the new list.
565 usage: (append &rest SEQUENCES) */)
566 (ptrdiff_t nargs
, Lisp_Object
*args
)
568 return concat (nargs
, args
, Lisp_Cons
, 1);
571 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
572 doc
: /* Concatenate all the arguments and make the result a string.
573 The result is a string whose elements are the elements of all the arguments.
574 Each argument may be a string or a list or vector of characters (integers).
575 usage: (concat &rest SEQUENCES) */)
576 (ptrdiff_t nargs
, Lisp_Object
*args
)
578 return concat (nargs
, args
, Lisp_String
, 0);
581 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
582 doc
: /* Concatenate all the arguments and make the result a vector.
583 The result is a vector whose elements are the elements of all the arguments.
584 Each argument may be a list, vector or string.
585 usage: (vconcat &rest SEQUENCES) */)
586 (ptrdiff_t nargs
, Lisp_Object
*args
)
588 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
592 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
593 doc
: /* Return a copy of a list, vector, string or char-table.
594 The elements of a list or vector are not copied; they are shared
595 with the original. */)
598 if (NILP (arg
)) return arg
;
600 if (CHAR_TABLE_P (arg
))
602 return copy_char_table (arg
);
605 if (BOOL_VECTOR_P (arg
))
607 EMACS_INT nbits
= bool_vector_size (arg
);
608 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
609 Lisp_Object val
= make_uninit_bool_vector (nbits
);
610 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
614 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
615 wrong_type_argument (Qsequencep
, arg
);
617 return concat (1, &arg
, XTYPE (arg
), 0);
620 /* This structure holds information of an argument of `concat' that is
621 a string and has text properties to be copied. */
624 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
625 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
626 ptrdiff_t to
; /* refer to VAL (the target string) */
630 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
631 enum Lisp_Type target_type
, bool last_special
)
637 ptrdiff_t toindex_byte
= 0;
638 EMACS_INT result_len
;
639 EMACS_INT result_len_byte
;
641 Lisp_Object last_tail
;
644 /* When we make a multibyte string, we can't copy text properties
645 while concatenating each string because the length of resulting
646 string can't be decided until we finish the whole concatenation.
647 So, we record strings that have text properties to be copied
648 here, and copy the text properties after the concatenation. */
649 struct textprop_rec
*textprops
= NULL
;
650 /* Number of elements in textprops. */
651 ptrdiff_t num_textprops
= 0;
656 /* In append, the last arg isn't treated like the others */
657 if (last_special
&& nargs
> 0)
660 last_tail
= args
[nargs
];
665 /* Check each argument. */
666 for (argnum
= 0; argnum
< nargs
; argnum
++)
669 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
670 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
671 wrong_type_argument (Qsequencep
, this);
674 /* Compute total length in chars of arguments in RESULT_LEN.
675 If desired output is a string, also compute length in bytes
676 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
677 whether the result should be a multibyte string. */
681 for (argnum
= 0; argnum
< nargs
; argnum
++)
685 len
= XFASTINT (Flength (this));
686 if (target_type
== Lisp_String
)
688 /* We must count the number of bytes needed in the string
689 as well as the number of characters. */
693 ptrdiff_t this_len_byte
;
695 if (VECTORP (this) || COMPILEDP (this))
696 for (i
= 0; i
< len
; i
++)
699 CHECK_CHARACTER (ch
);
701 this_len_byte
= CHAR_BYTES (c
);
702 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
704 result_len_byte
+= this_len_byte
;
705 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
708 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
709 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
710 else if (CONSP (this))
711 for (; CONSP (this); this = XCDR (this))
714 CHECK_CHARACTER (ch
);
716 this_len_byte
= CHAR_BYTES (c
);
717 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
719 result_len_byte
+= this_len_byte
;
720 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
723 else if (STRINGP (this))
725 if (STRING_MULTIBYTE (this))
728 this_len_byte
= SBYTES (this);
731 this_len_byte
= count_size_as_multibyte (SDATA (this),
733 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
735 result_len_byte
+= this_len_byte
;
740 if (MOST_POSITIVE_FIXNUM
< result_len
)
741 memory_full (SIZE_MAX
);
744 if (! some_multibyte
)
745 result_len_byte
= result_len
;
747 /* Create the output object. */
748 if (target_type
== Lisp_Cons
)
749 val
= Fmake_list (make_number (result_len
), Qnil
);
750 else if (target_type
== Lisp_Vectorlike
)
751 val
= Fmake_vector (make_number (result_len
), Qnil
);
752 else if (some_multibyte
)
753 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
755 val
= make_uninit_string (result_len
);
757 /* In `append', if all but last arg are nil, return last arg. */
758 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
761 /* Copy the contents of the args into the result. */
763 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
765 toindex
= 0, toindex_byte
= 0;
769 SAFE_NALLOCA (textprops
, 1, nargs
);
771 for (argnum
= 0; argnum
< nargs
; argnum
++)
774 ptrdiff_t thisleni
= 0;
775 register ptrdiff_t thisindex
= 0;
776 register ptrdiff_t thisindex_byte
= 0;
780 thislen
= Flength (this), thisleni
= XINT (thislen
);
782 /* Between strings of the same kind, copy fast. */
783 if (STRINGP (this) && STRINGP (val
)
784 && STRING_MULTIBYTE (this) == some_multibyte
)
786 ptrdiff_t thislen_byte
= SBYTES (this);
788 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
789 if (string_intervals (this))
791 textprops
[num_textprops
].argnum
= argnum
;
792 textprops
[num_textprops
].from
= 0;
793 textprops
[num_textprops
++].to
= toindex
;
795 toindex_byte
+= thislen_byte
;
798 /* Copy a single-byte string to a multibyte string. */
799 else if (STRINGP (this) && STRINGP (val
))
801 if (string_intervals (this))
803 textprops
[num_textprops
].argnum
= argnum
;
804 textprops
[num_textprops
].from
= 0;
805 textprops
[num_textprops
++].to
= toindex
;
807 toindex_byte
+= copy_text (SDATA (this),
808 SDATA (val
) + toindex_byte
,
809 SCHARS (this), 0, 1);
813 /* Copy element by element. */
816 register Lisp_Object elt
;
818 /* Fetch next element of `this' arg into `elt', or break if
819 `this' is exhausted. */
820 if (NILP (this)) break;
822 elt
= XCAR (this), this = XCDR (this);
823 else if (thisindex
>= thisleni
)
825 else if (STRINGP (this))
828 if (STRING_MULTIBYTE (this))
829 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
834 c
= SREF (this, thisindex
); thisindex
++;
835 if (some_multibyte
&& !ASCII_CHAR_P (c
))
836 c
= BYTE8_TO_CHAR (c
);
838 XSETFASTINT (elt
, c
);
840 else if (BOOL_VECTOR_P (this))
842 elt
= bool_vector_ref (this, thisindex
);
847 elt
= AREF (this, thisindex
);
851 /* Store this element into the result. */
858 else if (VECTORP (val
))
860 ASET (val
, toindex
, elt
);
866 CHECK_CHARACTER (elt
);
869 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
871 SSET (val
, toindex_byte
++, c
);
877 XSETCDR (prev
, last_tail
);
879 if (num_textprops
> 0)
882 ptrdiff_t last_to_end
= -1;
884 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
886 this = args
[textprops
[argnum
].argnum
];
887 props
= text_property_list (this,
889 make_number (SCHARS (this)),
891 /* If successive arguments have properties, be sure that the
892 value of `composition' property be the copy. */
893 if (last_to_end
== textprops
[argnum
].to
)
894 make_composition_value_copy (props
);
895 add_text_properties_from_list (val
, props
,
896 make_number (textprops
[argnum
].to
));
897 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
905 static Lisp_Object string_char_byte_cache_string
;
906 static ptrdiff_t string_char_byte_cache_charpos
;
907 static ptrdiff_t string_char_byte_cache_bytepos
;
910 clear_string_char_byte_cache (void)
912 string_char_byte_cache_string
= Qnil
;
915 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
918 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
921 ptrdiff_t best_below
, best_below_byte
;
922 ptrdiff_t best_above
, best_above_byte
;
924 best_below
= best_below_byte
= 0;
925 best_above
= SCHARS (string
);
926 best_above_byte
= SBYTES (string
);
927 if (best_above
== best_above_byte
)
930 if (EQ (string
, string_char_byte_cache_string
))
932 if (string_char_byte_cache_charpos
< char_index
)
934 best_below
= string_char_byte_cache_charpos
;
935 best_below_byte
= string_char_byte_cache_bytepos
;
939 best_above
= string_char_byte_cache_charpos
;
940 best_above_byte
= string_char_byte_cache_bytepos
;
944 if (char_index
- best_below
< best_above
- char_index
)
946 unsigned char *p
= SDATA (string
) + best_below_byte
;
948 while (best_below
< char_index
)
950 p
+= BYTES_BY_CHAR_HEAD (*p
);
953 i_byte
= p
- SDATA (string
);
957 unsigned char *p
= SDATA (string
) + best_above_byte
;
959 while (best_above
> char_index
)
962 while (!CHAR_HEAD_P (*p
)) p
--;
965 i_byte
= p
- SDATA (string
);
968 string_char_byte_cache_bytepos
= i_byte
;
969 string_char_byte_cache_charpos
= char_index
;
970 string_char_byte_cache_string
= string
;
975 /* Return the character index corresponding to BYTE_INDEX in STRING. */
978 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
981 ptrdiff_t best_below
, best_below_byte
;
982 ptrdiff_t best_above
, best_above_byte
;
984 best_below
= best_below_byte
= 0;
985 best_above
= SCHARS (string
);
986 best_above_byte
= SBYTES (string
);
987 if (best_above
== best_above_byte
)
990 if (EQ (string
, string_char_byte_cache_string
))
992 if (string_char_byte_cache_bytepos
< byte_index
)
994 best_below
= string_char_byte_cache_charpos
;
995 best_below_byte
= string_char_byte_cache_bytepos
;
999 best_above
= string_char_byte_cache_charpos
;
1000 best_above_byte
= string_char_byte_cache_bytepos
;
1004 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
1006 unsigned char *p
= SDATA (string
) + best_below_byte
;
1007 unsigned char *pend
= SDATA (string
) + byte_index
;
1011 p
+= BYTES_BY_CHAR_HEAD (*p
);
1015 i_byte
= p
- SDATA (string
);
1019 unsigned char *p
= SDATA (string
) + best_above_byte
;
1020 unsigned char *pbeg
= SDATA (string
) + byte_index
;
1025 while (!CHAR_HEAD_P (*p
)) p
--;
1029 i_byte
= p
- SDATA (string
);
1032 string_char_byte_cache_bytepos
= i_byte
;
1033 string_char_byte_cache_charpos
= i
;
1034 string_char_byte_cache_string
= string
;
1039 /* Convert STRING to a multibyte string. */
1042 string_make_multibyte (Lisp_Object string
)
1049 if (STRING_MULTIBYTE (string
))
1052 nbytes
= count_size_as_multibyte (SDATA (string
),
1054 /* If all the chars are ASCII, they won't need any more bytes
1055 once converted. In that case, we can return STRING itself. */
1056 if (nbytes
== SBYTES (string
))
1059 buf
= SAFE_ALLOCA (nbytes
);
1060 copy_text (SDATA (string
), buf
, SBYTES (string
),
1063 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1070 /* Convert STRING (if unibyte) to a multibyte string without changing
1071 the number of characters. Characters 0200 trough 0237 are
1072 converted to eight-bit characters. */
1075 string_to_multibyte (Lisp_Object string
)
1082 if (STRING_MULTIBYTE (string
))
1085 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1086 /* If all the chars are ASCII, they won't need any more bytes once
1088 if (nbytes
== SBYTES (string
))
1089 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1091 buf
= SAFE_ALLOCA (nbytes
);
1092 memcpy (buf
, SDATA (string
), SBYTES (string
));
1093 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1095 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1102 /* Convert STRING to a single-byte string. */
1105 string_make_unibyte (Lisp_Object string
)
1112 if (! STRING_MULTIBYTE (string
))
1115 nchars
= SCHARS (string
);
1117 buf
= SAFE_ALLOCA (nchars
);
1118 copy_text (SDATA (string
), buf
, SBYTES (string
),
1121 ret
= make_unibyte_string ((char *) buf
, nchars
);
1127 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1129 doc
: /* Return the multibyte equivalent of STRING.
1130 If STRING is unibyte and contains non-ASCII characters, the function
1131 `unibyte-char-to-multibyte' is used to convert each unibyte character
1132 to a multibyte character. In this case, the returned string is a
1133 newly created string with no text properties. If STRING is multibyte
1134 or entirely ASCII, it is returned unchanged. In particular, when
1135 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1136 (When the characters are all ASCII, Emacs primitives will treat the
1137 string the same way whether it is unibyte or multibyte.) */)
1138 (Lisp_Object string
)
1140 CHECK_STRING (string
);
1142 return string_make_multibyte (string
);
1145 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1147 doc
: /* Return the unibyte equivalent of STRING.
1148 Multibyte character codes are converted to unibyte according to
1149 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1150 If the lookup in the translation table fails, this function takes just
1151 the low 8 bits of each character. */)
1152 (Lisp_Object string
)
1154 CHECK_STRING (string
);
1156 return string_make_unibyte (string
);
1159 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1161 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1162 If STRING is unibyte, the result is STRING itself.
1163 Otherwise it is a newly created string, with no text properties.
1164 If STRING is multibyte and contains a character of charset
1165 `eight-bit', it is converted to the corresponding single byte. */)
1166 (Lisp_Object string
)
1168 CHECK_STRING (string
);
1170 if (STRING_MULTIBYTE (string
))
1172 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1173 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1175 string
= make_unibyte_string ((char *) str
, bytes
);
1181 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1183 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1184 If STRING is multibyte, the result is STRING itself.
1185 Otherwise it is a newly created string, with no text properties.
1187 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1188 part of a correct utf-8 sequence), it is converted to the corresponding
1189 multibyte character of charset `eight-bit'.
1190 See also `string-to-multibyte'.
1192 Beware, this often doesn't really do what you think it does.
1193 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1194 If you're not sure, whether to use `string-as-multibyte' or
1195 `string-to-multibyte', use `string-to-multibyte'. */)
1196 (Lisp_Object string
)
1198 CHECK_STRING (string
);
1200 if (! STRING_MULTIBYTE (string
))
1202 Lisp_Object new_string
;
1203 ptrdiff_t nchars
, nbytes
;
1205 parse_str_as_multibyte (SDATA (string
),
1208 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1209 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1210 if (nbytes
!= SBYTES (string
))
1211 str_as_multibyte (SDATA (new_string
), nbytes
,
1212 SBYTES (string
), NULL
);
1213 string
= new_string
;
1214 set_string_intervals (string
, NULL
);
1219 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1221 doc
: /* Return a multibyte string with the same individual chars as STRING.
1222 If STRING is multibyte, the result is STRING itself.
1223 Otherwise it is a newly created string, with no text properties.
1225 If STRING is unibyte and contains an 8-bit byte, it is converted to
1226 the corresponding multibyte character of charset `eight-bit'.
1228 This differs from `string-as-multibyte' by converting each byte of a correct
1229 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1230 correct sequence. */)
1231 (Lisp_Object string
)
1233 CHECK_STRING (string
);
1235 return string_to_multibyte (string
);
1238 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1240 doc
: /* Return a unibyte string with the same individual chars as STRING.
1241 If STRING is unibyte, the result is STRING itself.
1242 Otherwise it is a newly created string, with no text properties,
1243 where each `eight-bit' character is converted to the corresponding byte.
1244 If STRING contains a non-ASCII, non-`eight-bit' character,
1245 an error is signaled. */)
1246 (Lisp_Object string
)
1248 CHECK_STRING (string
);
1250 if (STRING_MULTIBYTE (string
))
1252 ptrdiff_t chars
= SCHARS (string
);
1253 unsigned char *str
= xmalloc (chars
);
1254 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1256 if (converted
< chars
)
1257 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1258 string
= make_unibyte_string ((char *) str
, chars
);
1265 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1266 doc
: /* Return a copy of ALIST.
1267 This is an alist which represents the same mapping from objects to objects,
1268 but does not share the alist structure with ALIST.
1269 The objects mapped (cars and cdrs of elements of the alist)
1270 are shared, however.
1271 Elements of ALIST that are not conses are also shared. */)
1274 register Lisp_Object tem
;
1279 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1280 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1282 register Lisp_Object car
;
1286 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1291 /* Check that ARRAY can have a valid subarray [FROM..TO),
1292 given that its size is SIZE.
1293 If FROM is nil, use 0; if TO is nil, use SIZE.
1294 Count negative values backwards from the end.
1295 Set *IFROM and *ITO to the two indexes used. */
1298 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1299 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1303 if (INTEGERP (from
))
1309 else if (NILP (from
))
1312 wrong_type_argument (Qintegerp
, from
);
1323 wrong_type_argument (Qintegerp
, to
);
1325 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1326 args_out_of_range_3 (array
, from
, to
);
1332 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1333 doc
: /* Return a new string whose contents are a substring of STRING.
1334 The returned string consists of the characters between index FROM
1335 (inclusive) and index TO (exclusive) of STRING. FROM and TO are
1336 zero-indexed: 0 means the first character of STRING. Negative values
1337 are counted from the end of STRING. If TO is nil, the substring runs
1338 to the end of STRING.
1340 The STRING argument may also be a vector. In that case, the return
1341 value is a new vector that contains the elements between index FROM
1342 (inclusive) and index TO (exclusive) of that vector argument.
1344 With one argument, just copy STRING (with properties, if any). */)
1345 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1348 ptrdiff_t size
, ifrom
, ito
;
1350 size
= CHECK_VECTOR_OR_STRING (string
);
1351 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1353 if (STRINGP (string
))
1356 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1358 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1359 res
= make_specified_string (SSDATA (string
) + from_byte
,
1360 ito
- ifrom
, to_byte
- from_byte
,
1361 STRING_MULTIBYTE (string
));
1362 copy_text_properties (make_number (ifrom
), make_number (ito
),
1363 string
, make_number (0), res
, Qnil
);
1366 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1372 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1373 doc
: /* Return a substring of STRING, without text properties.
1374 It starts at index FROM and ends before TO.
1375 TO may be nil or omitted; then the substring runs to the end of STRING.
1376 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1377 If FROM or TO is negative, it counts from the end.
1379 With one argument, just copy STRING without its properties. */)
1380 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1382 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1384 CHECK_STRING (string
);
1386 size
= SCHARS (string
);
1387 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1389 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1391 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1392 return make_specified_string (SSDATA (string
) + from_byte
,
1393 to_char
- from_char
, to_byte
- from_byte
,
1394 STRING_MULTIBYTE (string
));
1397 /* Extract a substring of STRING, giving start and end positions
1398 both in characters and in bytes. */
1401 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1402 ptrdiff_t to
, ptrdiff_t to_byte
)
1405 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1407 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1408 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1410 if (STRINGP (string
))
1412 res
= make_specified_string (SSDATA (string
) + from_byte
,
1413 to
- from
, to_byte
- from_byte
,
1414 STRING_MULTIBYTE (string
));
1415 copy_text_properties (make_number (from
), make_number (to
),
1416 string
, make_number (0), res
, Qnil
);
1419 res
= Fvector (to
- from
, aref_addr (string
, from
));
1424 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1425 doc
: /* Take cdr N times on LIST, return the result. */)
1426 (Lisp_Object n
, Lisp_Object list
)
1431 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1434 CHECK_LIST_CONS (list
, list
);
1440 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1441 doc
: /* Return the Nth element of LIST.
1442 N counts from zero. If LIST is not that long, nil is returned. */)
1443 (Lisp_Object n
, Lisp_Object list
)
1445 return Fcar (Fnthcdr (n
, list
));
1448 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1449 doc
: /* Return element of SEQUENCE at index N. */)
1450 (register Lisp_Object sequence
, Lisp_Object n
)
1453 if (CONSP (sequence
) || NILP (sequence
))
1454 return Fcar (Fnthcdr (n
, sequence
));
1456 /* Faref signals a "not array" error, so check here. */
1457 CHECK_ARRAY (sequence
, Qsequencep
);
1458 return Faref (sequence
, n
);
1461 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1462 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1463 The value is actually the tail of LIST whose car is ELT. */)
1464 (register Lisp_Object elt
, Lisp_Object list
)
1466 register Lisp_Object tail
;
1467 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1469 register Lisp_Object tem
;
1470 CHECK_LIST_CONS (tail
, list
);
1472 if (! NILP (Fequal (elt
, tem
)))
1479 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1480 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1481 The value is actually the tail of LIST whose car is ELT. */)
1482 (register Lisp_Object elt
, Lisp_Object list
)
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1490 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1494 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1505 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1506 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1507 The value is actually the tail of LIST whose car is ELT. */)
1508 (register Lisp_Object elt
, Lisp_Object list
)
1510 register Lisp_Object tail
;
1513 return Fmemq (elt
, list
);
1515 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1517 register Lisp_Object tem
;
1518 CHECK_LIST_CONS (tail
, list
);
1520 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1527 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1528 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1529 The value is actually the first element of LIST whose car is KEY.
1530 Elements of LIST that are not conses are ignored. */)
1531 (Lisp_Object key
, Lisp_Object list
)
1536 || (CONSP (XCAR (list
))
1537 && EQ (XCAR (XCAR (list
)), key
)))
1542 || (CONSP (XCAR (list
))
1543 && EQ (XCAR (XCAR (list
)), key
)))
1548 || (CONSP (XCAR (list
))
1549 && EQ (XCAR (XCAR (list
)), key
)))
1559 /* Like Fassq but never report an error and do not allow quits.
1560 Use only on lists known never to be circular. */
1563 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1566 && (!CONSP (XCAR (list
))
1567 || !EQ (XCAR (XCAR (list
)), key
)))
1570 return CAR_SAFE (list
);
1573 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1574 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1575 The value is actually the first element of LIST whose car equals KEY. */)
1576 (Lisp_Object key
, Lisp_Object list
)
1583 || (CONSP (XCAR (list
))
1584 && (car
= XCAR (XCAR (list
)),
1585 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1590 || (CONSP (XCAR (list
))
1591 && (car
= XCAR (XCAR (list
)),
1592 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1597 || (CONSP (XCAR (list
))
1598 && (car
= XCAR (XCAR (list
)),
1599 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1609 /* Like Fassoc but never report an error and do not allow quits.
1610 Use only on lists known never to be circular. */
1613 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1616 && (!CONSP (XCAR (list
))
1617 || (!EQ (XCAR (XCAR (list
)), key
)
1618 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1621 return CONSP (list
) ? XCAR (list
) : Qnil
;
1624 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1625 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1626 The value is actually the first element of LIST whose cdr is KEY. */)
1627 (register Lisp_Object key
, Lisp_Object list
)
1632 || (CONSP (XCAR (list
))
1633 && EQ (XCDR (XCAR (list
)), key
)))
1638 || (CONSP (XCAR (list
))
1639 && EQ (XCDR (XCAR (list
)), key
)))
1644 || (CONSP (XCAR (list
))
1645 && EQ (XCDR (XCAR (list
)), key
)))
1655 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1656 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1657 The value is actually the first element of LIST whose cdr equals KEY. */)
1658 (Lisp_Object key
, Lisp_Object list
)
1665 || (CONSP (XCAR (list
))
1666 && (cdr
= XCDR (XCAR (list
)),
1667 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1672 || (CONSP (XCAR (list
))
1673 && (cdr
= XCDR (XCAR (list
)),
1674 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1679 || (CONSP (XCAR (list
))
1680 && (cdr
= XCDR (XCAR (list
)),
1681 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1691 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1692 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1693 More precisely, this function skips any members `eq' to ELT at the
1694 front of LIST, then removes members `eq' to ELT from the remaining
1695 sublist by modifying its list structure, then returns the resulting
1698 Write `(setq foo (delq element foo))' to be sure of correctly changing
1699 the value of a list `foo'. See also `remq', which does not modify the
1701 (register Lisp_Object elt
, Lisp_Object list
)
1703 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1706 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1708 Lisp_Object tem
= XCAR (tail
);
1714 Fsetcdr (prev
, XCDR (tail
));
1722 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1723 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1724 SEQ must be a sequence (i.e. a list, a vector, or a string).
1725 The return value is a sequence of the same type.
1727 If SEQ is a list, this behaves like `delq', except that it compares
1728 with `equal' instead of `eq'. In particular, it may remove elements
1729 by altering the list structure.
1731 If SEQ is not a list, deletion is never performed destructively;
1732 instead this function creates and returns a new vector or string.
1734 Write `(setq foo (delete element foo))' to be sure of correctly
1735 changing the value of a sequence `foo'. */)
1736 (Lisp_Object elt
, Lisp_Object seq
)
1742 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1743 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1746 if (n
!= ASIZE (seq
))
1748 struct Lisp_Vector
*p
= allocate_vector (n
);
1750 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1751 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1752 p
->contents
[n
++] = AREF (seq
, i
);
1754 XSETVECTOR (seq
, p
);
1757 else if (STRINGP (seq
))
1759 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1762 for (i
= nchars
= nbytes
= ibyte
= 0;
1764 ++i
, ibyte
+= cbytes
)
1766 if (STRING_MULTIBYTE (seq
))
1768 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1769 cbytes
= CHAR_BYTES (c
);
1777 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1784 if (nchars
!= SCHARS (seq
))
1788 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1789 if (!STRING_MULTIBYTE (seq
))
1790 STRING_SET_UNIBYTE (tem
);
1792 for (i
= nchars
= nbytes
= ibyte
= 0;
1794 ++i
, ibyte
+= cbytes
)
1796 if (STRING_MULTIBYTE (seq
))
1798 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1799 cbytes
= CHAR_BYTES (c
);
1807 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1809 unsigned char *from
= SDATA (seq
) + ibyte
;
1810 unsigned char *to
= SDATA (tem
) + nbytes
;
1816 for (n
= cbytes
; n
--; )
1826 Lisp_Object tail
, prev
;
1828 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1830 CHECK_LIST_CONS (tail
, seq
);
1832 if (!NILP (Fequal (elt
, XCAR (tail
))))
1837 Fsetcdr (prev
, XCDR (tail
));
1848 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1849 doc
: /* Reverse order of items in a list, vector or string SEQ.
1850 If SEQ is a list, it should be nil-terminated.
1851 This function may destructively modify SEQ to produce the value. */)
1856 else if (STRINGP (seq
))
1857 return Freverse (seq
);
1858 else if (CONSP (seq
))
1860 Lisp_Object prev
, tail
, next
;
1862 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1865 CHECK_LIST_CONS (tail
, tail
);
1867 Fsetcdr (tail
, prev
);
1872 else if (VECTORP (seq
))
1874 ptrdiff_t i
, size
= ASIZE (seq
);
1876 for (i
= 0; i
< size
/ 2; i
++)
1878 Lisp_Object tem
= AREF (seq
, i
);
1879 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1880 ASET (seq
, size
- i
- 1, tem
);
1883 else if (BOOL_VECTOR_P (seq
))
1885 ptrdiff_t i
, size
= bool_vector_size (seq
);
1887 for (i
= 0; i
< size
/ 2; i
++)
1889 bool tem
= bool_vector_bitref (seq
, i
);
1890 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1891 bool_vector_set (seq
, size
- i
- 1, tem
);
1895 wrong_type_argument (Qarrayp
, seq
);
1899 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1900 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1901 See also the function `nreverse', which is used more often. */)
1908 else if (CONSP (seq
))
1910 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1913 new = Fcons (XCAR (seq
), new);
1915 CHECK_LIST_END (seq
, seq
);
1917 else if (VECTORP (seq
))
1919 ptrdiff_t i
, size
= ASIZE (seq
);
1921 new = make_uninit_vector (size
);
1922 for (i
= 0; i
< size
; i
++)
1923 ASET (new, i
, AREF (seq
, size
- i
- 1));
1925 else if (BOOL_VECTOR_P (seq
))
1928 EMACS_INT nbits
= bool_vector_size (seq
);
1930 new = make_uninit_bool_vector (nbits
);
1931 for (i
= 0; i
< nbits
; i
++)
1932 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1934 else if (STRINGP (seq
))
1936 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1942 new = make_uninit_string (size
);
1943 for (i
= 0; i
< size
; i
++)
1944 SSET (new, i
, SREF (seq
, size
- i
- 1));
1948 unsigned char *p
, *q
;
1950 new = make_uninit_multibyte_string (size
, bytes
);
1951 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1952 while (q
> SDATA (new))
1956 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1958 CHAR_STRING (ch
, q
);
1963 wrong_type_argument (Qsequencep
, seq
);
1967 /* Sort LIST using PREDICATE, preserving original order of elements
1968 considered as equal. */
1971 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1973 Lisp_Object front
, back
;
1974 Lisp_Object len
, tem
;
1978 len
= Flength (list
);
1979 length
= XINT (len
);
1983 XSETINT (len
, (length
/ 2) - 1);
1984 tem
= Fnthcdr (len
, list
);
1986 Fsetcdr (tem
, Qnil
);
1988 front
= Fsort (front
, predicate
);
1989 back
= Fsort (back
, predicate
);
1990 return merge (front
, back
, predicate
);
1993 /* Using PRED to compare, return whether A and B are in order.
1994 Compare stably when A appeared before B in the input. */
1996 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1998 return NILP (call2 (pred
, b
, a
));
2001 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
2002 into DEST. Argument arrays must be nonempty and must not overlap,
2003 except that B might be the last part of DEST. */
2005 merge_vectors (Lisp_Object pred
,
2006 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
2007 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
2008 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
2010 eassume (0 < alen
&& 0 < blen
);
2011 Lisp_Object
const *alim
= a
+ alen
;
2012 Lisp_Object
const *blim
= b
+ blen
;
2016 if (inorder (pred
, a
[0], b
[0]))
2022 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
2031 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
2038 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
2039 temporary storage. LEN must be at least 2. */
2041 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
2042 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
2043 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
2046 ptrdiff_t halflen
= len
>> 1;
2047 sort_vector_copy (pred
, halflen
, vec
, tmp
);
2048 if (1 < len
- halflen
)
2049 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
2050 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
2053 /* Using PRED to compare, sort from LEN-length SRC into DST.
2054 Len must be positive. */
2056 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
2057 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
2058 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
2061 ptrdiff_t halflen
= len
>> 1;
2067 sort_vector_inplace (pred
, halflen
, src
, dest
);
2068 if (1 < len
- halflen
)
2069 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
2070 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
2074 /* Sort VECTOR in place using PREDICATE, preserving original order of
2075 elements considered as equal. */
2078 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
2080 ptrdiff_t len
= ASIZE (vector
);
2083 ptrdiff_t halflen
= len
>> 1;
2086 SAFE_ALLOCA_LISP (tmp
, halflen
);
2087 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
2088 tmp
[i
] = make_number (0);
2089 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2093 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2094 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2095 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2096 modified by side effects. PREDICATE is called with two elements of
2097 SEQ, and should return non-nil if the first element should sort before
2099 (Lisp_Object seq
, Lisp_Object predicate
)
2102 seq
= sort_list (seq
, predicate
);
2103 else if (VECTORP (seq
))
2104 sort_vector (seq
, predicate
);
2105 else if (!NILP (seq
))
2106 wrong_type_argument (Qsequencep
, seq
);
2111 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2113 Lisp_Object l1
= org_l1
;
2114 Lisp_Object l2
= org_l2
;
2115 Lisp_Object tail
= Qnil
;
2116 Lisp_Object value
= Qnil
;
2136 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2151 Fsetcdr (tail
, tem
);
2157 /* This does not check for quits. That is safe since it must terminate. */
2159 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2160 doc
: /* Extract a value from a property list.
2161 PLIST is a property list, which is a list of the form
2162 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2163 corresponding to the given PROP, or nil if PROP is not one of the
2164 properties on the list. This function never signals an error. */)
2165 (Lisp_Object plist
, Lisp_Object prop
)
2167 Lisp_Object tail
, halftail
;
2169 /* halftail is used to detect circular lists. */
2170 tail
= halftail
= plist
;
2171 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2173 if (EQ (prop
, XCAR (tail
)))
2174 return XCAR (XCDR (tail
));
2176 tail
= XCDR (XCDR (tail
));
2177 halftail
= XCDR (halftail
);
2178 if (EQ (tail
, halftail
))
2185 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2186 doc
: /* Return the value of SYMBOL's PROPNAME property.
2187 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2188 (Lisp_Object symbol
, Lisp_Object propname
)
2190 CHECK_SYMBOL (symbol
);
2191 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2194 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2195 doc
: /* Change value in PLIST of PROP to VAL.
2196 PLIST is a property list, which is a list of the form
2197 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2198 If PROP is already a property on the list, its value is set to VAL,
2199 otherwise the new PROP VAL pair is added. The new plist is returned;
2200 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2201 The PLIST is modified by side effects. */)
2202 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2204 register Lisp_Object tail
, prev
;
2205 Lisp_Object newcell
;
2207 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2208 tail
= XCDR (XCDR (tail
)))
2210 if (EQ (prop
, XCAR (tail
)))
2212 Fsetcar (XCDR (tail
), val
);
2219 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2223 Fsetcdr (XCDR (prev
), newcell
);
2227 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2228 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2229 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2230 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2232 CHECK_SYMBOL (symbol
);
2234 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2238 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2239 doc
: /* Extract a value from a property list, comparing with `equal'.
2240 PLIST is a property list, which is a list of the form
2241 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2242 corresponding to the given PROP, or nil if PROP is not
2243 one of the properties on the list. */)
2244 (Lisp_Object plist
, Lisp_Object prop
)
2249 CONSP (tail
) && CONSP (XCDR (tail
));
2250 tail
= XCDR (XCDR (tail
)))
2252 if (! NILP (Fequal (prop
, XCAR (tail
))))
2253 return XCAR (XCDR (tail
));
2258 CHECK_LIST_END (tail
, prop
);
2263 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2264 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2265 PLIST is a property list, which is a list of the form
2266 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2267 If PROP is already a property on the list, its value is set to VAL,
2268 otherwise the new PROP VAL pair is added. The new plist is returned;
2269 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2270 The PLIST is modified by side effects. */)
2271 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2273 register Lisp_Object tail
, prev
;
2274 Lisp_Object newcell
;
2276 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2277 tail
= XCDR (XCDR (tail
)))
2279 if (! NILP (Fequal (prop
, XCAR (tail
))))
2281 Fsetcar (XCDR (tail
), val
);
2288 newcell
= list2 (prop
, val
);
2292 Fsetcdr (XCDR (prev
), newcell
);
2296 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2297 doc
: /* Return t if the two args are the same Lisp object.
2298 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2299 (Lisp_Object obj1
, Lisp_Object obj2
)
2302 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2304 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2307 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2308 doc
: /* Return t if two Lisp objects have similar structure and contents.
2309 They must have the same data type.
2310 Conses are compared by comparing the cars and the cdrs.
2311 Vectors and strings are compared element by element.
2312 Numbers are compared by value, but integers cannot equal floats.
2313 (Use `=' if you want integers and floats to be able to be equal.)
2314 Symbols must match exactly. */)
2315 (register Lisp_Object o1
, Lisp_Object o2
)
2317 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2320 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2321 doc
: /* Return t if two Lisp objects have similar structure and contents.
2322 This is like `equal' except that it compares the text properties
2323 of strings. (`equal' ignores text properties.) */)
2324 (register Lisp_Object o1
, Lisp_Object o2
)
2326 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2329 /* DEPTH is current depth of recursion. Signal an error if it
2331 PROPS means compare string text properties too. */
2334 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2340 error ("Stack overflow in equal");
2342 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2345 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2347 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2349 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2351 { /* `o1' was seen already. */
2352 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2353 if (!NILP (Fmemq (o2
, o2s
)))
2356 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2359 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2369 if (XTYPE (o1
) != XTYPE (o2
))
2378 d1
= extract_float (o1
);
2379 d2
= extract_float (o2
);
2380 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2381 though they are not =. */
2382 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2386 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2390 /* FIXME: This inf-loops in a circular list! */
2394 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2398 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2399 depth
+ 1, props
, ht
)
2400 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2401 depth
+ 1, props
, ht
))
2403 o1
= XOVERLAY (o1
)->plist
;
2404 o2
= XOVERLAY (o2
)->plist
;
2409 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2410 && (XMARKER (o1
)->buffer
== 0
2411 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2415 case Lisp_Vectorlike
:
2418 ptrdiff_t size
= ASIZE (o1
);
2419 /* Pseudovectors have the type encoded in the size field, so this test
2420 actually checks that the objects have the same type as well as the
2422 if (ASIZE (o2
) != size
)
2424 /* Boolvectors are compared much like strings. */
2425 if (BOOL_VECTOR_P (o1
))
2427 EMACS_INT size
= bool_vector_size (o1
);
2428 if (size
!= bool_vector_size (o2
))
2430 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2431 bool_vector_bytes (size
)))
2435 if (WINDOW_CONFIGURATIONP (o1
))
2436 return compare_window_configurations (o1
, o2
, 0);
2438 /* Aside from them, only true vectors, char-tables, compiled
2439 functions, and fonts (font-spec, font-entity, font-object)
2440 are sensible to compare, so eliminate the others now. */
2441 if (size
& PSEUDOVECTOR_FLAG
)
2443 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2446 size
&= PSEUDOVECTOR_SIZE_MASK
;
2448 for (i
= 0; i
< size
; i
++)
2453 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2461 if (SCHARS (o1
) != SCHARS (o2
))
2463 if (SBYTES (o1
) != SBYTES (o2
))
2465 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2467 if (props
&& !compare_string_intervals (o1
, o2
))
2479 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2480 doc
: /* Store each element of ARRAY with ITEM.
2481 ARRAY is a vector, string, char-table, or bool-vector. */)
2482 (Lisp_Object array
, Lisp_Object item
)
2484 register ptrdiff_t size
, idx
;
2486 if (VECTORP (array
))
2487 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2488 ASET (array
, idx
, item
);
2489 else if (CHAR_TABLE_P (array
))
2493 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2494 set_char_table_contents (array
, i
, item
);
2495 set_char_table_defalt (array
, item
);
2497 else if (STRINGP (array
))
2499 register unsigned char *p
= SDATA (array
);
2501 CHECK_CHARACTER (item
);
2502 charval
= XFASTINT (item
);
2503 size
= SCHARS (array
);
2504 if (STRING_MULTIBYTE (array
))
2506 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2507 int len
= CHAR_STRING (charval
, str
);
2508 ptrdiff_t size_byte
= SBYTES (array
);
2511 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2512 error ("Attempt to change byte length of a string");
2513 for (idx
= 0; idx
< size_byte
; idx
++)
2514 *p
++ = str
[idx
% len
];
2517 for (idx
= 0; idx
< size
; idx
++)
2520 else if (BOOL_VECTOR_P (array
))
2521 return bool_vector_fill (array
, item
);
2523 wrong_type_argument (Qarrayp
, array
);
2527 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2529 doc
: /* Clear the contents of STRING.
2530 This makes STRING unibyte and may change its length. */)
2531 (Lisp_Object string
)
2534 CHECK_STRING (string
);
2535 len
= SBYTES (string
);
2536 memset (SDATA (string
), 0, len
);
2537 STRING_SET_CHARS (string
, len
);
2538 STRING_SET_UNIBYTE (string
);
2544 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2546 return CALLN (Fnconc
, s1
, s2
);
2549 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2550 doc
: /* Concatenate any number of lists by altering them.
2551 Only the last argument is not altered, and need not be a list.
2552 usage: (nconc &rest LISTS) */)
2553 (ptrdiff_t nargs
, Lisp_Object
*args
)
2556 register Lisp_Object tail
, tem
, val
;
2560 for (argnum
= 0; argnum
< nargs
; argnum
++)
2563 if (NILP (tem
)) continue;
2568 if (argnum
+ 1 == nargs
) break;
2570 CHECK_LIST_CONS (tem
, tem
);
2579 tem
= args
[argnum
+ 1];
2580 Fsetcdr (tail
, tem
);
2582 args
[argnum
+ 1] = tail
;
2588 /* This is the guts of all mapping functions.
2589 Apply FN to each element of SEQ, one by one,
2590 storing the results into elements of VALS, a C vector of Lisp_Objects.
2591 LENI is the length of VALS, which should also be the length of SEQ. */
2594 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2596 Lisp_Object tail
, dummy
;
2599 if (VECTORP (seq
) || COMPILEDP (seq
))
2601 for (i
= 0; i
< leni
; i
++)
2603 dummy
= call1 (fn
, AREF (seq
, i
));
2608 else if (BOOL_VECTOR_P (seq
))
2610 for (i
= 0; i
< leni
; i
++)
2612 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2617 else if (STRINGP (seq
))
2621 for (i
= 0, i_byte
= 0; i
< leni
;)
2624 ptrdiff_t i_before
= i
;
2626 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2627 XSETFASTINT (dummy
, c
);
2628 dummy
= call1 (fn
, dummy
);
2630 vals
[i_before
] = dummy
;
2633 else /* Must be a list, since Flength did not get an error */
2636 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2638 dummy
= call1 (fn
, XCAR (tail
));
2646 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2647 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2648 In between each pair of results, stick in SEPARATOR. Thus, " " as
2649 SEPARATOR results in spaces between the values returned by FUNCTION.
2650 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2651 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2661 len
= Flength (sequence
);
2662 if (CHAR_TABLE_P (sequence
))
2663 wrong_type_argument (Qlistp
, sequence
);
2665 nargs
= leni
+ leni
- 1;
2666 if (nargs
< 0) return empty_unibyte_string
;
2668 SAFE_ALLOCA_LISP (args
, nargs
);
2670 mapcar1 (leni
, args
, function
, sequence
);
2672 for (i
= leni
- 1; i
> 0; i
--)
2673 args
[i
+ i
] = args
[i
];
2675 for (i
= 1; i
< nargs
; i
+= 2)
2676 args
[i
] = separator
;
2678 ret
= Fconcat (nargs
, args
);
2684 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2685 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2686 The result is a list just as long as SEQUENCE.
2687 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2688 (Lisp_Object function
, Lisp_Object sequence
)
2690 register Lisp_Object len
;
2691 register EMACS_INT leni
;
2692 register Lisp_Object
*args
;
2696 len
= Flength (sequence
);
2697 if (CHAR_TABLE_P (sequence
))
2698 wrong_type_argument (Qlistp
, sequence
);
2699 leni
= XFASTINT (len
);
2701 SAFE_ALLOCA_LISP (args
, leni
);
2703 mapcar1 (leni
, args
, function
, sequence
);
2705 ret
= Flist (leni
, args
);
2711 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2712 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2713 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2714 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2715 (Lisp_Object function
, Lisp_Object sequence
)
2717 register EMACS_INT leni
;
2719 leni
= XFASTINT (Flength (sequence
));
2720 if (CHAR_TABLE_P (sequence
))
2721 wrong_type_argument (Qlistp
, sequence
);
2722 mapcar1 (leni
, 0, function
, sequence
);
2727 /* This is how C code calls `yes-or-no-p' and allows the user
2731 do_yes_or_no_p (Lisp_Object prompt
)
2733 return call1 (intern ("yes-or-no-p"), prompt
);
2736 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2737 doc
: /* Ask user a yes-or-no question.
2738 Return t if answer is yes, and nil if the answer is no.
2739 PROMPT is the string to display to ask the question. It should end in
2740 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2742 The user must confirm the answer with RET, and can edit it until it
2745 If dialog boxes are supported, a dialog box will be used
2746 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2747 (Lisp_Object prompt
)
2751 CHECK_STRING (prompt
);
2753 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2754 && use_dialog_box
&& ! NILP (last_input_event
))
2756 Lisp_Object pane
, menu
, obj
;
2757 redisplay_preserve_echo_area (4);
2758 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2759 Fcons (build_string ("No"), Qnil
));
2760 menu
= Fcons (prompt
, pane
);
2761 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2765 AUTO_STRING (yes_or_no
, "(yes or no) ");
2766 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2770 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2771 Qyes_or_no_p_history
, Qnil
,
2773 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2775 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2780 message1 ("Please answer yes or no.");
2781 Fsleep_for (make_number (2), Qnil
);
2785 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2786 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2788 Each of the three load averages is multiplied by 100, then converted
2791 When USE-FLOATS is non-nil, floats will be used instead of integers.
2792 These floats are not multiplied by 100.
2794 If the 5-minute or 15-minute load averages are not available, return a
2795 shortened list, containing only those averages which are available.
2797 An error is thrown if the load average can't be obtained. In some
2798 cases making it work would require Emacs being installed setuid or
2799 setgid so that it can read kernel information, and that usually isn't
2801 (Lisp_Object use_floats
)
2804 int loads
= getloadavg (load_ave
, 3);
2805 Lisp_Object ret
= Qnil
;
2808 error ("load-average not implemented for this operating system");
2812 Lisp_Object load
= (NILP (use_floats
)
2813 ? make_number (100.0 * load_ave
[loads
])
2814 : make_float (load_ave
[loads
]));
2815 ret
= Fcons (load
, ret
);
2821 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2822 doc
: /* Return t if FEATURE is present in this Emacs.
2824 Use this to conditionalize execution of lisp code based on the
2825 presence or absence of Emacs or environment extensions.
2826 Use `provide' to declare that a feature is available. This function
2827 looks at the value of the variable `features'. The optional argument
2828 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2829 (Lisp_Object feature
, Lisp_Object subfeature
)
2831 register Lisp_Object tem
;
2832 CHECK_SYMBOL (feature
);
2833 tem
= Fmemq (feature
, Vfeatures
);
2834 if (!NILP (tem
) && !NILP (subfeature
))
2835 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2836 return (NILP (tem
)) ? Qnil
: Qt
;
2839 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2840 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2841 The optional argument SUBFEATURES should be a list of symbols listing
2842 particular subfeatures supported in this version of FEATURE. */)
2843 (Lisp_Object feature
, Lisp_Object subfeatures
)
2845 register Lisp_Object tem
;
2846 CHECK_SYMBOL (feature
);
2847 CHECK_LIST (subfeatures
);
2848 if (!NILP (Vautoload_queue
))
2849 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2851 tem
= Fmemq (feature
, Vfeatures
);
2853 Vfeatures
= Fcons (feature
, Vfeatures
);
2854 if (!NILP (subfeatures
))
2855 Fput (feature
, Qsubfeatures
, subfeatures
);
2856 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2858 /* Run any load-hooks for this file. */
2859 tem
= Fassq (feature
, Vafter_load_alist
);
2861 Fmapc (Qfuncall
, XCDR (tem
));
2866 /* `require' and its subroutines. */
2868 /* List of features currently being require'd, innermost first. */
2870 static Lisp_Object require_nesting_list
;
2873 require_unwind (Lisp_Object old_value
)
2875 require_nesting_list
= old_value
;
2878 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2879 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2880 If FEATURE is not a member of the list `features', then the feature
2881 is not loaded; so load the file FILENAME.
2882 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2883 and `load' will try to load this name appended with the suffix `.elc',
2884 `.el', or the system-dependent suffix for dynamic module files, in that
2885 order. The name without appended suffix will not be used.
2886 See `get-load-suffixes' for the complete list of suffixes.
2887 If the optional third argument NOERROR is non-nil,
2888 then return nil if the file is not found instead of signaling an error.
2889 Normally the return value is FEATURE.
2890 The normal messages at start and end of loading FILENAME are suppressed. */)
2891 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2894 bool from_file
= load_in_progress
;
2896 CHECK_SYMBOL (feature
);
2898 /* Record the presence of `require' in this file
2899 even if the feature specified is already loaded.
2900 But not more than once in any file,
2901 and not when we aren't loading or reading from a file. */
2903 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2904 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2909 tem
= Fcons (Qrequire
, feature
);
2910 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2911 LOADHIST_ATTACH (tem
);
2913 tem
= Fmemq (feature
, Vfeatures
);
2917 ptrdiff_t count
= SPECPDL_INDEX ();
2920 /* This is to make sure that loadup.el gives a clear picture
2921 of what files are preloaded and when. */
2922 if (! NILP (Vpurify_flag
))
2923 error ("(require %s) while preparing to dump",
2924 SDATA (SYMBOL_NAME (feature
)));
2926 /* A certain amount of recursive `require' is legitimate,
2927 but if we require the same feature recursively 3 times,
2929 tem
= require_nesting_list
;
2930 while (! NILP (tem
))
2932 if (! NILP (Fequal (feature
, XCAR (tem
))))
2937 error ("Recursive `require' for feature `%s'",
2938 SDATA (SYMBOL_NAME (feature
)));
2940 /* Update the list for any nested `require's that occur. */
2941 record_unwind_protect (require_unwind
, require_nesting_list
);
2942 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2944 /* Value saved here is to be restored into Vautoload_queue */
2945 record_unwind_protect (un_autoload
, Vautoload_queue
);
2946 Vautoload_queue
= Qt
;
2948 /* Load the file. */
2949 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2950 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2952 /* If load failed entirely, return nil. */
2954 return unbind_to (count
, Qnil
);
2956 tem
= Fmemq (feature
, Vfeatures
);
2958 error ("Required feature `%s' was not provided",
2959 SDATA (SYMBOL_NAME (feature
)));
2961 /* Once loading finishes, don't undo it. */
2962 Vautoload_queue
= Qt
;
2963 feature
= unbind_to (count
, feature
);
2969 /* Primitives for work of the "widget" library.
2970 In an ideal world, this section would not have been necessary.
2971 However, lisp function calls being as slow as they are, it turns
2972 out that some functions in the widget library (wid-edit.el) are the
2973 bottleneck of Widget operation. Here is their translation to C,
2974 for the sole reason of efficiency. */
2976 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2977 doc
: /* Return non-nil if PLIST has the property PROP.
2978 PLIST is a property list, which is a list of the form
2979 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2980 Unlike `plist-get', this allows you to distinguish between a missing
2981 property and a property with the value nil.
2982 The value is actually the tail of PLIST whose car is PROP. */)
2983 (Lisp_Object plist
, Lisp_Object prop
)
2985 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2987 plist
= XCDR (plist
);
2988 plist
= CDR (plist
);
2994 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2995 doc
: /* In WIDGET, set PROPERTY to VALUE.
2996 The value can later be retrieved with `widget-get'. */)
2997 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2999 CHECK_CONS (widget
);
3000 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3004 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3005 doc
: /* In WIDGET, get the value of PROPERTY.
3006 The value could either be specified when the widget was created, or
3007 later with `widget-put'. */)
3008 (Lisp_Object widget
, Lisp_Object property
)
3016 CHECK_CONS (widget
);
3017 tmp
= Fplist_member (XCDR (widget
), property
);
3023 tmp
= XCAR (widget
);
3026 widget
= Fget (tmp
, Qwidget_type
);
3030 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3031 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3032 ARGS are passed as extra arguments to the function.
3033 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3034 (ptrdiff_t nargs
, Lisp_Object
*args
)
3036 Lisp_Object widget
= args
[0];
3037 Lisp_Object property
= args
[1];
3038 Lisp_Object propval
= Fwidget_get (widget
, property
);
3039 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
3040 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
3044 #ifdef HAVE_LANGINFO_CODESET
3045 #include <langinfo.h>
3048 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3049 doc
: /* Access locale data ITEM for the current C locale, if available.
3050 ITEM should be one of the following:
3052 `codeset', returning the character set as a string (locale item CODESET);
3054 `days', returning a 7-element vector of day names (locale items DAY_n);
3056 `months', returning a 12-element vector of month names (locale items MON_n);
3058 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3059 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3061 If the system can't provide such information through a call to
3062 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3064 See also Info node `(libc)Locales'.
3066 The data read from the system are decoded using `locale-coding-system'. */)
3070 #ifdef HAVE_LANGINFO_CODESET
3072 if (EQ (item
, Qcodeset
))
3074 str
= nl_langinfo (CODESET
);
3075 return build_string (str
);
3078 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3080 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3081 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3083 synchronize_system_time_locale ();
3084 for (i
= 0; i
< 7; i
++)
3086 str
= nl_langinfo (days
[i
]);
3087 val
= build_unibyte_string (str
);
3088 /* Fixme: Is this coding system necessarily right, even if
3089 it is consistent with CODESET? If not, what to do? */
3090 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3097 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3099 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3100 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3101 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3103 synchronize_system_time_locale ();
3104 for (i
= 0; i
< 12; i
++)
3106 str
= nl_langinfo (months
[i
]);
3107 val
= build_unibyte_string (str
);
3108 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3114 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3115 but is in the locale files. This could be used by ps-print. */
3117 else if (EQ (item
, Qpaper
))
3118 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3119 #endif /* PAPER_WIDTH */
3120 #endif /* HAVE_LANGINFO_CODESET*/
3124 /* base64 encode/decode functions (RFC 2045).
3125 Based on code from GNU recode. */
3127 #define MIME_LINE_LENGTH 76
3129 #define IS_ASCII(Character) \
3131 #define IS_BASE64(Character) \
3132 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3133 #define IS_BASE64_IGNORABLE(Character) \
3134 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3135 || (Character) == '\f' || (Character) == '\r')
3137 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3138 character or return retval if there are no characters left to
3140 #define READ_QUADRUPLET_BYTE(retval) \
3145 if (nchars_return) \
3146 *nchars_return = nchars; \
3151 while (IS_BASE64_IGNORABLE (c))
3153 /* Table of characters coding the 64 values. */
3154 static const char base64_value_to_char
[64] =
3156 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3157 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3158 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3159 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3160 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3161 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3162 '8', '9', '+', '/' /* 60-63 */
3165 /* Table of base64 values for first 128 characters. */
3166 static const short base64_char_to_value
[128] =
3168 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3169 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3170 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3171 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3172 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3173 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3174 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3175 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3176 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3177 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3178 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3179 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3180 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3183 /* The following diagram shows the logical steps by which three octets
3184 get transformed into four base64 characters.
3186 .--------. .--------. .--------.
3187 |aaaaaabb| |bbbbcccc| |ccdddddd|
3188 `--------' `--------' `--------'
3190 .--------+--------+--------+--------.
3191 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3192 `--------+--------+--------+--------'
3194 .--------+--------+--------+--------.
3195 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3196 `--------+--------+--------+--------'
3198 The octets are divided into 6 bit chunks, which are then encoded into
3199 base64 characters. */
3202 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3203 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3206 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3208 doc
: /* Base64-encode the region between BEG and END.
3209 Return the length of the encoded text.
3210 Optional third argument NO-LINE-BREAK means do not break long lines
3211 into shorter lines. */)
3212 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3215 ptrdiff_t allength
, length
;
3216 ptrdiff_t ibeg
, iend
, encoded_length
;
3217 ptrdiff_t old_pos
= PT
;
3220 validate_region (&beg
, &end
);
3222 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3223 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3224 move_gap_both (XFASTINT (beg
), ibeg
);
3226 /* We need to allocate enough room for encoding the text.
3227 We need 33 1/3% more space, plus a newline every 76
3228 characters, and then we round up. */
3229 length
= iend
- ibeg
;
3230 allength
= length
+ length
/3 + 1;
3231 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3233 encoded
= SAFE_ALLOCA (allength
);
3234 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3235 encoded
, length
, NILP (no_line_break
),
3236 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3237 if (encoded_length
> allength
)
3240 if (encoded_length
< 0)
3242 /* The encoding wasn't possible. */
3244 error ("Multibyte character in data for base64 encoding");
3247 /* Now we have encoded the region, so we insert the new contents
3248 and delete the old. (Insert first in order to preserve markers.) */
3249 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3250 insert (encoded
, encoded_length
);
3252 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3254 /* If point was outside of the region, restore it exactly; else just
3255 move to the beginning of the region. */
3256 if (old_pos
>= XFASTINT (end
))
3257 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3258 else if (old_pos
> XFASTINT (beg
))
3259 old_pos
= XFASTINT (beg
);
3262 /* We return the length of the encoded text. */
3263 return make_number (encoded_length
);
3266 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3268 doc
: /* Base64-encode STRING and return the result.
3269 Optional second argument NO-LINE-BREAK means do not break long lines
3270 into shorter lines. */)
3271 (Lisp_Object string
, Lisp_Object no_line_break
)
3273 ptrdiff_t allength
, length
, encoded_length
;
3275 Lisp_Object encoded_string
;
3278 CHECK_STRING (string
);
3280 /* We need to allocate enough room for encoding the text.
3281 We need 33 1/3% more space, plus a newline every 76
3282 characters, and then we round up. */
3283 length
= SBYTES (string
);
3284 allength
= length
+ length
/3 + 1;
3285 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3287 /* We need to allocate enough room for decoding the text. */
3288 encoded
= SAFE_ALLOCA (allength
);
3290 encoded_length
= base64_encode_1 (SSDATA (string
),
3291 encoded
, length
, NILP (no_line_break
),
3292 STRING_MULTIBYTE (string
));
3293 if (encoded_length
> allength
)
3296 if (encoded_length
< 0)
3298 /* The encoding wasn't possible. */
3299 error ("Multibyte character in data for base64 encoding");
3302 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3305 return encoded_string
;
3309 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3310 bool line_break
, bool multibyte
)
3323 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3324 if (CHAR_BYTE8_P (c
))
3325 c
= CHAR_TO_BYTE8 (c
);
3333 /* Wrap line every 76 characters. */
3337 if (counter
< MIME_LINE_LENGTH
/ 4)
3346 /* Process first byte of a triplet. */
3348 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3349 value
= (0x03 & c
) << 4;
3351 /* Process second byte of a triplet. */
3355 *e
++ = base64_value_to_char
[value
];
3363 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3364 if (CHAR_BYTE8_P (c
))
3365 c
= CHAR_TO_BYTE8 (c
);
3373 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3374 value
= (0x0f & c
) << 2;
3376 /* Process third byte of a triplet. */
3380 *e
++ = base64_value_to_char
[value
];
3387 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3388 if (CHAR_BYTE8_P (c
))
3389 c
= CHAR_TO_BYTE8 (c
);
3397 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3398 *e
++ = base64_value_to_char
[0x3f & c
];
3405 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3407 doc
: /* Base64-decode the region between BEG and END.
3408 Return the length of the decoded text.
3409 If the region can't be decoded, signal an error and don't modify the buffer. */)
3410 (Lisp_Object beg
, Lisp_Object end
)
3412 ptrdiff_t ibeg
, iend
, length
, allength
;
3414 ptrdiff_t old_pos
= PT
;
3415 ptrdiff_t decoded_length
;
3416 ptrdiff_t inserted_chars
;
3417 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3420 validate_region (&beg
, &end
);
3422 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3423 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3425 length
= iend
- ibeg
;
3427 /* We need to allocate enough room for decoding the text. If we are
3428 working on a multibyte buffer, each decoded code may occupy at
3430 allength
= multibyte
? length
* 2 : length
;
3431 decoded
= SAFE_ALLOCA (allength
);
3433 move_gap_both (XFASTINT (beg
), ibeg
);
3434 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3436 multibyte
, &inserted_chars
);
3437 if (decoded_length
> allength
)
3440 if (decoded_length
< 0)
3442 /* The decoding wasn't possible. */
3443 error ("Invalid base64 data");
3446 /* Now we have decoded the region, so we insert the new contents
3447 and delete the old. (Insert first in order to preserve markers.) */
3448 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3449 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3452 /* Delete the original text. */
3453 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3454 iend
+ decoded_length
, 1);
3456 /* If point was outside of the region, restore it exactly; else just
3457 move to the beginning of the region. */
3458 if (old_pos
>= XFASTINT (end
))
3459 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3460 else if (old_pos
> XFASTINT (beg
))
3461 old_pos
= XFASTINT (beg
);
3462 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3464 return make_number (inserted_chars
);
3467 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3469 doc
: /* Base64-decode STRING and return the result. */)
3470 (Lisp_Object string
)
3473 ptrdiff_t length
, decoded_length
;
3474 Lisp_Object decoded_string
;
3477 CHECK_STRING (string
);
3479 length
= SBYTES (string
);
3480 /* We need to allocate enough room for decoding the text. */
3481 decoded
= SAFE_ALLOCA (length
);
3483 /* The decoded result should be unibyte. */
3484 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3486 if (decoded_length
> length
)
3488 else if (decoded_length
>= 0)
3489 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3491 decoded_string
= Qnil
;
3494 if (!STRINGP (decoded_string
))
3495 error ("Invalid base64 data");
3497 return decoded_string
;
3500 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3501 MULTIBYTE, the decoded result should be in multibyte
3502 form. If NCHARS_RETURN is not NULL, store the number of produced
3503 characters in *NCHARS_RETURN. */
3506 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3507 bool multibyte
, ptrdiff_t *nchars_return
)
3509 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3512 unsigned long value
;
3513 ptrdiff_t nchars
= 0;
3517 /* Process first byte of a quadruplet. */
3519 READ_QUADRUPLET_BYTE (e
-to
);
3523 value
= base64_char_to_value
[c
] << 18;
3525 /* Process second byte of a quadruplet. */
3527 READ_QUADRUPLET_BYTE (-1);
3531 value
|= base64_char_to_value
[c
] << 12;
3533 c
= (unsigned char) (value
>> 16);
3534 if (multibyte
&& c
>= 128)
3535 e
+= BYTE8_STRING (c
, e
);
3540 /* Process third byte of a quadruplet. */
3542 READ_QUADRUPLET_BYTE (-1);
3546 READ_QUADRUPLET_BYTE (-1);
3555 value
|= base64_char_to_value
[c
] << 6;
3557 c
= (unsigned char) (0xff & value
>> 8);
3558 if (multibyte
&& c
>= 128)
3559 e
+= BYTE8_STRING (c
, e
);
3564 /* Process fourth byte of a quadruplet. */
3566 READ_QUADRUPLET_BYTE (-1);
3573 value
|= base64_char_to_value
[c
];
3575 c
= (unsigned char) (0xff & value
);
3576 if (multibyte
&& c
>= 128)
3577 e
+= BYTE8_STRING (c
, e
);
3586 /***********************************************************************
3588 ***** Hash Tables *****
3590 ***********************************************************************/
3592 /* Implemented by gerd@gnu.org. This hash table implementation was
3593 inspired by CMUCL hash tables. */
3597 1. For small tables, association lists are probably faster than
3598 hash tables because they have lower overhead.
3600 For uses of hash tables where the O(1) behavior of table
3601 operations is not a requirement, it might therefore be a good idea
3602 not to hash. Instead, we could just do a linear search in the
3603 key_and_value vector of the hash table. This could be done
3604 if a `:linear-search t' argument is given to make-hash-table. */
3607 /* The list of all weak hash tables. Don't staticpro this one. */
3609 static struct Lisp_Hash_Table
*weak_hash_tables
;
3612 /***********************************************************************
3614 ***********************************************************************/
3617 CHECK_HASH_TABLE (Lisp_Object x
)
3619 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3623 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3625 h
->key_and_value
= key_and_value
;
3628 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3633 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3635 gc_aset (h
->next
, idx
, val
);
3638 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3643 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3645 gc_aset (h
->hash
, idx
, val
);
3648 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3653 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3655 gc_aset (h
->index
, idx
, val
);
3658 /* If OBJ is a Lisp hash table, return a pointer to its struct
3659 Lisp_Hash_Table. Otherwise, signal an error. */
3661 static struct Lisp_Hash_Table
*
3662 check_hash_table (Lisp_Object obj
)
3664 CHECK_HASH_TABLE (obj
);
3665 return XHASH_TABLE (obj
);
3669 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3670 number. A number is "almost" a prime number if it is not divisible
3671 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3674 next_almost_prime (EMACS_INT n
)
3676 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3677 for (n
|= 1; ; n
+= 2)
3678 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3683 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3684 which USED[I] is non-zero. If found at index I in ARGS, set
3685 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3686 0. This function is used to extract a keyword/argument pair from
3687 a DEFUN parameter list. */
3690 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3694 for (i
= 1; i
< nargs
; i
++)
3695 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3706 /* Return a Lisp vector which has the same contents as VEC but has
3707 at least INCR_MIN more entries, where INCR_MIN is positive.
3708 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3709 than NITEMS_MAX. Entries in the resulting
3710 vector that are not copied from VEC are set to nil. */
3713 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3715 struct Lisp_Vector
*v
;
3716 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3717 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3718 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3719 ? nitems_max
: C_language_max
);
3720 eassert (VECTORP (vec
));
3721 eassert (0 < incr_min
&& -1 <= nitems_max
);
3722 old_size
= ASIZE (vec
);
3723 incr_max
= n_max
- old_size
;
3724 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3725 if (incr_max
< incr
)
3726 memory_full (SIZE_MAX
);
3727 new_size
= old_size
+ incr
;
3728 v
= allocate_vector (new_size
);
3729 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3730 memclear (v
->contents
+ old_size
, incr
* word_size
);
3731 XSETVECTOR (vec
, v
);
3736 /***********************************************************************
3738 ***********************************************************************/
3740 struct hash_table_test hashtest_eq
, hashtest_eql
, hashtest_equal
;
3742 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3743 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3744 KEY2 are the same. */
3747 cmpfn_eql (struct hash_table_test
*ht
,
3751 return (FLOATP (key1
)
3753 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3757 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3758 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3759 KEY2 are the same. */
3762 cmpfn_equal (struct hash_table_test
*ht
,
3766 return !NILP (Fequal (key1
, key2
));
3770 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3771 HASH2 in hash table H using H->user_cmp_function. Value is true
3772 if KEY1 and KEY2 are the same. */
3775 cmpfn_user_defined (struct hash_table_test
*ht
,
3779 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3783 /* Value is a hash code for KEY for use in hash table H which uses
3784 `eq' to compare keys. The hash code returned is guaranteed to fit
3785 in a Lisp integer. */
3788 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3790 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3794 /* Value is a hash code for KEY for use in hash table H which uses
3795 `eql' to compare keys. The hash code returned is guaranteed to fit
3796 in a Lisp integer. */
3799 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3803 hash
= sxhash (key
, 0);
3805 hash
= XHASH (key
) ^ XTYPE (key
);
3809 /* Value is a hash code for KEY for use in hash table H which uses
3810 `equal' to compare keys. The hash code returned is guaranteed to fit
3811 in a Lisp integer. */
3814 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3816 EMACS_UINT hash
= sxhash (key
, 0);
3820 /* Value is a hash code for KEY for use in hash table H which uses as
3821 user-defined function to compare keys. The hash code returned is
3822 guaranteed to fit in a Lisp integer. */
3825 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3827 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3828 return hashfn_eq (ht
, hash
);
3831 /* Allocate basically initialized hash table. */
3833 static struct Lisp_Hash_Table
*
3834 allocate_hash_table (void)
3836 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3837 count
, PVEC_HASH_TABLE
);
3840 /* An upper bound on the size of a hash table index. It must fit in
3841 ptrdiff_t and be a valid Emacs fixnum. */
3842 #define INDEX_SIZE_BOUND \
3843 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3845 /* Create and initialize a new hash table.
3847 TEST specifies the test the hash table will use to compare keys.
3848 It must be either one of the predefined tests `eq', `eql' or
3849 `equal' or a symbol denoting a user-defined test named TEST with
3850 test and hash functions USER_TEST and USER_HASH.
3852 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3854 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3855 new size when it becomes full is computed by adding REHASH_SIZE to
3856 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3857 table's new size is computed by multiplying its old size with
3860 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3861 be resized when the ratio of (number of entries in the table) /
3862 (table size) is >= REHASH_THRESHOLD.
3864 WEAK specifies the weakness of the table. If non-nil, it must be
3865 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3868 make_hash_table (struct hash_table_test test
,
3869 Lisp_Object size
, Lisp_Object rehash_size
,
3870 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3872 struct Lisp_Hash_Table
*h
;
3874 EMACS_INT index_size
, sz
;
3878 /* Preconditions. */
3879 eassert (SYMBOLP (test
.name
));
3880 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3881 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3882 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3883 eassert (FLOATP (rehash_threshold
)
3884 && 0 < XFLOAT_DATA (rehash_threshold
)
3885 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3887 if (XFASTINT (size
) == 0)
3888 size
= make_number (1);
3890 sz
= XFASTINT (size
);
3891 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3892 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3893 ? next_almost_prime (index_float
)
3894 : INDEX_SIZE_BOUND
+ 1);
3895 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3896 error ("Hash table too large");
3898 /* Allocate a table and initialize it. */
3899 h
= allocate_hash_table ();
3901 /* Initialize hash table slots. */
3904 h
->rehash_threshold
= rehash_threshold
;
3905 h
->rehash_size
= rehash_size
;
3907 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3908 h
->hash
= Fmake_vector (size
, Qnil
);
3909 h
->next
= Fmake_vector (size
, Qnil
);
3910 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3912 /* Set up the free list. */
3913 for (i
= 0; i
< sz
- 1; ++i
)
3914 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3915 h
->next_free
= make_number (0);
3917 XSET_HASH_TABLE (table
, h
);
3918 eassert (HASH_TABLE_P (table
));
3919 eassert (XHASH_TABLE (table
) == h
);
3921 /* Maybe add this hash table to the list of all weak hash tables. */
3923 h
->next_weak
= NULL
;
3926 h
->next_weak
= weak_hash_tables
;
3927 weak_hash_tables
= h
;
3934 /* Return a copy of hash table H1. Keys and values are not copied,
3935 only the table itself is. */
3938 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3941 struct Lisp_Hash_Table
*h2
;
3943 h2
= allocate_hash_table ();
3945 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3946 h2
->hash
= Fcopy_sequence (h1
->hash
);
3947 h2
->next
= Fcopy_sequence (h1
->next
);
3948 h2
->index
= Fcopy_sequence (h1
->index
);
3949 XSET_HASH_TABLE (table
, h2
);
3951 /* Maybe add this hash table to the list of all weak hash tables. */
3952 if (!NILP (h2
->weak
))
3954 h2
->next_weak
= weak_hash_tables
;
3955 weak_hash_tables
= h2
;
3962 /* Resize hash table H if it's too full. If H cannot be resized
3963 because it's already too large, throw an error. */
3966 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3968 if (NILP (h
->next_free
))
3970 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3971 EMACS_INT new_size
, index_size
, nsize
;
3975 if (INTEGERP (h
->rehash_size
))
3976 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3979 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3980 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3982 new_size
= float_new_size
;
3983 if (new_size
<= old_size
)
3984 new_size
= old_size
+ 1;
3987 new_size
= INDEX_SIZE_BOUND
+ 1;
3989 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3990 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3991 ? next_almost_prime (index_float
)
3992 : INDEX_SIZE_BOUND
+ 1);
3993 nsize
= max (index_size
, 2 * new_size
);
3994 if (INDEX_SIZE_BOUND
< nsize
)
3995 error ("Hash table too large to resize");
3997 #ifdef ENABLE_CHECKING
3998 if (HASH_TABLE_P (Vpurify_flag
)
3999 && XHASH_TABLE (Vpurify_flag
) == h
)
4000 message ("Growing hash table to: %"pI
"d", new_size
);
4003 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
4004 2 * (new_size
- old_size
), -1));
4005 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
4006 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
4007 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
4009 /* Update the free list. Do it so that new entries are added at
4010 the end of the free list. This makes some operations like
4012 for (i
= old_size
; i
< new_size
- 1; ++i
)
4013 set_hash_next_slot (h
, i
, make_number (i
+ 1));
4015 if (!NILP (h
->next_free
))
4017 Lisp_Object last
, next
;
4019 last
= h
->next_free
;
4020 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4024 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
4027 XSETFASTINT (h
->next_free
, old_size
);
4030 for (i
= 0; i
< old_size
; ++i
)
4031 if (!NILP (HASH_HASH (h
, i
)))
4033 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4034 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4035 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4036 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4042 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4043 the hash code of KEY. Value is the index of the entry in H
4044 matching KEY, or -1 if not found. */
4047 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4049 EMACS_UINT hash_code
;
4050 ptrdiff_t start_of_bucket
;
4053 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4054 eassert ((hash_code
& ~INTMASK
) == 0);
4058 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4059 idx
= HASH_INDEX (h
, start_of_bucket
);
4063 ptrdiff_t i
= XFASTINT (idx
);
4064 if (EQ (key
, HASH_KEY (h
, i
))
4066 && hash_code
== XUINT (HASH_HASH (h
, i
))
4067 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4069 idx
= HASH_NEXT (h
, i
);
4072 return NILP (idx
) ? -1 : XFASTINT (idx
);
4076 /* Put an entry into hash table H that associates KEY with VALUE.
4077 HASH is a previously computed hash code of KEY.
4078 Value is the index of the entry in H matching KEY. */
4081 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4084 ptrdiff_t start_of_bucket
, i
;
4086 eassert ((hash
& ~INTMASK
) == 0);
4088 /* Increment count after resizing because resizing may fail. */
4089 maybe_resize_hash_table (h
);
4092 /* Store key/value in the key_and_value vector. */
4093 i
= XFASTINT (h
->next_free
);
4094 h
->next_free
= HASH_NEXT (h
, i
);
4095 set_hash_key_slot (h
, i
, key
);
4096 set_hash_value_slot (h
, i
, value
);
4098 /* Remember its hash code. */
4099 set_hash_hash_slot (h
, i
, make_number (hash
));
4101 /* Add new entry to its collision chain. */
4102 start_of_bucket
= hash
% ASIZE (h
->index
);
4103 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4104 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4109 /* Remove the entry matching KEY from hash table H, if there is one. */
4112 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4114 EMACS_UINT hash_code
;
4115 ptrdiff_t start_of_bucket
;
4116 Lisp_Object idx
, prev
;
4118 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4119 eassert ((hash_code
& ~INTMASK
) == 0);
4120 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4121 idx
= HASH_INDEX (h
, start_of_bucket
);
4126 ptrdiff_t i
= XFASTINT (idx
);
4128 if (EQ (key
, HASH_KEY (h
, i
))
4130 && hash_code
== XUINT (HASH_HASH (h
, i
))
4131 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4133 /* Take entry out of collision chain. */
4135 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4137 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4139 /* Clear slots in key_and_value and add the slots to
4141 set_hash_key_slot (h
, i
, Qnil
);
4142 set_hash_value_slot (h
, i
, Qnil
);
4143 set_hash_hash_slot (h
, i
, Qnil
);
4144 set_hash_next_slot (h
, i
, h
->next_free
);
4145 h
->next_free
= make_number (i
);
4147 eassert (h
->count
>= 0);
4153 idx
= HASH_NEXT (h
, i
);
4159 /* Clear hash table H. */
4162 hash_clear (struct Lisp_Hash_Table
*h
)
4166 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4168 for (i
= 0; i
< size
; ++i
)
4170 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4171 set_hash_key_slot (h
, i
, Qnil
);
4172 set_hash_value_slot (h
, i
, Qnil
);
4173 set_hash_hash_slot (h
, i
, Qnil
);
4176 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4177 ASET (h
->index
, i
, Qnil
);
4179 h
->next_free
= make_number (0);
4186 /************************************************************************
4188 ************************************************************************/
4190 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4191 entries from the table that don't survive the current GC.
4192 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4193 true if anything was marked. */
4196 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4198 ptrdiff_t n
= gc_asize (h
->index
);
4199 bool marked
= false;
4201 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4203 Lisp_Object idx
, next
, prev
;
4205 /* Follow collision chain, removing entries that
4206 don't survive this garbage collection. */
4208 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4210 ptrdiff_t i
= XFASTINT (idx
);
4211 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4212 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4215 if (EQ (h
->weak
, Qkey
))
4216 remove_p
= !key_known_to_survive_p
;
4217 else if (EQ (h
->weak
, Qvalue
))
4218 remove_p
= !value_known_to_survive_p
;
4219 else if (EQ (h
->weak
, Qkey_or_value
))
4220 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4221 else if (EQ (h
->weak
, Qkey_and_value
))
4222 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4226 next
= HASH_NEXT (h
, i
);
4228 if (remove_entries_p
)
4232 /* Take out of collision chain. */
4234 set_hash_index_slot (h
, bucket
, next
);
4236 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4238 /* Add to free list. */
4239 set_hash_next_slot (h
, i
, h
->next_free
);
4242 /* Clear key, value, and hash. */
4243 set_hash_key_slot (h
, i
, Qnil
);
4244 set_hash_value_slot (h
, i
, Qnil
);
4245 set_hash_hash_slot (h
, i
, Qnil
);
4258 /* Make sure key and value survive. */
4259 if (!key_known_to_survive_p
)
4261 mark_object (HASH_KEY (h
, i
));
4265 if (!value_known_to_survive_p
)
4267 mark_object (HASH_VALUE (h
, i
));
4278 /* Remove elements from weak hash tables that don't survive the
4279 current garbage collection. Remove weak tables that don't survive
4280 from Vweak_hash_tables. Called from gc_sweep. */
4282 NO_INLINE
/* For better stack traces */
4284 sweep_weak_hash_tables (void)
4286 struct Lisp_Hash_Table
*h
, *used
, *next
;
4289 /* Mark all keys and values that are in use. Keep on marking until
4290 there is no more change. This is necessary for cases like
4291 value-weak table A containing an entry X -> Y, where Y is used in a
4292 key-weak table B, Z -> Y. If B comes after A in the list of weak
4293 tables, X -> Y might be removed from A, although when looking at B
4294 one finds that it shouldn't. */
4298 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4300 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4301 marked
|= sweep_weak_table (h
, 0);
4306 /* Remove tables and entries that aren't used. */
4307 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4309 next
= h
->next_weak
;
4311 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4313 /* TABLE is marked as used. Sweep its contents. */
4315 sweep_weak_table (h
, 1);
4317 /* Add table to the list of used weak hash tables. */
4318 h
->next_weak
= used
;
4323 weak_hash_tables
= used
;
4328 /***********************************************************************
4329 Hash Code Computation
4330 ***********************************************************************/
4332 /* Maximum depth up to which to dive into Lisp structures. */
4334 #define SXHASH_MAX_DEPTH 3
4336 /* Maximum length up to which to take list and vector elements into
4339 #define SXHASH_MAX_LEN 7
4341 /* Return a hash for string PTR which has length LEN. The hash value
4342 can be any EMACS_UINT value. */
4345 hash_string (char const *ptr
, ptrdiff_t len
)
4347 char const *p
= ptr
;
4348 char const *end
= p
+ len
;
4350 EMACS_UINT hash
= 0;
4355 hash
= sxhash_combine (hash
, c
);
4361 /* Return a hash for string PTR which has length LEN. The hash
4362 code returned is guaranteed to fit in a Lisp integer. */
4365 sxhash_string (char const *ptr
, ptrdiff_t len
)
4367 EMACS_UINT hash
= hash_string (ptr
, len
);
4368 return SXHASH_REDUCE (hash
);
4371 /* Return a hash for the floating point value VAL. */
4374 sxhash_float (double val
)
4376 EMACS_UINT hash
= 0;
4378 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4379 + (sizeof val
% sizeof hash
!= 0))
4383 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4387 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4388 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4389 hash
= sxhash_combine (hash
, u
.word
[i
]);
4390 return SXHASH_REDUCE (hash
);
4393 /* Return a hash for list LIST. DEPTH is the current depth in the
4394 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4397 sxhash_list (Lisp_Object list
, int depth
)
4399 EMACS_UINT hash
= 0;
4402 if (depth
< SXHASH_MAX_DEPTH
)
4404 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4405 list
= XCDR (list
), ++i
)
4407 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4408 hash
= sxhash_combine (hash
, hash2
);
4413 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4414 hash
= sxhash_combine (hash
, hash2
);
4417 return SXHASH_REDUCE (hash
);
4421 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4422 the Lisp structure. */
4425 sxhash_vector (Lisp_Object vec
, int depth
)
4427 EMACS_UINT hash
= ASIZE (vec
);
4430 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4431 for (i
= 0; i
< n
; ++i
)
4433 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4434 hash
= sxhash_combine (hash
, hash2
);
4437 return SXHASH_REDUCE (hash
);
4440 /* Return a hash for bool-vector VECTOR. */
4443 sxhash_bool_vector (Lisp_Object vec
)
4445 EMACS_INT size
= bool_vector_size (vec
);
4446 EMACS_UINT hash
= size
;
4449 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4450 for (i
= 0; i
< n
; ++i
)
4451 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4453 return SXHASH_REDUCE (hash
);
4457 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4458 structure. Value is an unsigned integer clipped to INTMASK. */
4461 sxhash (Lisp_Object obj
, int depth
)
4465 if (depth
> SXHASH_MAX_DEPTH
)
4468 switch (XTYPE (obj
))
4480 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4483 /* This can be everything from a vector to an overlay. */
4484 case Lisp_Vectorlike
:
4486 /* According to the CL HyperSpec, two arrays are equal only if
4487 they are `eq', except for strings and bit-vectors. In
4488 Emacs, this works differently. We have to compare element
4490 hash
= sxhash_vector (obj
, depth
);
4491 else if (BOOL_VECTOR_P (obj
))
4492 hash
= sxhash_bool_vector (obj
);
4494 /* Others are `equal' if they are `eq', so let's take their
4500 hash
= sxhash_list (obj
, depth
);
4504 hash
= sxhash_float (XFLOAT_DATA (obj
));
4516 /***********************************************************************
4518 ***********************************************************************/
4521 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4522 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4525 EMACS_UINT hash
= sxhash (obj
, 0);
4526 return make_number (hash
);
4530 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4531 doc
: /* Create and return a new hash table.
4533 Arguments are specified as keyword/argument pairs. The following
4534 arguments are defined:
4536 :test TEST -- TEST must be a symbol that specifies how to compare
4537 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4538 `equal'. User-supplied test and hash functions can be specified via
4539 `define-hash-table-test'.
4541 :size SIZE -- A hint as to how many elements will be put in the table.
4544 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4545 fills up. If REHASH-SIZE is an integer, increase the size by that
4546 amount. If it is a float, it must be > 1.0, and the new size is the
4547 old size multiplied by that factor. Default is 1.5.
4549 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4550 Resize the hash table when the ratio (number of entries / table size)
4551 is greater than or equal to THRESHOLD. Default is 0.8.
4553 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4554 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4555 returned is a weak table. Key/value pairs are removed from a weak
4556 hash table when there are no non-weak references pointing to their
4557 key, value, one of key or value, or both key and value, depending on
4558 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4561 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4562 (ptrdiff_t nargs
, Lisp_Object
*args
)
4564 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4565 struct hash_table_test testdesc
;
4569 /* The vector `used' is used to keep track of arguments that
4570 have been consumed. */
4571 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4572 memset (used
, 0, nargs
* sizeof *used
);
4574 /* See if there's a `:test TEST' among the arguments. */
4575 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4576 test
= i
? args
[i
] : Qeql
;
4578 testdesc
= hashtest_eq
;
4579 else if (EQ (test
, Qeql
))
4580 testdesc
= hashtest_eql
;
4581 else if (EQ (test
, Qequal
))
4582 testdesc
= hashtest_equal
;
4585 /* See if it is a user-defined test. */
4588 prop
= Fget (test
, Qhash_table_test
);
4589 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4590 signal_error ("Invalid hash table test", test
);
4591 testdesc
.name
= test
;
4592 testdesc
.user_cmp_function
= XCAR (prop
);
4593 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4594 testdesc
.hashfn
= hashfn_user_defined
;
4595 testdesc
.cmpfn
= cmpfn_user_defined
;
4598 /* See if there's a `:size SIZE' argument. */
4599 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4600 size
= i
? args
[i
] : Qnil
;
4602 size
= make_number (DEFAULT_HASH_SIZE
);
4603 else if (!INTEGERP (size
) || XINT (size
) < 0)
4604 signal_error ("Invalid hash table size", size
);
4606 /* Look for `:rehash-size SIZE'. */
4607 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4608 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4609 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4610 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4611 signal_error ("Invalid hash table rehash size", rehash_size
);
4613 /* Look for `:rehash-threshold THRESHOLD'. */
4614 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4615 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4616 if (! (FLOATP (rehash_threshold
)
4617 && 0 < XFLOAT_DATA (rehash_threshold
)
4618 && XFLOAT_DATA (rehash_threshold
) <= 1))
4619 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4621 /* Look for `:weakness WEAK'. */
4622 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4623 weak
= i
? args
[i
] : Qnil
;
4625 weak
= Qkey_and_value
;
4628 && !EQ (weak
, Qvalue
)
4629 && !EQ (weak
, Qkey_or_value
)
4630 && !EQ (weak
, Qkey_and_value
))
4631 signal_error ("Invalid hash table weakness", weak
);
4633 /* Now, all args should have been used up, or there's a problem. */
4634 for (i
= 0; i
< nargs
; ++i
)
4636 signal_error ("Invalid argument list", args
[i
]);
4639 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4643 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4644 doc
: /* Return a copy of hash table TABLE. */)
4647 return copy_hash_table (check_hash_table (table
));
4651 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4652 doc
: /* Return the number of elements in TABLE. */)
4655 return make_number (check_hash_table (table
)->count
);
4659 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4660 Shash_table_rehash_size
, 1, 1, 0,
4661 doc
: /* Return the current rehash size of TABLE. */)
4664 return check_hash_table (table
)->rehash_size
;
4668 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4669 Shash_table_rehash_threshold
, 1, 1, 0,
4670 doc
: /* Return the current rehash threshold of TABLE. */)
4673 return check_hash_table (table
)->rehash_threshold
;
4677 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4678 doc
: /* Return the size of TABLE.
4679 The size can be used as an argument to `make-hash-table' to create
4680 a hash table than can hold as many elements as TABLE holds
4681 without need for resizing. */)
4684 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4685 return make_number (HASH_TABLE_SIZE (h
));
4689 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4690 doc
: /* Return the test TABLE uses. */)
4693 return check_hash_table (table
)->test
.name
;
4697 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4699 doc
: /* Return the weakness of TABLE. */)
4702 return check_hash_table (table
)->weak
;
4706 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4707 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4710 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4714 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4715 doc
: /* Clear hash table TABLE and return it. */)
4718 hash_clear (check_hash_table (table
));
4719 /* Be compatible with XEmacs. */
4724 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4725 doc
: /* Look up KEY in TABLE and return its associated value.
4726 If KEY is not found, return DFLT which defaults to nil. */)
4727 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4729 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4730 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4731 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4735 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4736 doc
: /* Associate KEY with VALUE in hash table TABLE.
4737 If KEY is already present in table, replace its current value with
4738 VALUE. In any case, return VALUE. */)
4739 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4741 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4745 i
= hash_lookup (h
, key
, &hash
);
4747 set_hash_value_slot (h
, i
, value
);
4749 hash_put (h
, key
, value
, hash
);
4755 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4756 doc
: /* Remove KEY from TABLE. */)
4757 (Lisp_Object key
, Lisp_Object table
)
4759 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4760 hash_remove_from_table (h
, key
);
4765 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4766 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4767 FUNCTION is called with two arguments, KEY and VALUE.
4768 `maphash' always returns nil. */)
4769 (Lisp_Object function
, Lisp_Object table
)
4771 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4773 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4774 if (!NILP (HASH_HASH (h
, i
)))
4775 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4781 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4782 Sdefine_hash_table_test
, 3, 3, 0,
4783 doc
: /* Define a new hash table test with name NAME, a symbol.
4785 In hash tables created with NAME specified as test, use TEST to
4786 compare keys, and HASH for computing hash codes of keys.
4788 TEST must be a function taking two arguments and returning non-nil if
4789 both arguments are the same. HASH must be a function taking one
4790 argument and returning an object that is the hash code of the argument.
4791 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4792 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4793 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4795 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4800 /************************************************************************
4801 MD5, SHA-1, and SHA-2
4802 ************************************************************************/
4809 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4812 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4813 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4817 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4818 register EMACS_INT b
, e
;
4819 register struct buffer
*bp
;
4822 void *(*hash_func
) (const char *, size_t, void *);
4825 CHECK_SYMBOL (algorithm
);
4827 if (STRINGP (object
))
4829 if (NILP (coding_system
))
4831 /* Decide the coding-system to encode the data with. */
4833 if (STRING_MULTIBYTE (object
))
4834 /* use default, we can't guess correct value */
4835 coding_system
= preferred_coding_system ();
4837 coding_system
= Qraw_text
;
4840 if (NILP (Fcoding_system_p (coding_system
)))
4842 /* Invalid coding system. */
4844 if (!NILP (noerror
))
4845 coding_system
= Qraw_text
;
4847 xsignal1 (Qcoding_system_error
, coding_system
);
4850 if (STRING_MULTIBYTE (object
))
4851 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4853 size
= SCHARS (object
);
4854 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4856 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4857 end_byte
= (end_char
== size
4859 : string_char_to_byte (object
, end_char
));
4863 struct buffer
*prev
= current_buffer
;
4865 record_unwind_current_buffer ();
4867 CHECK_BUFFER (object
);
4869 bp
= XBUFFER (object
);
4870 set_buffer_internal (bp
);
4876 CHECK_NUMBER_COERCE_MARKER (start
);
4884 CHECK_NUMBER_COERCE_MARKER (end
);
4889 temp
= b
, b
= e
, e
= temp
;
4891 if (!(BEGV
<= b
&& e
<= ZV
))
4892 args_out_of_range (start
, end
);
4894 if (NILP (coding_system
))
4896 /* Decide the coding-system to encode the data with.
4897 See fileio.c:Fwrite-region */
4899 if (!NILP (Vcoding_system_for_write
))
4900 coding_system
= Vcoding_system_for_write
;
4903 bool force_raw_text
= 0;
4905 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4906 if (NILP (coding_system
)
4907 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4909 coding_system
= Qnil
;
4910 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4914 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4916 /* Check file-coding-system-alist. */
4917 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4918 Qwrite_region
, start
, end
,
4919 Fbuffer_file_name (object
));
4920 if (CONSP (val
) && !NILP (XCDR (val
)))
4921 coding_system
= XCDR (val
);
4924 if (NILP (coding_system
)
4925 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4927 /* If we still have not decided a coding system, use the
4928 default value of buffer-file-coding-system. */
4929 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4933 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4934 /* Confirm that VAL can surely encode the current region. */
4935 coding_system
= call4 (Vselect_safe_coding_system_function
,
4936 make_number (b
), make_number (e
),
4937 coding_system
, Qnil
);
4940 coding_system
= Qraw_text
;
4943 if (NILP (Fcoding_system_p (coding_system
)))
4945 /* Invalid coding system. */
4947 if (!NILP (noerror
))
4948 coding_system
= Qraw_text
;
4950 xsignal1 (Qcoding_system_error
, coding_system
);
4954 object
= make_buffer_string (b
, e
, 0);
4955 set_buffer_internal (prev
);
4956 /* Discard the unwind protect for recovering the current
4960 if (STRING_MULTIBYTE (object
))
4961 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4963 end_byte
= SBYTES (object
);
4966 if (EQ (algorithm
, Qmd5
))
4968 digest_size
= MD5_DIGEST_SIZE
;
4969 hash_func
= md5_buffer
;
4971 else if (EQ (algorithm
, Qsha1
))
4973 digest_size
= SHA1_DIGEST_SIZE
;
4974 hash_func
= sha1_buffer
;
4976 else if (EQ (algorithm
, Qsha224
))
4978 digest_size
= SHA224_DIGEST_SIZE
;
4979 hash_func
= sha224_buffer
;
4981 else if (EQ (algorithm
, Qsha256
))
4983 digest_size
= SHA256_DIGEST_SIZE
;
4984 hash_func
= sha256_buffer
;
4986 else if (EQ (algorithm
, Qsha384
))
4988 digest_size
= SHA384_DIGEST_SIZE
;
4989 hash_func
= sha384_buffer
;
4991 else if (EQ (algorithm
, Qsha512
))
4993 digest_size
= SHA512_DIGEST_SIZE
;
4994 hash_func
= sha512_buffer
;
4997 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4999 /* allocate 2 x digest_size so that it can be re-used to hold the
5001 digest
= make_uninit_string (digest_size
* 2);
5003 hash_func (SSDATA (object
) + start_byte
,
5004 end_byte
- start_byte
,
5009 unsigned char *p
= SDATA (digest
);
5010 for (i
= digest_size
- 1; i
>= 0; i
--)
5012 static char const hexdigit
[16] = "0123456789abcdef";
5014 p
[2 * i
] = hexdigit
[p_i
>> 4];
5015 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5020 return make_unibyte_string (SSDATA (digest
), digest_size
);
5023 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5024 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5026 A message digest is a cryptographic checksum of a document, and the
5027 algorithm to calculate it is defined in RFC 1321.
5029 The two optional arguments START and END are character positions
5030 specifying for which part of OBJECT the message digest should be
5031 computed. If nil or omitted, the digest is computed for the whole
5034 The MD5 message digest is computed from the result of encoding the
5035 text in a coding system, not directly from the internal Emacs form of
5036 the text. The optional fourth argument CODING-SYSTEM specifies which
5037 coding system to encode the text with. It should be the same coding
5038 system that you used or will use when actually writing the text into a
5041 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5042 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5043 system would be chosen by default for writing this text into a file.
5045 If OBJECT is a string, the most preferred coding system (see the
5046 command `prefer-coding-system') is used.
5048 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5049 guesswork fails. Normally, an error is signaled in such case. */)
5050 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5052 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5055 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5056 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5057 ALGORITHM is a symbol specifying the hash to use:
5058 md5, sha1, sha224, sha256, sha384 or sha512.
5060 The two optional arguments START and END are positions specifying for
5061 which part of OBJECT to compute the hash. If nil or omitted, uses the
5064 If BINARY is non-nil, returns a string in binary form. */)
5065 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5067 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5073 DEFSYM (Qmd5
, "md5");
5074 DEFSYM (Qsha1
, "sha1");
5075 DEFSYM (Qsha224
, "sha224");
5076 DEFSYM (Qsha256
, "sha256");
5077 DEFSYM (Qsha384
, "sha384");
5078 DEFSYM (Qsha512
, "sha512");
5080 /* Hash table stuff. */
5081 DEFSYM (Qhash_table_p
, "hash-table-p");
5083 DEFSYM (Qeql
, "eql");
5084 DEFSYM (Qequal
, "equal");
5085 DEFSYM (QCtest
, ":test");
5086 DEFSYM (QCsize
, ":size");
5087 DEFSYM (QCrehash_size
, ":rehash-size");
5088 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5089 DEFSYM (QCweakness
, ":weakness");
5090 DEFSYM (Qkey
, "key");
5091 DEFSYM (Qvalue
, "value");
5092 DEFSYM (Qhash_table_test
, "hash-table-test");
5093 DEFSYM (Qkey_or_value
, "key-or-value");
5094 DEFSYM (Qkey_and_value
, "key-and-value");
5097 defsubr (&Smake_hash_table
);
5098 defsubr (&Scopy_hash_table
);
5099 defsubr (&Shash_table_count
);
5100 defsubr (&Shash_table_rehash_size
);
5101 defsubr (&Shash_table_rehash_threshold
);
5102 defsubr (&Shash_table_size
);
5103 defsubr (&Shash_table_test
);
5104 defsubr (&Shash_table_weakness
);
5105 defsubr (&Shash_table_p
);
5106 defsubr (&Sclrhash
);
5107 defsubr (&Sgethash
);
5108 defsubr (&Sputhash
);
5109 defsubr (&Sremhash
);
5110 defsubr (&Smaphash
);
5111 defsubr (&Sdefine_hash_table_test
);
5113 DEFSYM (Qstring_lessp
, "string-lessp");
5114 DEFSYM (Qprovide
, "provide");
5115 DEFSYM (Qrequire
, "require");
5116 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5117 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5118 DEFSYM (Qwidget_type
, "widget-type");
5120 staticpro (&string_char_byte_cache_string
);
5121 string_char_byte_cache_string
= Qnil
;
5123 require_nesting_list
= Qnil
;
5124 staticpro (&require_nesting_list
);
5126 Fset (Qyes_or_no_p_history
, Qnil
);
5128 DEFVAR_LISP ("features", Vfeatures
,
5129 doc
: /* A list of symbols which are the features of the executing Emacs.
5130 Used by `featurep' and `require', and altered by `provide'. */);
5131 Vfeatures
= list1 (Qemacs
);
5132 DEFSYM (Qsubfeatures
, "subfeatures");
5133 DEFSYM (Qfuncall
, "funcall");
5135 #ifdef HAVE_LANGINFO_CODESET
5136 DEFSYM (Qcodeset
, "codeset");
5137 DEFSYM (Qdays
, "days");
5138 DEFSYM (Qmonths
, "months");
5139 DEFSYM (Qpaper
, "paper");
5140 #endif /* HAVE_LANGINFO_CODESET */
5142 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5143 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5144 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5145 invoked by mouse clicks and mouse menu items.
5147 On some platforms, file selection dialogs are also enabled if this is
5151 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5152 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5153 This applies to commands from menus and tool bar buttons even when
5154 they are initiated from the keyboard. If `use-dialog-box' is nil,
5155 that disables the use of a file dialog, regardless of the value of
5157 use_file_dialog
= 1;
5159 defsubr (&Sidentity
);
5162 defsubr (&Ssafe_length
);
5163 defsubr (&Sstring_bytes
);
5164 defsubr (&Sstring_equal
);
5165 defsubr (&Scompare_strings
);
5166 defsubr (&Sstring_lessp
);
5167 defsubr (&Sstring_numeric_lessp
);
5168 defsubr (&Sstring_collate_lessp
);
5169 defsubr (&Sstring_collate_equalp
);
5172 defsubr (&Svconcat
);
5173 defsubr (&Scopy_sequence
);
5174 defsubr (&Sstring_make_multibyte
);
5175 defsubr (&Sstring_make_unibyte
);
5176 defsubr (&Sstring_as_multibyte
);
5177 defsubr (&Sstring_as_unibyte
);
5178 defsubr (&Sstring_to_multibyte
);
5179 defsubr (&Sstring_to_unibyte
);
5180 defsubr (&Scopy_alist
);
5181 defsubr (&Ssubstring
);
5182 defsubr (&Ssubstring_no_properties
);
5195 defsubr (&Snreverse
);
5196 defsubr (&Sreverse
);
5198 defsubr (&Splist_get
);
5200 defsubr (&Splist_put
);
5202 defsubr (&Slax_plist_get
);
5203 defsubr (&Slax_plist_put
);
5206 defsubr (&Sequal_including_properties
);
5207 defsubr (&Sfillarray
);
5208 defsubr (&Sclear_string
);
5212 defsubr (&Smapconcat
);
5213 defsubr (&Syes_or_no_p
);
5214 defsubr (&Sload_average
);
5215 defsubr (&Sfeaturep
);
5216 defsubr (&Srequire
);
5217 defsubr (&Sprovide
);
5218 defsubr (&Splist_member
);
5219 defsubr (&Swidget_put
);
5220 defsubr (&Swidget_get
);
5221 defsubr (&Swidget_apply
);
5222 defsubr (&Sbase64_encode_region
);
5223 defsubr (&Sbase64_decode_region
);
5224 defsubr (&Sbase64_encode_string
);
5225 defsubr (&Sbase64_decode_string
);
5227 defsubr (&Ssecure_hash
);
5228 defsubr (&Slocale_info
);
5230 hashtest_eq
.name
= Qeq
;
5231 hashtest_eq
.user_hash_function
= Qnil
;
5232 hashtest_eq
.user_cmp_function
= Qnil
;
5233 hashtest_eq
.cmpfn
= 0;
5234 hashtest_eq
.hashfn
= hashfn_eq
;
5236 hashtest_eql
.name
= Qeql
;
5237 hashtest_eql
.user_hash_function
= Qnil
;
5238 hashtest_eql
.user_cmp_function
= Qnil
;
5239 hashtest_eql
.cmpfn
= cmpfn_eql
;
5240 hashtest_eql
.hashfn
= hashfn_eql
;
5242 hashtest_equal
.name
= Qequal
;
5243 hashtest_equal
.user_hash_function
= Qnil
;
5244 hashtest_equal
.user_cmp_function
= Qnil
;
5245 hashtest_equal
.cmpfn
= cmpfn_equal
;
5246 hashtest_equal
.hashfn
= hashfn_equal
;