1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2017 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
39 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
40 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
41 enum equal_kind
{ EQUAL_NO_QUIT
, EQUAL_PLAIN
, EQUAL_INCLUDING_PROPERTIES
};
42 static bool internal_equal (Lisp_Object
, Lisp_Object
,
43 enum equal_kind
, int, Lisp_Object
);
45 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
46 doc
: /* Return the argument unchanged. */
53 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
54 doc
: /* Return a pseudo-random number.
55 All integers representable in Lisp, i.e. between `most-negative-fixnum'
56 and `most-positive-fixnum', inclusive, are equally likely.
58 With positive integer LIMIT, return random number in interval [0,LIMIT).
59 With argument t, set the random number seed from the system's entropy
60 pool if available, otherwise from less-random volatile data such as the time.
61 With a string argument, set the seed based on the string's contents.
62 Other values of LIMIT are ignored.
64 See Info node `(elisp)Random Numbers' for more details. */)
71 else if (STRINGP (limit
))
72 seed_random (SSDATA (limit
), SBYTES (limit
));
75 if (INTEGERP (limit
) && 0 < XINT (limit
))
78 /* Return the remainder, except reject the rare case where
79 get_random returns a number so close to INTMASK that the
80 remainder isn't random. */
81 EMACS_INT remainder
= val
% XINT (limit
);
82 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
83 return make_number (remainder
);
86 return make_number (val
);
89 /* Random data-structure functions. */
91 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
92 doc
: /* Return the length of vector, list or string SEQUENCE.
93 A byte-code function object is also allowed.
94 If the string contains multibyte characters, this is not necessarily
95 the number of bytes in the string; it is the number of characters.
96 To get the number of bytes, use `string-bytes'. */)
97 (register Lisp_Object sequence
)
99 register Lisp_Object val
;
101 if (STRINGP (sequence
))
102 XSETFASTINT (val
, SCHARS (sequence
));
103 else if (VECTORP (sequence
))
104 XSETFASTINT (val
, ASIZE (sequence
));
105 else if (CHAR_TABLE_P (sequence
))
106 XSETFASTINT (val
, MAX_CHAR
);
107 else if (BOOL_VECTOR_P (sequence
))
108 XSETFASTINT (val
, bool_vector_size (sequence
));
109 else if (COMPILEDP (sequence
) || RECORDP (sequence
))
110 XSETFASTINT (val
, PVSIZE (sequence
));
111 else if (CONSP (sequence
))
114 FOR_EACH_TAIL (sequence
)
116 CHECK_LIST_END (sequence
, sequence
);
117 if (MOST_POSITIVE_FIXNUM
< i
)
118 error ("List too long");
119 val
= make_number (i
);
121 else if (NILP (sequence
))
122 XSETFASTINT (val
, 0);
124 wrong_type_argument (Qsequencep
, sequence
);
129 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
130 doc
: /* Return the length of a list, but avoid error or infinite loop.
131 This function never gets an error. If LIST is not really a list,
132 it returns 0. If LIST is circular, it returns a finite value
133 which is at least the number of distinct elements. */)
137 FOR_EACH_TAIL_SAFE (list
)
139 return make_fixnum_or_float (len
);
142 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
143 doc
: /* Return the number of bytes in STRING.
144 If STRING is multibyte, this may be greater than the length of STRING. */)
147 CHECK_STRING (string
);
148 return make_number (SBYTES (string
));
151 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
152 doc
: /* Return t if two strings have identical contents.
153 Case is significant, but text properties are ignored.
154 Symbols are also allowed; their print names are used instead. */)
155 (register Lisp_Object s1
, Lisp_Object s2
)
158 s1
= SYMBOL_NAME (s1
);
160 s2
= SYMBOL_NAME (s2
);
164 if (SCHARS (s1
) != SCHARS (s2
)
165 || SBYTES (s1
) != SBYTES (s2
)
166 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
171 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
172 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
173 The arguments START1, END1, START2, and END2, if non-nil, are
174 positions specifying which parts of STR1 or STR2 to compare. In
175 string STR1, compare the part between START1 (inclusive) and END1
176 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
177 the string; if END1 is nil, it defaults to the length of the string.
178 Likewise, in string STR2, compare the part between START2 and END2.
179 Like in `substring', negative values are counted from the end.
181 The strings are compared by the numeric values of their characters.
182 For instance, STR1 is "less than" STR2 if its first differing
183 character has a smaller numeric value. If IGNORE-CASE is non-nil,
184 characters are converted to upper-case before comparing them. Unibyte
185 strings are converted to multibyte for comparison.
187 The value is t if the strings (or specified portions) match.
188 If string STR1 is less, the value is a negative number N;
189 - 1 - N is the number of characters that match at the beginning.
190 If string STR1 is greater, the value is a positive number N;
191 N - 1 is the number of characters that match at the beginning. */)
192 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
193 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
195 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
200 /* For backward compatibility, silently bring too-large positive end
201 values into range. */
202 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
203 end1
= make_number (SCHARS (str1
));
204 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
205 end2
= make_number (SCHARS (str2
));
207 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
208 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
213 i1_byte
= string_char_to_byte (str1
, i1
);
214 i2_byte
= string_char_to_byte (str2
, i2
);
216 while (i1
< to1
&& i2
< to2
)
218 /* When we find a mismatch, we must compare the
219 characters, not just the bytes. */
222 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
223 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
228 if (! NILP (ignore_case
))
230 c1
= XINT (Fupcase (make_number (c1
)));
231 c2
= XINT (Fupcase (make_number (c2
)));
237 /* Note that I1 has already been incremented
238 past the character that we are comparing;
239 hence we don't add or subtract 1 here. */
241 return make_number (- i1
+ from1
);
243 return make_number (i1
- from1
);
247 return make_number (i1
- from1
+ 1);
249 return make_number (- i1
+ from1
- 1);
254 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
255 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
257 Symbols are also allowed; their print names are used instead. */)
258 (register Lisp_Object string1
, Lisp_Object string2
)
260 register ptrdiff_t end
;
261 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
263 if (SYMBOLP (string1
))
264 string1
= SYMBOL_NAME (string1
);
265 if (SYMBOLP (string2
))
266 string2
= SYMBOL_NAME (string2
);
267 CHECK_STRING (string1
);
268 CHECK_STRING (string2
);
270 i1
= i1_byte
= i2
= i2_byte
= 0;
272 end
= SCHARS (string1
);
273 if (end
> SCHARS (string2
))
274 end
= SCHARS (string2
);
278 /* When we find a mismatch, we must compare the
279 characters, not just the bytes. */
282 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
283 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
286 return c1
< c2
? Qt
: Qnil
;
288 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
291 DEFUN ("string-version-lessp", Fstring_version_lessp
,
292 Sstring_version_lessp
, 2, 2, 0,
293 doc
: /* Return non-nil if S1 is less than S2, as version strings.
295 This function compares version strings S1 and S2:
296 1) By prefix lexicographically.
297 2) Then by version (similarly to version comparison of Debian's dpkg).
298 Leading zeros in version numbers are ignored.
299 3) If both prefix and version are equal, compare as ordinary strings.
301 For example, \"foo2.png\" compares less than \"foo12.png\".
303 Symbols are also allowed; their print names are used instead. */)
304 (Lisp_Object string1
, Lisp_Object string2
)
306 if (SYMBOLP (string1
))
307 string1
= SYMBOL_NAME (string1
);
308 if (SYMBOLP (string2
))
309 string2
= SYMBOL_NAME (string2
);
310 CHECK_STRING (string1
);
311 CHECK_STRING (string2
);
313 char *p1
= SSDATA (string1
);
314 char *p2
= SSDATA (string2
);
315 char *lim1
= p1
+ SBYTES (string1
);
316 char *lim2
= p2
+ SBYTES (string2
);
319 while ((cmp
= filevercmp (p1
, p2
)) == 0)
321 /* If the strings are identical through their first null bytes,
322 skip past identical prefixes and try again. */
323 ptrdiff_t size
= strlen (p1
) + 1;
327 return lim2
< p2
? Qnil
: Qt
;
332 return cmp
< 0 ? Qt
: Qnil
;
335 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
336 doc
: /* Return t if first arg string is less than second in collation order.
337 Symbols are also allowed; their print names are used instead.
339 This function obeys the conventions for collation order in your
340 locale settings. For example, punctuation and whitespace characters
341 might be considered less significant for sorting:
343 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
344 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
346 The optional argument LOCALE, a string, overrides the setting of your
347 current locale identifier for collation. The value is system
348 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
349 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
351 If IGNORE-CASE is non-nil, characters are converted to lower-case
352 before comparing them.
354 To emulate Unicode-compliant collation on MS-Windows systems,
355 bind `w32-collate-ignore-punctuation' to a non-nil value, since
356 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
358 If your system does not support a locale environment, this function
359 behaves like `string-lessp'. */)
360 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
362 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
363 /* Check parameters. */
365 s1
= SYMBOL_NAME (s1
);
367 s2
= SYMBOL_NAME (s2
);
371 CHECK_STRING (locale
);
373 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
375 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
376 return Fstring_lessp (s1
, s2
);
377 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
380 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
381 doc
: /* Return t if two strings have identical contents.
382 Symbols are also allowed; their print names are used instead.
384 This function obeys the conventions for collation order in your locale
385 settings. For example, characters with different coding points but
386 the same meaning might be considered as equal, like different grave
387 accent Unicode characters:
389 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
392 The optional argument LOCALE, a string, overrides the setting of your
393 current locale identifier for collation. The value is system
394 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
395 while it would be \"enu_USA.1252\" on MS Windows systems.
397 If IGNORE-CASE is non-nil, characters are converted to lower-case
398 before comparing them.
400 To emulate Unicode-compliant collation on MS-Windows systems,
401 bind `w32-collate-ignore-punctuation' to a non-nil value, since
402 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
404 If your system does not support a locale environment, this function
405 behaves like `string-equal'.
407 Do NOT use this function to compare file names for equality. */)
408 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
410 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
411 /* Check parameters. */
413 s1
= SYMBOL_NAME (s1
);
415 s2
= SYMBOL_NAME (s2
);
419 CHECK_STRING (locale
);
421 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
423 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
424 return Fstring_equal (s1
, s2
);
425 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
428 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
429 enum Lisp_Type target_type
, bool last_special
);
433 concat2 (Lisp_Object s1
, Lisp_Object s2
)
435 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
440 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
442 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
445 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
446 doc
: /* Concatenate all the arguments and make the result a list.
447 The result is a list whose elements are the elements of all the arguments.
448 Each argument may be a list, vector or string.
449 The last argument is not copied, just used as the tail of the new list.
450 usage: (append &rest SEQUENCES) */)
451 (ptrdiff_t nargs
, Lisp_Object
*args
)
453 return concat (nargs
, args
, Lisp_Cons
, 1);
456 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
457 doc
: /* Concatenate all the arguments and make the result a string.
458 The result is a string whose elements are the elements of all the arguments.
459 Each argument may be a string or a list or vector of characters (integers).
460 usage: (concat &rest SEQUENCES) */)
461 (ptrdiff_t nargs
, Lisp_Object
*args
)
463 return concat (nargs
, args
, Lisp_String
, 0);
466 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
467 doc
: /* Concatenate all the arguments and make the result a vector.
468 The result is a vector whose elements are the elements of all the arguments.
469 Each argument may be a list, vector or string.
470 usage: (vconcat &rest SEQUENCES) */)
471 (ptrdiff_t nargs
, Lisp_Object
*args
)
473 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
477 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
478 doc
: /* Return a copy of a list, vector, string, char-table or record.
479 The elements of a list, vector or record are not copied; they are
480 shared with the original. */)
483 if (NILP (arg
)) return arg
;
487 return Frecord (PVSIZE (arg
), XVECTOR (arg
)->contents
);
490 if (CHAR_TABLE_P (arg
))
492 return copy_char_table (arg
);
495 if (BOOL_VECTOR_P (arg
))
497 EMACS_INT nbits
= bool_vector_size (arg
);
498 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
499 Lisp_Object val
= make_uninit_bool_vector (nbits
);
500 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
504 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
505 wrong_type_argument (Qsequencep
, arg
);
507 return concat (1, &arg
, XTYPE (arg
), 0);
510 /* This structure holds information of an argument of `concat' that is
511 a string and has text properties to be copied. */
514 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
515 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
516 ptrdiff_t to
; /* refer to VAL (the target string) */
520 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
521 enum Lisp_Type target_type
, bool last_special
)
527 ptrdiff_t toindex_byte
= 0;
528 EMACS_INT result_len
;
529 EMACS_INT result_len_byte
;
531 Lisp_Object last_tail
;
534 /* When we make a multibyte string, we can't copy text properties
535 while concatenating each string because the length of resulting
536 string can't be decided until we finish the whole concatenation.
537 So, we record strings that have text properties to be copied
538 here, and copy the text properties after the concatenation. */
539 struct textprop_rec
*textprops
= NULL
;
540 /* Number of elements in textprops. */
541 ptrdiff_t num_textprops
= 0;
546 /* In append, the last arg isn't treated like the others */
547 if (last_special
&& nargs
> 0)
550 last_tail
= args
[nargs
];
555 /* Check each argument. */
556 for (argnum
= 0; argnum
< nargs
; argnum
++)
559 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
560 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
561 wrong_type_argument (Qsequencep
, this);
564 /* Compute total length in chars of arguments in RESULT_LEN.
565 If desired output is a string, also compute length in bytes
566 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
567 whether the result should be a multibyte string. */
571 for (argnum
= 0; argnum
< nargs
; argnum
++)
575 len
= XFASTINT (Flength (this));
576 if (target_type
== Lisp_String
)
578 /* We must count the number of bytes needed in the string
579 as well as the number of characters. */
583 ptrdiff_t this_len_byte
;
585 if (VECTORP (this) || COMPILEDP (this))
586 for (i
= 0; i
< len
; i
++)
589 CHECK_CHARACTER (ch
);
591 this_len_byte
= CHAR_BYTES (c
);
592 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
594 result_len_byte
+= this_len_byte
;
595 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
598 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
599 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
600 else if (CONSP (this))
601 for (; CONSP (this); this = XCDR (this))
604 CHECK_CHARACTER (ch
);
606 this_len_byte
= CHAR_BYTES (c
);
607 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
609 result_len_byte
+= this_len_byte
;
610 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
613 else if (STRINGP (this))
615 if (STRING_MULTIBYTE (this))
618 this_len_byte
= SBYTES (this);
621 this_len_byte
= count_size_as_multibyte (SDATA (this),
623 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
625 result_len_byte
+= this_len_byte
;
630 if (MOST_POSITIVE_FIXNUM
< result_len
)
631 memory_full (SIZE_MAX
);
634 if (! some_multibyte
)
635 result_len_byte
= result_len
;
637 /* Create the output object. */
638 if (target_type
== Lisp_Cons
)
639 val
= Fmake_list (make_number (result_len
), Qnil
);
640 else if (target_type
== Lisp_Vectorlike
)
641 val
= Fmake_vector (make_number (result_len
), Qnil
);
642 else if (some_multibyte
)
643 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
645 val
= make_uninit_string (result_len
);
647 /* In `append', if all but last arg are nil, return last arg. */
648 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
651 /* Copy the contents of the args into the result. */
653 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
655 toindex
= 0, toindex_byte
= 0;
659 SAFE_NALLOCA (textprops
, 1, nargs
);
661 for (argnum
= 0; argnum
< nargs
; argnum
++)
664 ptrdiff_t thisleni
= 0;
665 register ptrdiff_t thisindex
= 0;
666 register ptrdiff_t thisindex_byte
= 0;
670 thislen
= Flength (this), thisleni
= XINT (thislen
);
672 /* Between strings of the same kind, copy fast. */
673 if (STRINGP (this) && STRINGP (val
)
674 && STRING_MULTIBYTE (this) == some_multibyte
)
676 ptrdiff_t thislen_byte
= SBYTES (this);
678 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
679 if (string_intervals (this))
681 textprops
[num_textprops
].argnum
= argnum
;
682 textprops
[num_textprops
].from
= 0;
683 textprops
[num_textprops
++].to
= toindex
;
685 toindex_byte
+= thislen_byte
;
688 /* Copy a single-byte string to a multibyte string. */
689 else if (STRINGP (this) && STRINGP (val
))
691 if (string_intervals (this))
693 textprops
[num_textprops
].argnum
= argnum
;
694 textprops
[num_textprops
].from
= 0;
695 textprops
[num_textprops
++].to
= toindex
;
697 toindex_byte
+= copy_text (SDATA (this),
698 SDATA (val
) + toindex_byte
,
699 SCHARS (this), 0, 1);
703 /* Copy element by element. */
706 register Lisp_Object elt
;
708 /* Fetch next element of `this' arg into `elt', or break if
709 `this' is exhausted. */
710 if (NILP (this)) break;
712 elt
= XCAR (this), this = XCDR (this);
713 else if (thisindex
>= thisleni
)
715 else if (STRINGP (this))
718 if (STRING_MULTIBYTE (this))
719 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
724 c
= SREF (this, thisindex
); thisindex
++;
725 if (some_multibyte
&& !ASCII_CHAR_P (c
))
726 c
= BYTE8_TO_CHAR (c
);
728 XSETFASTINT (elt
, c
);
730 else if (BOOL_VECTOR_P (this))
732 elt
= bool_vector_ref (this, thisindex
);
737 elt
= AREF (this, thisindex
);
741 /* Store this element into the result. */
748 else if (VECTORP (val
))
750 ASET (val
, toindex
, elt
);
756 CHECK_CHARACTER (elt
);
759 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
761 SSET (val
, toindex_byte
++, c
);
767 XSETCDR (prev
, last_tail
);
769 if (num_textprops
> 0)
772 ptrdiff_t last_to_end
= -1;
774 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
776 this = args
[textprops
[argnum
].argnum
];
777 props
= text_property_list (this,
779 make_number (SCHARS (this)),
781 /* If successive arguments have properties, be sure that the
782 value of `composition' property be the copy. */
783 if (last_to_end
== textprops
[argnum
].to
)
784 make_composition_value_copy (props
);
785 add_text_properties_from_list (val
, props
,
786 make_number (textprops
[argnum
].to
));
787 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
795 static Lisp_Object string_char_byte_cache_string
;
796 static ptrdiff_t string_char_byte_cache_charpos
;
797 static ptrdiff_t string_char_byte_cache_bytepos
;
800 clear_string_char_byte_cache (void)
802 string_char_byte_cache_string
= Qnil
;
805 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
808 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
811 ptrdiff_t best_below
, best_below_byte
;
812 ptrdiff_t best_above
, best_above_byte
;
814 best_below
= best_below_byte
= 0;
815 best_above
= SCHARS (string
);
816 best_above_byte
= SBYTES (string
);
817 if (best_above
== best_above_byte
)
820 if (EQ (string
, string_char_byte_cache_string
))
822 if (string_char_byte_cache_charpos
< char_index
)
824 best_below
= string_char_byte_cache_charpos
;
825 best_below_byte
= string_char_byte_cache_bytepos
;
829 best_above
= string_char_byte_cache_charpos
;
830 best_above_byte
= string_char_byte_cache_bytepos
;
834 if (char_index
- best_below
< best_above
- char_index
)
836 unsigned char *p
= SDATA (string
) + best_below_byte
;
838 while (best_below
< char_index
)
840 p
+= BYTES_BY_CHAR_HEAD (*p
);
843 i_byte
= p
- SDATA (string
);
847 unsigned char *p
= SDATA (string
) + best_above_byte
;
849 while (best_above
> char_index
)
852 while (!CHAR_HEAD_P (*p
)) p
--;
855 i_byte
= p
- SDATA (string
);
858 string_char_byte_cache_bytepos
= i_byte
;
859 string_char_byte_cache_charpos
= char_index
;
860 string_char_byte_cache_string
= string
;
865 /* Return the character index corresponding to BYTE_INDEX in STRING. */
868 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
871 ptrdiff_t best_below
, best_below_byte
;
872 ptrdiff_t best_above
, best_above_byte
;
874 best_below
= best_below_byte
= 0;
875 best_above
= SCHARS (string
);
876 best_above_byte
= SBYTES (string
);
877 if (best_above
== best_above_byte
)
880 if (EQ (string
, string_char_byte_cache_string
))
882 if (string_char_byte_cache_bytepos
< byte_index
)
884 best_below
= string_char_byte_cache_charpos
;
885 best_below_byte
= string_char_byte_cache_bytepos
;
889 best_above
= string_char_byte_cache_charpos
;
890 best_above_byte
= string_char_byte_cache_bytepos
;
894 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
896 unsigned char *p
= SDATA (string
) + best_below_byte
;
897 unsigned char *pend
= SDATA (string
) + byte_index
;
901 p
+= BYTES_BY_CHAR_HEAD (*p
);
905 i_byte
= p
- SDATA (string
);
909 unsigned char *p
= SDATA (string
) + best_above_byte
;
910 unsigned char *pbeg
= SDATA (string
) + byte_index
;
915 while (!CHAR_HEAD_P (*p
)) p
--;
919 i_byte
= p
- SDATA (string
);
922 string_char_byte_cache_bytepos
= i_byte
;
923 string_char_byte_cache_charpos
= i
;
924 string_char_byte_cache_string
= string
;
929 /* Convert STRING to a multibyte string. */
932 string_make_multibyte (Lisp_Object string
)
939 if (STRING_MULTIBYTE (string
))
942 nbytes
= count_size_as_multibyte (SDATA (string
),
944 /* If all the chars are ASCII, they won't need any more bytes
945 once converted. In that case, we can return STRING itself. */
946 if (nbytes
== SBYTES (string
))
949 buf
= SAFE_ALLOCA (nbytes
);
950 copy_text (SDATA (string
), buf
, SBYTES (string
),
953 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
960 /* Convert STRING (if unibyte) to a multibyte string without changing
961 the number of characters. Characters 0200 trough 0237 are
962 converted to eight-bit characters. */
965 string_to_multibyte (Lisp_Object string
)
972 if (STRING_MULTIBYTE (string
))
975 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
976 /* If all the chars are ASCII, they won't need any more bytes once
978 if (nbytes
== SBYTES (string
))
979 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
981 buf
= SAFE_ALLOCA (nbytes
);
982 memcpy (buf
, SDATA (string
), SBYTES (string
));
983 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
985 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
992 /* Convert STRING to a single-byte string. */
995 string_make_unibyte (Lisp_Object string
)
1002 if (! STRING_MULTIBYTE (string
))
1005 nchars
= SCHARS (string
);
1007 buf
= SAFE_ALLOCA (nchars
);
1008 copy_text (SDATA (string
), buf
, SBYTES (string
),
1011 ret
= make_unibyte_string ((char *) buf
, nchars
);
1017 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1019 doc
: /* Return the multibyte equivalent of STRING.
1020 If STRING is unibyte and contains non-ASCII characters, the function
1021 `unibyte-char-to-multibyte' is used to convert each unibyte character
1022 to a multibyte character. In this case, the returned string is a
1023 newly created string with no text properties. If STRING is multibyte
1024 or entirely ASCII, it is returned unchanged. In particular, when
1025 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1026 \(When the characters are all ASCII, Emacs primitives will treat the
1027 string the same way whether it is unibyte or multibyte.) */)
1028 (Lisp_Object string
)
1030 CHECK_STRING (string
);
1032 return string_make_multibyte (string
);
1035 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1037 doc
: /* Return the unibyte equivalent of STRING.
1038 Multibyte character codes are converted to unibyte according to
1039 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1040 If the lookup in the translation table fails, this function takes just
1041 the low 8 bits of each character. */)
1042 (Lisp_Object string
)
1044 CHECK_STRING (string
);
1046 return string_make_unibyte (string
);
1049 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1051 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1052 If STRING is unibyte, the result is STRING itself.
1053 Otherwise it is a newly created string, with no text properties.
1054 If STRING is multibyte and contains a character of charset
1055 `eight-bit', it is converted to the corresponding single byte. */)
1056 (Lisp_Object string
)
1058 CHECK_STRING (string
);
1060 if (STRING_MULTIBYTE (string
))
1062 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1063 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1065 string
= make_unibyte_string ((char *) str
, bytes
);
1071 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1073 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1074 If STRING is multibyte, the result is STRING itself.
1075 Otherwise it is a newly created string, with no text properties.
1077 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1078 part of a correct utf-8 sequence), it is converted to the corresponding
1079 multibyte character of charset `eight-bit'.
1080 See also `string-to-multibyte'.
1082 Beware, this often doesn't really do what you think it does.
1083 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1084 If you're not sure, whether to use `string-as-multibyte' or
1085 `string-to-multibyte', use `string-to-multibyte'. */)
1086 (Lisp_Object string
)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1093 ptrdiff_t nchars
, nbytes
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1100 if (nbytes
!= SBYTES (string
))
1101 str_as_multibyte (SDATA (new_string
), nbytes
,
1102 SBYTES (string
), NULL
);
1103 string
= new_string
;
1104 set_string_intervals (string
, NULL
);
1109 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1111 doc
: /* Return a multibyte string with the same individual chars as STRING.
1112 If STRING is multibyte, the result is STRING itself.
1113 Otherwise it is a newly created string, with no text properties.
1115 If STRING is unibyte and contains an 8-bit byte, it is converted to
1116 the corresponding multibyte character of charset `eight-bit'.
1118 This differs from `string-as-multibyte' by converting each byte of a correct
1119 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1120 correct sequence. */)
1121 (Lisp_Object string
)
1123 CHECK_STRING (string
);
1125 return string_to_multibyte (string
);
1128 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1130 doc
: /* Return a unibyte string with the same individual chars as STRING.
1131 If STRING is unibyte, the result is STRING itself.
1132 Otherwise it is a newly created string, with no text properties,
1133 where each `eight-bit' character is converted to the corresponding byte.
1134 If STRING contains a non-ASCII, non-`eight-bit' character,
1135 an error is signaled. */)
1136 (Lisp_Object string
)
1138 CHECK_STRING (string
);
1140 if (STRING_MULTIBYTE (string
))
1142 ptrdiff_t chars
= SCHARS (string
);
1143 unsigned char *str
= xmalloc (chars
);
1144 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1146 if (converted
< chars
)
1147 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1148 string
= make_unibyte_string ((char *) str
, chars
);
1155 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1156 doc
: /* Return a copy of ALIST.
1157 This is an alist which represents the same mapping from objects to objects,
1158 but does not share the alist structure with ALIST.
1159 The objects mapped (cars and cdrs of elements of the alist)
1160 are shared, however.
1161 Elements of ALIST that are not conses are also shared. */)
1166 alist
= concat (1, &alist
, Lisp_Cons
, false);
1167 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1169 Lisp_Object car
= XCAR (tem
);
1171 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1176 /* Check that ARRAY can have a valid subarray [FROM..TO),
1177 given that its size is SIZE.
1178 If FROM is nil, use 0; if TO is nil, use SIZE.
1179 Count negative values backwards from the end.
1180 Set *IFROM and *ITO to the two indexes used. */
1183 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1184 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1188 if (INTEGERP (from
))
1194 else if (NILP (from
))
1197 wrong_type_argument (Qintegerp
, from
);
1208 wrong_type_argument (Qintegerp
, to
);
1210 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1211 args_out_of_range_3 (array
, from
, to
);
1217 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1218 doc
: /* Return a new string whose contents are a substring of STRING.
1219 The returned string consists of the characters between index FROM
1220 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1221 zero-indexed: 0 means the first character of STRING. Negative values
1222 are counted from the end of STRING. If TO is nil, the substring runs
1223 to the end of STRING.
1225 The STRING argument may also be a vector. In that case, the return
1226 value is a new vector that contains the elements between index FROM
1227 \(inclusive) and index TO (exclusive) of that vector argument.
1229 With one argument, just copy STRING (with properties, if any). */)
1230 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1233 ptrdiff_t size
, ifrom
, ito
;
1235 size
= CHECK_VECTOR_OR_STRING (string
);
1236 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1238 if (STRINGP (string
))
1241 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1243 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1244 res
= make_specified_string (SSDATA (string
) + from_byte
,
1245 ito
- ifrom
, to_byte
- from_byte
,
1246 STRING_MULTIBYTE (string
));
1247 copy_text_properties (make_number (ifrom
), make_number (ito
),
1248 string
, make_number (0), res
, Qnil
);
1251 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1257 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1258 doc
: /* Return a substring of STRING, without text properties.
1259 It starts at index FROM and ends before TO.
1260 TO may be nil or omitted; then the substring runs to the end of STRING.
1261 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1262 If FROM or TO is negative, it counts from the end.
1264 With one argument, just copy STRING without its properties. */)
1265 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1267 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1269 CHECK_STRING (string
);
1271 size
= SCHARS (string
);
1272 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1274 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1276 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1277 return make_specified_string (SSDATA (string
) + from_byte
,
1278 to_char
- from_char
, to_byte
- from_byte
,
1279 STRING_MULTIBYTE (string
));
1282 /* Extract a substring of STRING, giving start and end positions
1283 both in characters and in bytes. */
1286 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1287 ptrdiff_t to
, ptrdiff_t to_byte
)
1290 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1292 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1293 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1295 if (STRINGP (string
))
1297 res
= make_specified_string (SSDATA (string
) + from_byte
,
1298 to
- from
, to_byte
- from_byte
,
1299 STRING_MULTIBYTE (string
));
1300 copy_text_properties (make_number (from
), make_number (to
),
1301 string
, make_number (0), res
, Qnil
);
1304 res
= Fvector (to
- from
, aref_addr (string
, from
));
1309 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1310 doc
: /* Take cdr N times on LIST, return the result. */)
1311 (Lisp_Object n
, Lisp_Object list
)
1314 Lisp_Object tail
= list
;
1315 for (EMACS_INT num
= XINT (n
); 0 < num
; num
--)
1319 CHECK_LIST_END (tail
, list
);
1328 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1329 doc
: /* Return the Nth element of LIST.
1330 N counts from zero. If LIST is not that long, nil is returned. */)
1331 (Lisp_Object n
, Lisp_Object list
)
1333 return Fcar (Fnthcdr (n
, list
));
1336 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1337 doc
: /* Return element of SEQUENCE at index N. */)
1338 (register Lisp_Object sequence
, Lisp_Object n
)
1341 if (CONSP (sequence
) || NILP (sequence
))
1342 return Fcar (Fnthcdr (n
, sequence
));
1344 /* Faref signals a "not array" error, so check here. */
1345 CHECK_ARRAY (sequence
, Qsequencep
);
1346 return Faref (sequence
, n
);
1349 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1350 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1351 The value is actually the tail of LIST whose car is ELT. */)
1352 (Lisp_Object elt
, Lisp_Object list
)
1354 Lisp_Object tail
= list
;
1355 FOR_EACH_TAIL (tail
)
1356 if (! NILP (Fequal (elt
, XCAR (tail
))))
1358 CHECK_LIST_END (tail
, list
);
1362 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1363 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1364 The value is actually the tail of LIST whose car is ELT. */)
1365 (Lisp_Object elt
, Lisp_Object list
)
1367 Lisp_Object tail
= list
;
1368 FOR_EACH_TAIL (tail
)
1369 if (EQ (XCAR (tail
), elt
))
1371 CHECK_LIST_END (tail
, list
);
1375 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1376 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1377 The value is actually the tail of LIST whose car is ELT. */)
1378 (Lisp_Object elt
, Lisp_Object list
)
1381 return Fmemq (elt
, list
);
1383 Lisp_Object tail
= list
;
1384 FOR_EACH_TAIL (tail
)
1386 Lisp_Object tem
= XCAR (tail
);
1387 if (FLOATP (tem
) && equal_no_quit (elt
, tem
))
1390 CHECK_LIST_END (tail
, list
);
1394 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1395 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1396 The value is actually the first element of LIST whose car is KEY.
1397 Elements of LIST that are not conses are ignored. */)
1398 (Lisp_Object key
, Lisp_Object list
)
1400 Lisp_Object tail
= list
;
1401 FOR_EACH_TAIL (tail
)
1402 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1404 CHECK_LIST_END (tail
, list
);
1408 /* Like Fassq but never report an error and do not allow quits.
1409 Use only on objects known to be non-circular lists. */
1412 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1414 for (; ! NILP (list
); list
= XCDR (list
))
1415 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1420 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 3, 0,
1421 doc
: /* Return non-nil if KEY is equal to the car of an element of LIST.
1422 The value is actually the first element of LIST whose car equals KEY.
1424 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1425 (Lisp_Object key
, Lisp_Object list
, Lisp_Object testfn
)
1427 Lisp_Object tail
= list
;
1428 FOR_EACH_TAIL (tail
)
1430 Lisp_Object car
= XCAR (tail
);
1433 ? (EQ (XCAR (car
), key
) || !NILP (Fequal
1435 : !NILP (call2 (testfn
, XCAR (car
), key
))))
1438 CHECK_LIST_END (tail
, list
);
1442 /* Like Fassoc but never report an error and do not allow quits.
1443 Use only on keys and lists known to be non-circular, and on keys
1444 that are not too deep and are not window configurations. */
1447 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1449 for (; ! NILP (list
); list
= XCDR (list
))
1451 Lisp_Object car
= XCAR (list
);
1453 && (EQ (XCAR (car
), key
) || equal_no_quit (XCAR (car
), key
)))
1459 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1460 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1461 The value is actually the first element of LIST whose cdr is KEY. */)
1462 (Lisp_Object key
, Lisp_Object list
)
1464 Lisp_Object tail
= list
;
1465 FOR_EACH_TAIL (tail
)
1466 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1468 CHECK_LIST_END (tail
, list
);
1472 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1473 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1474 The value is actually the first element of LIST whose cdr equals KEY. */)
1475 (Lisp_Object key
, Lisp_Object list
)
1477 Lisp_Object tail
= list
;
1478 FOR_EACH_TAIL (tail
)
1480 Lisp_Object car
= XCAR (tail
);
1482 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1485 CHECK_LIST_END (tail
, list
);
1489 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1490 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1491 More precisely, this function skips any members `eq' to ELT at the
1492 front of LIST, then removes members `eq' to ELT from the remaining
1493 sublist by modifying its list structure, then returns the resulting
1496 Write `(setq foo (delq element foo))' to be sure of correctly changing
1497 the value of a list `foo'. See also `remq', which does not modify the
1499 (Lisp_Object elt
, Lisp_Object list
)
1501 Lisp_Object prev
= Qnil
, tail
= list
;
1503 FOR_EACH_TAIL (tail
)
1505 Lisp_Object tem
= XCAR (tail
);
1511 Fsetcdr (prev
, XCDR (tail
));
1516 CHECK_LIST_END (tail
, list
);
1520 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1521 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1522 SEQ must be a sequence (i.e. a list, a vector, or a string).
1523 The return value is a sequence of the same type.
1525 If SEQ is a list, this behaves like `delq', except that it compares
1526 with `equal' instead of `eq'. In particular, it may remove elements
1527 by altering the list structure.
1529 If SEQ is not a list, deletion is never performed destructively;
1530 instead this function creates and returns a new vector or string.
1532 Write `(setq foo (delete element foo))' to be sure of correctly
1533 changing the value of a sequence `foo'. */)
1534 (Lisp_Object elt
, Lisp_Object seq
)
1540 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1541 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1544 if (n
!= ASIZE (seq
))
1546 struct Lisp_Vector
*p
= allocate_vector (n
);
1548 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1549 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1550 p
->contents
[n
++] = AREF (seq
, i
);
1552 XSETVECTOR (seq
, p
);
1555 else if (STRINGP (seq
))
1557 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1560 for (i
= nchars
= nbytes
= ibyte
= 0;
1562 ++i
, ibyte
+= cbytes
)
1564 if (STRING_MULTIBYTE (seq
))
1566 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1567 cbytes
= CHAR_BYTES (c
);
1575 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1582 if (nchars
!= SCHARS (seq
))
1586 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1587 if (!STRING_MULTIBYTE (seq
))
1588 STRING_SET_UNIBYTE (tem
);
1590 for (i
= nchars
= nbytes
= ibyte
= 0;
1592 ++i
, ibyte
+= cbytes
)
1594 if (STRING_MULTIBYTE (seq
))
1596 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1597 cbytes
= CHAR_BYTES (c
);
1605 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1607 unsigned char *from
= SDATA (seq
) + ibyte
;
1608 unsigned char *to
= SDATA (tem
) + nbytes
;
1614 for (n
= cbytes
; n
--; )
1624 Lisp_Object prev
= Qnil
, tail
= seq
;
1626 FOR_EACH_TAIL (tail
)
1628 if (!NILP (Fequal (elt
, XCAR (tail
))))
1633 Fsetcdr (prev
, XCDR (tail
));
1638 CHECK_LIST_END (tail
, seq
);
1644 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1645 doc
: /* Reverse order of items in a list, vector or string SEQ.
1646 If SEQ is a list, it should be nil-terminated.
1647 This function may destructively modify SEQ to produce the value. */)
1652 else if (STRINGP (seq
))
1653 return Freverse (seq
);
1654 else if (CONSP (seq
))
1656 Lisp_Object prev
, tail
, next
;
1658 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1661 /* If SEQ contains a cycle, attempting to reverse it
1662 in-place will inevitably come back to SEQ. */
1664 circular_list (seq
);
1665 Fsetcdr (tail
, prev
);
1668 CHECK_LIST_END (tail
, seq
);
1671 else if (VECTORP (seq
))
1673 ptrdiff_t i
, size
= ASIZE (seq
);
1675 for (i
= 0; i
< size
/ 2; i
++)
1677 Lisp_Object tem
= AREF (seq
, i
);
1678 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1679 ASET (seq
, size
- i
- 1, tem
);
1682 else if (BOOL_VECTOR_P (seq
))
1684 ptrdiff_t i
, size
= bool_vector_size (seq
);
1686 for (i
= 0; i
< size
/ 2; i
++)
1688 bool tem
= bool_vector_bitref (seq
, i
);
1689 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1690 bool_vector_set (seq
, size
- i
- 1, tem
);
1694 wrong_type_argument (Qarrayp
, seq
);
1698 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1699 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1700 See also the function `nreverse', which is used more often. */)
1707 else if (CONSP (seq
))
1711 new = Fcons (XCAR (seq
), new);
1712 CHECK_LIST_END (seq
, seq
);
1714 else if (VECTORP (seq
))
1716 ptrdiff_t i
, size
= ASIZE (seq
);
1718 new = make_uninit_vector (size
);
1719 for (i
= 0; i
< size
; i
++)
1720 ASET (new, i
, AREF (seq
, size
- i
- 1));
1722 else if (BOOL_VECTOR_P (seq
))
1725 EMACS_INT nbits
= bool_vector_size (seq
);
1727 new = make_uninit_bool_vector (nbits
);
1728 for (i
= 0; i
< nbits
; i
++)
1729 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1731 else if (STRINGP (seq
))
1733 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1739 new = make_uninit_string (size
);
1740 for (i
= 0; i
< size
; i
++)
1741 SSET (new, i
, SREF (seq
, size
- i
- 1));
1745 unsigned char *p
, *q
;
1747 new = make_uninit_multibyte_string (size
, bytes
);
1748 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1749 while (q
> SDATA (new))
1753 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1755 CHAR_STRING (ch
, q
);
1760 wrong_type_argument (Qsequencep
, seq
);
1764 /* Sort LIST using PREDICATE, preserving original order of elements
1765 considered as equal. */
1768 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1770 Lisp_Object front
, back
;
1771 Lisp_Object len
, tem
;
1775 len
= Flength (list
);
1776 length
= XINT (len
);
1780 XSETINT (len
, (length
/ 2) - 1);
1781 tem
= Fnthcdr (len
, list
);
1783 Fsetcdr (tem
, Qnil
);
1785 front
= Fsort (front
, predicate
);
1786 back
= Fsort (back
, predicate
);
1787 return merge (front
, back
, predicate
);
1790 /* Using PRED to compare, return whether A and B are in order.
1791 Compare stably when A appeared before B in the input. */
1793 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1795 return NILP (call2 (pred
, b
, a
));
1798 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1799 into DEST. Argument arrays must be nonempty and must not overlap,
1800 except that B might be the last part of DEST. */
1802 merge_vectors (Lisp_Object pred
,
1803 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1804 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1805 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1807 eassume (0 < alen
&& 0 < blen
);
1808 Lisp_Object
const *alim
= a
+ alen
;
1809 Lisp_Object
const *blim
= b
+ blen
;
1813 if (inorder (pred
, a
[0], b
[0]))
1819 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1828 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1835 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1836 temporary storage. LEN must be at least 2. */
1838 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1839 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1840 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1843 ptrdiff_t halflen
= len
>> 1;
1844 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1845 if (1 < len
- halflen
)
1846 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1847 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1850 /* Using PRED to compare, sort from LEN-length SRC into DST.
1851 Len must be positive. */
1853 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1854 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1855 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1858 ptrdiff_t halflen
= len
>> 1;
1864 sort_vector_inplace (pred
, halflen
, src
, dest
);
1865 if (1 < len
- halflen
)
1866 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1867 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1871 /* Sort VECTOR in place using PREDICATE, preserving original order of
1872 elements considered as equal. */
1875 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1877 ptrdiff_t len
= ASIZE (vector
);
1880 ptrdiff_t halflen
= len
>> 1;
1883 SAFE_ALLOCA_LISP (tmp
, halflen
);
1884 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1885 tmp
[i
] = make_number (0);
1886 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1890 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1891 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1892 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1893 modified by side effects. PREDICATE is called with two elements of
1894 SEQ, and should return non-nil if the first element should sort before
1896 (Lisp_Object seq
, Lisp_Object predicate
)
1899 seq
= sort_list (seq
, predicate
);
1900 else if (VECTORP (seq
))
1901 sort_vector (seq
, predicate
);
1902 else if (!NILP (seq
))
1903 wrong_type_argument (Qsequencep
, seq
);
1908 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1910 Lisp_Object l1
= org_l1
;
1911 Lisp_Object l2
= org_l2
;
1912 Lisp_Object tail
= Qnil
;
1913 Lisp_Object value
= Qnil
;
1933 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
1948 Fsetcdr (tail
, tem
);
1954 /* This does not check for quits. That is safe since it must terminate. */
1956 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1957 doc
: /* Extract a value from a property list.
1958 PLIST is a property list, which is a list of the form
1959 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1960 corresponding to the given PROP, or nil if PROP is not one of the
1961 properties on the list. This function never signals an error. */)
1962 (Lisp_Object plist
, Lisp_Object prop
)
1964 Lisp_Object tail
= plist
;
1965 FOR_EACH_TAIL_SAFE (tail
)
1967 if (! CONSP (XCDR (tail
)))
1969 if (EQ (prop
, XCAR (tail
)))
1970 return XCAR (XCDR (tail
));
1972 if (EQ (tail
, li
.tortoise
))
1979 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1980 doc
: /* Return the value of SYMBOL's PROPNAME property.
1981 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1982 (Lisp_Object symbol
, Lisp_Object propname
)
1984 CHECK_SYMBOL (symbol
);
1985 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1988 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1989 doc
: /* Change value in PLIST of PROP to VAL.
1990 PLIST is a property list, which is a list of the form
1991 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1992 If PROP is already a property on the list, its value is set to VAL,
1993 otherwise the new PROP VAL pair is added. The new plist is returned;
1994 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1995 The PLIST is modified by side effects. */)
1996 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
1998 Lisp_Object prev
= Qnil
, tail
= plist
;
1999 FOR_EACH_TAIL (tail
)
2001 if (! CONSP (XCDR (tail
)))
2004 if (EQ (prop
, XCAR (tail
)))
2006 Fsetcar (XCDR (tail
), val
);
2012 if (EQ (tail
, li
.tortoise
))
2013 circular_list (plist
);
2015 CHECK_LIST_END (tail
, plist
);
2017 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2020 Fsetcdr (XCDR (prev
), newcell
);
2024 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2025 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2026 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2027 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2029 CHECK_SYMBOL (symbol
);
2031 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2035 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2036 doc
: /* Extract a value from a property list, comparing with `equal'.
2037 PLIST is a property list, which is a list of the form
2038 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2039 corresponding to the given PROP, or nil if PROP is not
2040 one of the properties on the list. */)
2041 (Lisp_Object plist
, Lisp_Object prop
)
2043 Lisp_Object tail
= plist
;
2044 FOR_EACH_TAIL (tail
)
2046 if (! CONSP (XCDR (tail
)))
2048 if (! NILP (Fequal (prop
, XCAR (tail
))))
2049 return XCAR (XCDR (tail
));
2051 if (EQ (tail
, li
.tortoise
))
2052 circular_list (plist
);
2055 CHECK_LIST_END (tail
, plist
);
2060 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2061 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2062 PLIST is a property list, which is a list of the form
2063 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2064 If PROP is already a property on the list, its value is set to VAL,
2065 otherwise the new PROP VAL pair is added. The new plist is returned;
2066 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2067 The PLIST is modified by side effects. */)
2068 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2070 Lisp_Object prev
= Qnil
, tail
= plist
;
2071 FOR_EACH_TAIL (tail
)
2073 if (! CONSP (XCDR (tail
)))
2076 if (! NILP (Fequal (prop
, XCAR (tail
))))
2078 Fsetcar (XCDR (tail
), val
);
2084 if (EQ (tail
, li
.tortoise
))
2085 circular_list (plist
);
2087 CHECK_LIST_END (tail
, plist
);
2088 Lisp_Object newcell
= list2 (prop
, val
);
2091 Fsetcdr (XCDR (prev
), newcell
);
2095 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2096 doc
: /* Return t if the two args are the same Lisp object.
2097 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2098 (Lisp_Object obj1
, Lisp_Object obj2
)
2101 return equal_no_quit (obj1
, obj2
) ? Qt
: Qnil
;
2103 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2106 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2107 doc
: /* Return t if two Lisp objects have similar structure and contents.
2108 They must have the same data type.
2109 Conses are compared by comparing the cars and the cdrs.
2110 Vectors and strings are compared element by element.
2111 Numbers are compared by value, but integers cannot equal floats.
2112 (Use `=' if you want integers and floats to be able to be equal.)
2113 Symbols must match exactly. */)
2114 (Lisp_Object o1
, Lisp_Object o2
)
2116 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2119 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2120 doc
: /* Return t if two Lisp objects have similar structure and contents.
2121 This is like `equal' except that it compares the text properties
2122 of strings. (`equal' ignores text properties.) */)
2123 (Lisp_Object o1
, Lisp_Object o2
)
2125 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2129 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2130 Use this only on arguments that are cycle-free and not too large and
2131 are not window configurations. */
2134 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2136 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2139 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2140 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2141 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2142 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2143 equal-including-properties.
2145 If DEPTH is the current depth of recursion; signal an error if it
2146 gets too deep. HT is a hash table used to detect cycles; if nil,
2147 it has not been allocated yet. But ignore the last two arguments
2148 if EQUAL_KIND == EQUAL_NO_QUIT. */
2151 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2152 int depth
, Lisp_Object ht
)
2157 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2159 error ("Stack overflow in equal");
2161 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2164 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2166 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2168 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2170 { /* `o1' was seen already. */
2171 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2172 if (!NILP (Fmemq (o2
, o2s
)))
2175 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2178 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2186 if (XTYPE (o1
) != XTYPE (o2
))
2193 double d1
= XFLOAT_DATA (o1
);
2194 double d2
= XFLOAT_DATA (o2
);
2195 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2196 though they are not =. */
2197 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2201 if (equal_kind
== EQUAL_NO_QUIT
)
2202 for (; CONSP (o1
); o1
= XCDR (o1
))
2206 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2209 if (EQ (XCDR (o1
), o2
))
2217 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2218 equal_kind
, depth
+ 1, ht
))
2221 if (EQ (XCDR (o1
), o2
))
2228 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2232 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2233 equal_kind
, depth
+ 1, ht
)
2234 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2235 equal_kind
, depth
+ 1, ht
))
2237 o1
= XOVERLAY (o1
)->plist
;
2238 o2
= XOVERLAY (o2
)->plist
;
2244 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2245 && (XMARKER (o1
)->buffer
== 0
2246 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2250 case Lisp_Vectorlike
:
2253 ptrdiff_t size
= ASIZE (o1
);
2254 /* Pseudovectors have the type encoded in the size field, so this test
2255 actually checks that the objects have the same type as well as the
2257 if (ASIZE (o2
) != size
)
2259 /* Boolvectors are compared much like strings. */
2260 if (BOOL_VECTOR_P (o1
))
2262 EMACS_INT size
= bool_vector_size (o1
);
2263 if (size
!= bool_vector_size (o2
))
2265 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2266 bool_vector_bytes (size
)))
2270 if (WINDOW_CONFIGURATIONP (o1
))
2272 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2273 return compare_window_configurations (o1
, o2
, false);
2276 /* Aside from them, only true vectors, char-tables, compiled
2277 functions, and fonts (font-spec, font-entity, font-object)
2278 are sensible to compare, so eliminate the others now. */
2279 if (size
& PSEUDOVECTOR_FLAG
)
2281 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2284 size
&= PSEUDOVECTOR_SIZE_MASK
;
2286 for (i
= 0; i
< size
; i
++)
2291 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2299 if (SCHARS (o1
) != SCHARS (o2
))
2301 if (SBYTES (o1
) != SBYTES (o2
))
2303 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2305 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2306 && !compare_string_intervals (o1
, o2
))
2318 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2319 doc
: /* Store each element of ARRAY with ITEM.
2320 ARRAY is a vector, string, char-table, or bool-vector. */)
2321 (Lisp_Object array
, Lisp_Object item
)
2323 register ptrdiff_t size
, idx
;
2325 if (VECTORP (array
))
2326 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2327 ASET (array
, idx
, item
);
2328 else if (CHAR_TABLE_P (array
))
2332 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2333 set_char_table_contents (array
, i
, item
);
2334 set_char_table_defalt (array
, item
);
2336 else if (STRINGP (array
))
2338 register unsigned char *p
= SDATA (array
);
2340 CHECK_CHARACTER (item
);
2341 charval
= XFASTINT (item
);
2342 size
= SCHARS (array
);
2343 if (STRING_MULTIBYTE (array
))
2345 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2346 int len
= CHAR_STRING (charval
, str
);
2347 ptrdiff_t size_byte
= SBYTES (array
);
2350 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2351 error ("Attempt to change byte length of a string");
2352 for (idx
= 0; idx
< size_byte
; idx
++)
2353 *p
++ = str
[idx
% len
];
2356 for (idx
= 0; idx
< size
; idx
++)
2359 else if (BOOL_VECTOR_P (array
))
2360 return bool_vector_fill (array
, item
);
2362 wrong_type_argument (Qarrayp
, array
);
2366 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2368 doc
: /* Clear the contents of STRING.
2369 This makes STRING unibyte and may change its length. */)
2370 (Lisp_Object string
)
2373 CHECK_STRING (string
);
2374 len
= SBYTES (string
);
2375 memset (SDATA (string
), 0, len
);
2376 STRING_SET_CHARS (string
, len
);
2377 STRING_SET_UNIBYTE (string
);
2383 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2385 return CALLN (Fnconc
, s1
, s2
);
2388 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2389 doc
: /* Concatenate any number of lists by altering them.
2390 Only the last argument is not altered, and need not be a list.
2391 usage: (nconc &rest LISTS) */)
2392 (ptrdiff_t nargs
, Lisp_Object
*args
)
2394 Lisp_Object val
= Qnil
;
2396 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2398 Lisp_Object tem
= args
[argnum
];
2399 if (NILP (tem
)) continue;
2404 if (argnum
+ 1 == nargs
) break;
2412 tem
= args
[argnum
+ 1];
2413 Fsetcdr (tail
, tem
);
2415 args
[argnum
+ 1] = tail
;
2421 /* This is the guts of all mapping functions.
2422 Apply FN to each element of SEQ, one by one, storing the results
2423 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2424 length of VALS, which should also be the length of SEQ. Return the
2425 number of results; although this is normally LENI, it can be less
2426 if SEQ is made shorter as a side effect of FN. */
2429 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2431 Lisp_Object tail
, dummy
;
2434 if (VECTORP (seq
) || COMPILEDP (seq
))
2436 for (i
= 0; i
< leni
; i
++)
2438 dummy
= call1 (fn
, AREF (seq
, i
));
2443 else if (BOOL_VECTOR_P (seq
))
2445 for (i
= 0; i
< leni
; i
++)
2447 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2452 else if (STRINGP (seq
))
2456 for (i
= 0, i_byte
= 0; i
< leni
;)
2459 ptrdiff_t i_before
= i
;
2461 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2462 XSETFASTINT (dummy
, c
);
2463 dummy
= call1 (fn
, dummy
);
2465 vals
[i_before
] = dummy
;
2468 else /* Must be a list, since Flength did not get an error */
2471 for (i
= 0; i
< leni
; i
++)
2475 dummy
= call1 (fn
, XCAR (tail
));
2485 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2486 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2487 In between each pair of results, stick in SEPARATOR. Thus, " " as
2488 SEPARATOR results in spaces between the values returned by FUNCTION.
2489 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2490 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2493 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2494 if (CHAR_TABLE_P (sequence
))
2495 wrong_type_argument (Qlistp
, sequence
);
2496 EMACS_INT args_alloc
= 2 * leni
- 1;
2498 return empty_unibyte_string
;
2500 SAFE_ALLOCA_LISP (args
, args_alloc
);
2501 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2502 ptrdiff_t nargs
= 2 * nmapped
- 1;
2504 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2505 args
[i
+ i
] = args
[i
];
2507 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2508 args
[i
] = separator
;
2510 Lisp_Object ret
= Fconcat (nargs
, args
);
2515 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2516 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2517 The result is a list just as long as SEQUENCE.
2518 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2519 (Lisp_Object function
, Lisp_Object sequence
)
2522 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2523 if (CHAR_TABLE_P (sequence
))
2524 wrong_type_argument (Qlistp
, sequence
);
2526 SAFE_ALLOCA_LISP (args
, leni
);
2527 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2528 Lisp_Object ret
= Flist (nmapped
, args
);
2533 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2534 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2535 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2536 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2537 (Lisp_Object function
, Lisp_Object sequence
)
2539 register EMACS_INT leni
;
2541 leni
= XFASTINT (Flength (sequence
));
2542 if (CHAR_TABLE_P (sequence
))
2543 wrong_type_argument (Qlistp
, sequence
);
2544 mapcar1 (leni
, 0, function
, sequence
);
2549 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2550 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2551 the results by altering them (using `nconc').
2552 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2553 (Lisp_Object function
, Lisp_Object sequence
)
2556 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2557 if (CHAR_TABLE_P (sequence
))
2558 wrong_type_argument (Qlistp
, sequence
);
2560 SAFE_ALLOCA_LISP (args
, leni
);
2561 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2562 Lisp_Object ret
= Fnconc (nmapped
, args
);
2567 /* This is how C code calls `yes-or-no-p' and allows the user
2571 do_yes_or_no_p (Lisp_Object prompt
)
2573 return call1 (intern ("yes-or-no-p"), prompt
);
2576 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2577 doc
: /* Ask user a yes-or-no question.
2578 Return t if answer is yes, and nil if the answer is no.
2579 PROMPT is the string to display to ask the question. It should end in
2580 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2582 The user must confirm the answer with RET, and can edit it until it
2585 If dialog boxes are supported, a dialog box will be used
2586 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2587 (Lisp_Object prompt
)
2591 CHECK_STRING (prompt
);
2593 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2594 && use_dialog_box
&& ! NILP (last_input_event
))
2596 Lisp_Object pane
, menu
, obj
;
2597 redisplay_preserve_echo_area (4);
2598 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2599 Fcons (build_string ("No"), Qnil
));
2600 menu
= Fcons (prompt
, pane
);
2601 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2605 AUTO_STRING (yes_or_no
, "(yes or no) ");
2606 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2610 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2611 Qyes_or_no_p_history
, Qnil
,
2613 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2615 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2620 message1 ("Please answer yes or no.");
2621 Fsleep_for (make_number (2), Qnil
);
2625 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2626 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2628 Each of the three load averages is multiplied by 100, then converted
2631 When USE-FLOATS is non-nil, floats will be used instead of integers.
2632 These floats are not multiplied by 100.
2634 If the 5-minute or 15-minute load averages are not available, return a
2635 shortened list, containing only those averages which are available.
2637 An error is thrown if the load average can't be obtained. In some
2638 cases making it work would require Emacs being installed setuid or
2639 setgid so that it can read kernel information, and that usually isn't
2641 (Lisp_Object use_floats
)
2644 int loads
= getloadavg (load_ave
, 3);
2645 Lisp_Object ret
= Qnil
;
2648 error ("load-average not implemented for this operating system");
2652 Lisp_Object load
= (NILP (use_floats
)
2653 ? make_number (100.0 * load_ave
[loads
])
2654 : make_float (load_ave
[loads
]));
2655 ret
= Fcons (load
, ret
);
2661 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2662 doc
: /* Return t if FEATURE is present in this Emacs.
2664 Use this to conditionalize execution of lisp code based on the
2665 presence or absence of Emacs or environment extensions.
2666 Use `provide' to declare that a feature is available. This function
2667 looks at the value of the variable `features'. The optional argument
2668 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2669 (Lisp_Object feature
, Lisp_Object subfeature
)
2671 register Lisp_Object tem
;
2672 CHECK_SYMBOL (feature
);
2673 tem
= Fmemq (feature
, Vfeatures
);
2674 if (!NILP (tem
) && !NILP (subfeature
))
2675 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2676 return (NILP (tem
)) ? Qnil
: Qt
;
2679 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2680 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2681 The optional argument SUBFEATURES should be a list of symbols listing
2682 particular subfeatures supported in this version of FEATURE. */)
2683 (Lisp_Object feature
, Lisp_Object subfeatures
)
2685 register Lisp_Object tem
;
2686 CHECK_SYMBOL (feature
);
2687 CHECK_LIST (subfeatures
);
2688 if (!NILP (Vautoload_queue
))
2689 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2691 tem
= Fmemq (feature
, Vfeatures
);
2693 Vfeatures
= Fcons (feature
, Vfeatures
);
2694 if (!NILP (subfeatures
))
2695 Fput (feature
, Qsubfeatures
, subfeatures
);
2696 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2698 /* Run any load-hooks for this file. */
2699 tem
= Fassq (feature
, Vafter_load_alist
);
2701 Fmapc (Qfuncall
, XCDR (tem
));
2706 /* `require' and its subroutines. */
2708 /* List of features currently being require'd, innermost first. */
2710 static Lisp_Object require_nesting_list
;
2713 require_unwind (Lisp_Object old_value
)
2715 require_nesting_list
= old_value
;
2718 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2719 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2720 If FEATURE is not a member of the list `features', then the feature is
2721 not loaded; so load the file FILENAME.
2723 If FILENAME is omitted, the printname of FEATURE is used as the file
2724 name, and `load' will try to load this name appended with the suffix
2725 `.elc', `.el', or the system-dependent suffix for dynamic module
2726 files, in that order. The name without appended suffix will not be
2727 used. See `get-load-suffixes' for the complete list of suffixes.
2729 The directories in `load-path' are searched when trying to find the
2732 If the optional third argument NOERROR is non-nil, then return nil if
2733 the file is not found instead of signaling an error. Normally the
2734 return value is FEATURE.
2736 The normal messages at start and end of loading FILENAME are
2738 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2741 bool from_file
= load_in_progress
;
2743 CHECK_SYMBOL (feature
);
2745 /* Record the presence of `require' in this file
2746 even if the feature specified is already loaded.
2747 But not more than once in any file,
2748 and not when we aren't loading or reading from a file. */
2750 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2751 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2756 tem
= Fcons (Qrequire
, feature
);
2757 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2758 LOADHIST_ATTACH (tem
);
2760 tem
= Fmemq (feature
, Vfeatures
);
2764 ptrdiff_t count
= SPECPDL_INDEX ();
2767 /* This is to make sure that loadup.el gives a clear picture
2768 of what files are preloaded and when. */
2769 if (! NILP (Vpurify_flag
))
2770 error ("(require %s) while preparing to dump",
2771 SDATA (SYMBOL_NAME (feature
)));
2773 /* A certain amount of recursive `require' is legitimate,
2774 but if we require the same feature recursively 3 times,
2776 tem
= require_nesting_list
;
2777 while (! NILP (tem
))
2779 if (! NILP (Fequal (feature
, XCAR (tem
))))
2784 error ("Recursive `require' for feature `%s'",
2785 SDATA (SYMBOL_NAME (feature
)));
2787 /* Update the list for any nested `require's that occur. */
2788 record_unwind_protect (require_unwind
, require_nesting_list
);
2789 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2791 /* Value saved here is to be restored into Vautoload_queue */
2792 record_unwind_protect (un_autoload
, Vautoload_queue
);
2793 Vautoload_queue
= Qt
;
2795 /* Load the file. */
2796 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2797 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2799 /* If load failed entirely, return nil. */
2801 return unbind_to (count
, Qnil
);
2803 tem
= Fmemq (feature
, Vfeatures
);
2806 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
2807 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
2810 error ("Required feature `%s' was not provided", tem2
);
2812 /* Cf autoload-do-load. */
2813 error ("Loading file %s failed to provide feature `%s'",
2814 SDATA (tem3
), tem2
);
2817 /* Once loading finishes, don't undo it. */
2818 Vautoload_queue
= Qt
;
2819 feature
= unbind_to (count
, feature
);
2825 /* Primitives for work of the "widget" library.
2826 In an ideal world, this section would not have been necessary.
2827 However, lisp function calls being as slow as they are, it turns
2828 out that some functions in the widget library (wid-edit.el) are the
2829 bottleneck of Widget operation. Here is their translation to C,
2830 for the sole reason of efficiency. */
2832 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2833 doc
: /* Return non-nil if PLIST has the property PROP.
2834 PLIST is a property list, which is a list of the form
2835 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2836 Unlike `plist-get', this allows you to distinguish between a missing
2837 property and a property with the value nil.
2838 The value is actually the tail of PLIST whose car is PROP. */)
2839 (Lisp_Object plist
, Lisp_Object prop
)
2841 Lisp_Object tail
= plist
;
2842 FOR_EACH_TAIL (tail
)
2844 if (EQ (XCAR (tail
), prop
))
2849 if (EQ (tail
, li
.tortoise
))
2850 circular_list (tail
);
2852 CHECK_LIST_END (tail
, plist
);
2856 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2857 doc
: /* In WIDGET, set PROPERTY to VALUE.
2858 The value can later be retrieved with `widget-get'. */)
2859 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2861 CHECK_CONS (widget
);
2862 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2866 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2867 doc
: /* In WIDGET, get the value of PROPERTY.
2868 The value could either be specified when the widget was created, or
2869 later with `widget-put'. */)
2870 (Lisp_Object widget
, Lisp_Object property
)
2878 CHECK_CONS (widget
);
2879 tmp
= Fplist_member (XCDR (widget
), property
);
2885 tmp
= XCAR (widget
);
2888 widget
= Fget (tmp
, Qwidget_type
);
2892 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2893 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2894 ARGS are passed as extra arguments to the function.
2895 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2896 (ptrdiff_t nargs
, Lisp_Object
*args
)
2898 Lisp_Object widget
= args
[0];
2899 Lisp_Object property
= args
[1];
2900 Lisp_Object propval
= Fwidget_get (widget
, property
);
2901 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2902 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2906 #ifdef HAVE_LANGINFO_CODESET
2907 #include <langinfo.h>
2910 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2911 doc
: /* Access locale data ITEM for the current C locale, if available.
2912 ITEM should be one of the following:
2914 `codeset', returning the character set as a string (locale item CODESET);
2916 `days', returning a 7-element vector of day names (locale items DAY_n);
2918 `months', returning a 12-element vector of month names (locale items MON_n);
2920 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2921 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2923 If the system can't provide such information through a call to
2924 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2926 See also Info node `(libc)Locales'.
2928 The data read from the system are decoded using `locale-coding-system'. */)
2932 #ifdef HAVE_LANGINFO_CODESET
2933 if (EQ (item
, Qcodeset
))
2935 str
= nl_langinfo (CODESET
);
2936 return build_string (str
);
2939 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2941 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2942 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2944 synchronize_system_time_locale ();
2945 for (i
= 0; i
< 7; i
++)
2947 str
= nl_langinfo (days
[i
]);
2948 AUTO_STRING (val
, str
);
2949 /* Fixme: Is this coding system necessarily right, even if
2950 it is consistent with CODESET? If not, what to do? */
2951 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2958 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2960 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2961 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2962 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2964 synchronize_system_time_locale ();
2965 for (i
= 0; i
< 12; i
++)
2967 str
= nl_langinfo (months
[i
]);
2968 AUTO_STRING (val
, str
);
2969 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2975 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2976 but is in the locale files. This could be used by ps-print. */
2978 else if (EQ (item
, Qpaper
))
2979 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2980 #endif /* PAPER_WIDTH */
2981 #endif /* HAVE_LANGINFO_CODESET*/
2985 /* base64 encode/decode functions (RFC 2045).
2986 Based on code from GNU recode. */
2988 #define MIME_LINE_LENGTH 76
2990 #define IS_ASCII(Character) \
2992 #define IS_BASE64(Character) \
2993 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2994 #define IS_BASE64_IGNORABLE(Character) \
2995 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2996 || (Character) == '\f' || (Character) == '\r')
2998 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2999 character or return retval if there are no characters left to
3001 #define READ_QUADRUPLET_BYTE(retval) \
3006 if (nchars_return) \
3007 *nchars_return = nchars; \
3012 while (IS_BASE64_IGNORABLE (c))
3014 /* Table of characters coding the 64 values. */
3015 static const char base64_value_to_char
[64] =
3017 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3018 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3019 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3020 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3021 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3022 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3023 '8', '9', '+', '/' /* 60-63 */
3026 /* Table of base64 values for first 128 characters. */
3027 static const short base64_char_to_value
[128] =
3029 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3030 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3031 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3032 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3033 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3034 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3035 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3036 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3037 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3038 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3039 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3040 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3041 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3044 /* The following diagram shows the logical steps by which three octets
3045 get transformed into four base64 characters.
3047 .--------. .--------. .--------.
3048 |aaaaaabb| |bbbbcccc| |ccdddddd|
3049 `--------' `--------' `--------'
3051 .--------+--------+--------+--------.
3052 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3053 `--------+--------+--------+--------'
3055 .--------+--------+--------+--------.
3056 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3057 `--------+--------+--------+--------'
3059 The octets are divided into 6 bit chunks, which are then encoded into
3060 base64 characters. */
3063 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3064 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3067 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3069 doc
: /* Base64-encode the region between BEG and END.
3070 Return the length of the encoded text.
3071 Optional third argument NO-LINE-BREAK means do not break long lines
3072 into shorter lines. */)
3073 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3076 ptrdiff_t allength
, length
;
3077 ptrdiff_t ibeg
, iend
, encoded_length
;
3078 ptrdiff_t old_pos
= PT
;
3081 validate_region (&beg
, &end
);
3083 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3084 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3085 move_gap_both (XFASTINT (beg
), ibeg
);
3087 /* We need to allocate enough room for encoding the text.
3088 We need 33 1/3% more space, plus a newline every 76
3089 characters, and then we round up. */
3090 length
= iend
- ibeg
;
3091 allength
= length
+ length
/3 + 1;
3092 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3094 encoded
= SAFE_ALLOCA (allength
);
3095 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3096 encoded
, length
, NILP (no_line_break
),
3097 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3098 if (encoded_length
> allength
)
3101 if (encoded_length
< 0)
3103 /* The encoding wasn't possible. */
3105 error ("Multibyte character in data for base64 encoding");
3108 /* Now we have encoded the region, so we insert the new contents
3109 and delete the old. (Insert first in order to preserve markers.) */
3110 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3111 insert (encoded
, encoded_length
);
3113 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3115 /* If point was outside of the region, restore it exactly; else just
3116 move to the beginning of the region. */
3117 if (old_pos
>= XFASTINT (end
))
3118 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3119 else if (old_pos
> XFASTINT (beg
))
3120 old_pos
= XFASTINT (beg
);
3123 /* We return the length of the encoded text. */
3124 return make_number (encoded_length
);
3127 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3129 doc
: /* Base64-encode STRING and return the result.
3130 Optional second argument NO-LINE-BREAK means do not break long lines
3131 into shorter lines. */)
3132 (Lisp_Object string
, Lisp_Object no_line_break
)
3134 ptrdiff_t allength
, length
, encoded_length
;
3136 Lisp_Object encoded_string
;
3139 CHECK_STRING (string
);
3141 /* We need to allocate enough room for encoding the text.
3142 We need 33 1/3% more space, plus a newline every 76
3143 characters, and then we round up. */
3144 length
= SBYTES (string
);
3145 allength
= length
+ length
/3 + 1;
3146 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3148 /* We need to allocate enough room for decoding the text. */
3149 encoded
= SAFE_ALLOCA (allength
);
3151 encoded_length
= base64_encode_1 (SSDATA (string
),
3152 encoded
, length
, NILP (no_line_break
),
3153 STRING_MULTIBYTE (string
));
3154 if (encoded_length
> allength
)
3157 if (encoded_length
< 0)
3159 /* The encoding wasn't possible. */
3160 error ("Multibyte character in data for base64 encoding");
3163 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3166 return encoded_string
;
3170 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3171 bool line_break
, bool multibyte
)
3184 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3185 if (CHAR_BYTE8_P (c
))
3186 c
= CHAR_TO_BYTE8 (c
);
3194 /* Wrap line every 76 characters. */
3198 if (counter
< MIME_LINE_LENGTH
/ 4)
3207 /* Process first byte of a triplet. */
3209 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3210 value
= (0x03 & c
) << 4;
3212 /* Process second byte of a triplet. */
3216 *e
++ = base64_value_to_char
[value
];
3224 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3225 if (CHAR_BYTE8_P (c
))
3226 c
= CHAR_TO_BYTE8 (c
);
3234 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3235 value
= (0x0f & c
) << 2;
3237 /* Process third byte of a triplet. */
3241 *e
++ = base64_value_to_char
[value
];
3248 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3249 if (CHAR_BYTE8_P (c
))
3250 c
= CHAR_TO_BYTE8 (c
);
3258 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3259 *e
++ = base64_value_to_char
[0x3f & c
];
3266 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3268 doc
: /* Base64-decode the region between BEG and END.
3269 Return the length of the decoded text.
3270 If the region can't be decoded, signal an error and don't modify the buffer. */)
3271 (Lisp_Object beg
, Lisp_Object end
)
3273 ptrdiff_t ibeg
, iend
, length
, allength
;
3275 ptrdiff_t old_pos
= PT
;
3276 ptrdiff_t decoded_length
;
3277 ptrdiff_t inserted_chars
;
3278 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3281 validate_region (&beg
, &end
);
3283 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3284 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3286 length
= iend
- ibeg
;
3288 /* We need to allocate enough room for decoding the text. If we are
3289 working on a multibyte buffer, each decoded code may occupy at
3291 allength
= multibyte
? length
* 2 : length
;
3292 decoded
= SAFE_ALLOCA (allength
);
3294 move_gap_both (XFASTINT (beg
), ibeg
);
3295 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3297 multibyte
, &inserted_chars
);
3298 if (decoded_length
> allength
)
3301 if (decoded_length
< 0)
3303 /* The decoding wasn't possible. */
3304 error ("Invalid base64 data");
3307 /* Now we have decoded the region, so we insert the new contents
3308 and delete the old. (Insert first in order to preserve markers.) */
3309 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3310 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3313 /* Delete the original text. */
3314 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3315 iend
+ decoded_length
, 1);
3317 /* If point was outside of the region, restore it exactly; else just
3318 move to the beginning of the region. */
3319 if (old_pos
>= XFASTINT (end
))
3320 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3321 else if (old_pos
> XFASTINT (beg
))
3322 old_pos
= XFASTINT (beg
);
3323 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3325 return make_number (inserted_chars
);
3328 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3330 doc
: /* Base64-decode STRING and return the result. */)
3331 (Lisp_Object string
)
3334 ptrdiff_t length
, decoded_length
;
3335 Lisp_Object decoded_string
;
3338 CHECK_STRING (string
);
3340 length
= SBYTES (string
);
3341 /* We need to allocate enough room for decoding the text. */
3342 decoded
= SAFE_ALLOCA (length
);
3344 /* The decoded result should be unibyte. */
3345 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3347 if (decoded_length
> length
)
3349 else if (decoded_length
>= 0)
3350 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3352 decoded_string
= Qnil
;
3355 if (!STRINGP (decoded_string
))
3356 error ("Invalid base64 data");
3358 return decoded_string
;
3361 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3362 MULTIBYTE, the decoded result should be in multibyte
3363 form. If NCHARS_RETURN is not NULL, store the number of produced
3364 characters in *NCHARS_RETURN. */
3367 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3368 bool multibyte
, ptrdiff_t *nchars_return
)
3370 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3373 unsigned long value
;
3374 ptrdiff_t nchars
= 0;
3378 /* Process first byte of a quadruplet. */
3380 READ_QUADRUPLET_BYTE (e
-to
);
3384 value
= base64_char_to_value
[c
] << 18;
3386 /* Process second byte of a quadruplet. */
3388 READ_QUADRUPLET_BYTE (-1);
3392 value
|= base64_char_to_value
[c
] << 12;
3394 c
= (unsigned char) (value
>> 16);
3395 if (multibyte
&& c
>= 128)
3396 e
+= BYTE8_STRING (c
, e
);
3401 /* Process third byte of a quadruplet. */
3403 READ_QUADRUPLET_BYTE (-1);
3407 READ_QUADRUPLET_BYTE (-1);
3416 value
|= base64_char_to_value
[c
] << 6;
3418 c
= (unsigned char) (0xff & value
>> 8);
3419 if (multibyte
&& c
>= 128)
3420 e
+= BYTE8_STRING (c
, e
);
3425 /* Process fourth byte of a quadruplet. */
3427 READ_QUADRUPLET_BYTE (-1);
3434 value
|= base64_char_to_value
[c
];
3436 c
= (unsigned char) (0xff & value
);
3437 if (multibyte
&& c
>= 128)
3438 e
+= BYTE8_STRING (c
, e
);
3447 /***********************************************************************
3449 ***** Hash Tables *****
3451 ***********************************************************************/
3453 /* Implemented by gerd@gnu.org. This hash table implementation was
3454 inspired by CMUCL hash tables. */
3458 1. For small tables, association lists are probably faster than
3459 hash tables because they have lower overhead.
3461 For uses of hash tables where the O(1) behavior of table
3462 operations is not a requirement, it might therefore be a good idea
3463 not to hash. Instead, we could just do a linear search in the
3464 key_and_value vector of the hash table. This could be done
3465 if a `:linear-search t' argument is given to make-hash-table. */
3468 /* The list of all weak hash tables. Don't staticpro this one. */
3470 static struct Lisp_Hash_Table
*weak_hash_tables
;
3473 /***********************************************************************
3475 ***********************************************************************/
3478 CHECK_HASH_TABLE (Lisp_Object x
)
3480 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3484 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3486 h
->key_and_value
= key_and_value
;
3489 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3494 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3496 gc_aset (h
->next
, idx
, make_number (val
));
3499 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3504 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3506 gc_aset (h
->hash
, idx
, val
);
3509 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3514 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3516 gc_aset (h
->index
, idx
, make_number (val
));
3519 /* If OBJ is a Lisp hash table, return a pointer to its struct
3520 Lisp_Hash_Table. Otherwise, signal an error. */
3522 static struct Lisp_Hash_Table
*
3523 check_hash_table (Lisp_Object obj
)
3525 CHECK_HASH_TABLE (obj
);
3526 return XHASH_TABLE (obj
);
3530 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3531 number. A number is "almost" a prime number if it is not divisible
3532 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3535 next_almost_prime (EMACS_INT n
)
3537 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3538 for (n
|= 1; ; n
+= 2)
3539 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3544 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3545 which USED[I] is non-zero. If found at index I in ARGS, set
3546 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3547 0. This function is used to extract a keyword/argument pair from
3548 a DEFUN parameter list. */
3551 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3555 for (i
= 1; i
< nargs
; i
++)
3556 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3567 /* Return a Lisp vector which has the same contents as VEC but has
3568 at least INCR_MIN more entries, where INCR_MIN is positive.
3569 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3570 than NITEMS_MAX. New entries in the resulting vector are
3574 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3576 struct Lisp_Vector
*v
;
3577 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3578 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3579 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3580 ? nitems_max
: C_language_max
);
3581 eassert (VECTORP (vec
));
3582 eassert (0 < incr_min
&& -1 <= nitems_max
);
3583 old_size
= ASIZE (vec
);
3584 incr_max
= n_max
- old_size
;
3585 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3586 if (incr_max
< incr
)
3587 memory_full (SIZE_MAX
);
3588 new_size
= old_size
+ incr
;
3589 v
= allocate_vector (new_size
);
3590 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3591 XSETVECTOR (vec
, v
);
3595 /* Likewise, except set new entries in the resulting vector to nil. */
3598 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3600 ptrdiff_t old_size
= ASIZE (vec
);
3601 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3602 ptrdiff_t new_size
= ASIZE (v
);
3603 memclear (XVECTOR (v
)->contents
+ old_size
,
3604 (new_size
- old_size
) * word_size
);
3609 /***********************************************************************
3611 ***********************************************************************/
3613 /* Return the index of the next entry in H following the one at IDX,
3617 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3619 return XINT (AREF (h
->next
, idx
));
3622 /* Return the index of the element in hash table H that is the start
3623 of the collision list at index IDX, or -1 if the list is empty. */
3626 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3628 return XINT (AREF (h
->index
, idx
));
3631 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3632 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3633 KEY2 are the same. */
3636 cmpfn_eql (struct hash_table_test
*ht
,
3640 return (FLOATP (key1
)
3642 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3646 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3647 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3648 KEY2 are the same. */
3651 cmpfn_equal (struct hash_table_test
*ht
,
3655 return !NILP (Fequal (key1
, key2
));
3659 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3660 HASH2 in hash table H using H->user_cmp_function. Value is true
3661 if KEY1 and KEY2 are the same. */
3664 cmpfn_user_defined (struct hash_table_test
*ht
,
3668 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3671 /* Value is a hash code for KEY for use in hash table H which uses
3672 `eq' to compare keys. The hash code returned is guaranteed to fit
3673 in a Lisp integer. */
3676 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3678 return XHASH (key
) ^ XTYPE (key
);
3681 /* Value is a hash code for KEY for use in hash table H which uses
3682 `equal' to compare keys. The hash code returned is guaranteed to fit
3683 in a Lisp integer. */
3686 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3688 return sxhash (key
, 0);
3691 /* Value is a hash code for KEY for use in hash table H which uses
3692 `eql' to compare keys. The hash code returned is guaranteed to fit
3693 in a Lisp integer. */
3696 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3698 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3701 /* Value is a hash code for KEY for use in hash table H which uses as
3702 user-defined function to compare keys. The hash code returned is
3703 guaranteed to fit in a Lisp integer. */
3706 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3708 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3709 return hashfn_eq (ht
, hash
);
3712 struct hash_table_test
const
3713 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3714 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3715 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3716 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3717 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3718 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3720 /* Allocate basically initialized hash table. */
3722 static struct Lisp_Hash_Table
*
3723 allocate_hash_table (void)
3725 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3726 count
, PVEC_HASH_TABLE
);
3729 /* An upper bound on the size of a hash table index. It must fit in
3730 ptrdiff_t and be a valid Emacs fixnum. */
3731 #define INDEX_SIZE_BOUND \
3732 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3734 /* Create and initialize a new hash table.
3736 TEST specifies the test the hash table will use to compare keys.
3737 It must be either one of the predefined tests `eq', `eql' or
3738 `equal' or a symbol denoting a user-defined test named TEST with
3739 test and hash functions USER_TEST and USER_HASH.
3741 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3743 If REHASH_SIZE is equal to a negative integer, this hash table's
3744 new size when it becomes full is computed by subtracting
3745 REHASH_SIZE from its old size. Otherwise it must be positive, and
3746 the table's new size is computed by multiplying its old size by
3749 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3750 be resized when the approximate ratio of table entries to table
3751 size exceeds REHASH_THRESHOLD.
3753 WEAK specifies the weakness of the table. If non-nil, it must be
3754 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3756 If PURECOPY is non-nil, the table can be copied to pure storage via
3757 `purecopy' when Emacs is being dumped. Such tables can no longer be
3758 changed after purecopy. */
3761 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
3762 float rehash_size
, float rehash_threshold
,
3763 Lisp_Object weak
, bool pure
)
3765 struct Lisp_Hash_Table
*h
;
3767 EMACS_INT index_size
;
3771 /* Preconditions. */
3772 eassert (SYMBOLP (test
.name
));
3773 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
3774 eassert (rehash_size
<= -1 || 0 < rehash_size
);
3775 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
3780 double threshold
= rehash_threshold
;
3781 index_float
= size
/ threshold
;
3782 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3783 ? next_almost_prime (index_float
)
3784 : INDEX_SIZE_BOUND
+ 1);
3785 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * size
))
3786 error ("Hash table too large");
3788 /* Allocate a table and initialize it. */
3789 h
= allocate_hash_table ();
3791 /* Initialize hash table slots. */
3794 h
->rehash_threshold
= rehash_threshold
;
3795 h
->rehash_size
= rehash_size
;
3797 h
->key_and_value
= Fmake_vector (make_number (2 * size
), Qnil
);
3798 h
->hash
= Fmake_vector (make_number (size
), Qnil
);
3799 h
->next
= Fmake_vector (make_number (size
), make_number (-1));
3800 h
->index
= Fmake_vector (make_number (index_size
), make_number (-1));
3803 /* Set up the free list. */
3804 for (i
= 0; i
< size
- 1; ++i
)
3805 set_hash_next_slot (h
, i
, i
+ 1);
3808 XSET_HASH_TABLE (table
, h
);
3809 eassert (HASH_TABLE_P (table
));
3810 eassert (XHASH_TABLE (table
) == h
);
3812 /* Maybe add this hash table to the list of all weak hash tables. */
3815 h
->next_weak
= weak_hash_tables
;
3816 weak_hash_tables
= h
;
3823 /* Return a copy of hash table H1. Keys and values are not copied,
3824 only the table itself is. */
3827 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3830 struct Lisp_Hash_Table
*h2
;
3832 h2
= allocate_hash_table ();
3834 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3835 h2
->hash
= Fcopy_sequence (h1
->hash
);
3836 h2
->next
= Fcopy_sequence (h1
->next
);
3837 h2
->index
= Fcopy_sequence (h1
->index
);
3838 XSET_HASH_TABLE (table
, h2
);
3840 /* Maybe add this hash table to the list of all weak hash tables. */
3841 if (!NILP (h2
->weak
))
3843 h2
->next_weak
= h1
->next_weak
;
3851 /* Resize hash table H if it's too full. If H cannot be resized
3852 because it's already too large, throw an error. */
3855 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3857 if (h
->next_free
< 0)
3859 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3860 EMACS_INT new_size
, index_size
, nsize
;
3862 double rehash_size
= h
->rehash_size
;
3865 if (rehash_size
< 0)
3866 new_size
= old_size
- rehash_size
;
3869 double float_new_size
= old_size
* (rehash_size
+ 1);
3870 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3871 new_size
= float_new_size
;
3873 new_size
= INDEX_SIZE_BOUND
+ 1;
3875 if (new_size
<= old_size
)
3876 new_size
= old_size
+ 1;
3877 double threshold
= h
->rehash_threshold
;
3878 index_float
= new_size
/ threshold
;
3879 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3880 ? next_almost_prime (index_float
)
3881 : INDEX_SIZE_BOUND
+ 1);
3882 nsize
= max (index_size
, 2 * new_size
);
3883 if (INDEX_SIZE_BOUND
< nsize
)
3884 error ("Hash table too large to resize");
3886 #ifdef ENABLE_CHECKING
3887 if (HASH_TABLE_P (Vpurify_flag
)
3888 && XHASH_TABLE (Vpurify_flag
) == h
)
3889 message ("Growing hash table to: %"pI
"d", new_size
);
3892 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3893 2 * (new_size
- old_size
), -1));
3894 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3895 set_hash_index (h
, Fmake_vector (make_number (index_size
),
3897 set_hash_next (h
, larger_vecalloc (h
->next
, new_size
- old_size
, -1));
3899 /* Update the free list. Do it so that new entries are added at
3900 the end of the free list. This makes some operations like
3902 for (i
= old_size
; i
< new_size
- 1; ++i
)
3903 set_hash_next_slot (h
, i
, i
+ 1);
3904 set_hash_next_slot (h
, i
, -1);
3906 if (h
->next_free
< 0)
3907 h
->next_free
= old_size
;
3910 ptrdiff_t last
= h
->next_free
;
3913 ptrdiff_t next
= HASH_NEXT (h
, last
);
3918 set_hash_next_slot (h
, last
, old_size
);
3922 for (i
= 0; i
< old_size
; ++i
)
3923 if (!NILP (HASH_HASH (h
, i
)))
3925 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3926 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3927 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3928 set_hash_index_slot (h
, start_of_bucket
, i
);
3934 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3935 the hash code of KEY. Value is the index of the entry in H
3936 matching KEY, or -1 if not found. */
3939 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3941 EMACS_UINT hash_code
;
3942 ptrdiff_t start_of_bucket
, i
;
3944 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3945 eassert ((hash_code
& ~INTMASK
) == 0);
3949 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3951 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
3952 if (EQ (key
, HASH_KEY (h
, i
))
3954 && hash_code
== XUINT (HASH_HASH (h
, i
))
3955 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3962 /* Put an entry into hash table H that associates KEY with VALUE.
3963 HASH is a previously computed hash code of KEY.
3964 Value is the index of the entry in H matching KEY. */
3967 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3970 ptrdiff_t start_of_bucket
, i
;
3972 eassert ((hash
& ~INTMASK
) == 0);
3974 /* Increment count after resizing because resizing may fail. */
3975 maybe_resize_hash_table (h
);
3978 /* Store key/value in the key_and_value vector. */
3980 h
->next_free
= HASH_NEXT (h
, i
);
3981 set_hash_key_slot (h
, i
, key
);
3982 set_hash_value_slot (h
, i
, value
);
3984 /* Remember its hash code. */
3985 set_hash_hash_slot (h
, i
, make_number (hash
));
3987 /* Add new entry to its collision chain. */
3988 start_of_bucket
= hash
% ASIZE (h
->index
);
3989 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3990 set_hash_index_slot (h
, start_of_bucket
, i
);
3995 /* Remove the entry matching KEY from hash table H, if there is one. */
3998 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4000 EMACS_UINT hash_code
= h
->test
.hashfn (&h
->test
, key
);
4001 eassert ((hash_code
& ~INTMASK
) == 0);
4002 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4003 ptrdiff_t prev
= -1;
4005 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4007 i
= HASH_NEXT (h
, i
))
4009 if (EQ (key
, HASH_KEY (h
, i
))
4011 && hash_code
== XUINT (HASH_HASH (h
, i
))
4012 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4014 /* Take entry out of collision chain. */
4016 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4018 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4020 /* Clear slots in key_and_value and add the slots to
4022 set_hash_key_slot (h
, i
, Qnil
);
4023 set_hash_value_slot (h
, i
, Qnil
);
4024 set_hash_hash_slot (h
, i
, Qnil
);
4025 set_hash_next_slot (h
, i
, h
->next_free
);
4028 eassert (h
->count
>= 0);
4037 /* Clear hash table H. */
4040 hash_clear (struct Lisp_Hash_Table
*h
)
4044 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4046 for (i
= 0; i
< size
; ++i
)
4048 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4049 set_hash_key_slot (h
, i
, Qnil
);
4050 set_hash_value_slot (h
, i
, Qnil
);
4051 set_hash_hash_slot (h
, i
, Qnil
);
4054 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4055 ASET (h
->index
, i
, make_number (-1));
4064 /************************************************************************
4066 ************************************************************************/
4068 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4069 entries from the table that don't survive the current GC.
4070 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4071 true if anything was marked. */
4074 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4076 ptrdiff_t n
= gc_asize (h
->index
);
4077 bool marked
= false;
4079 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4081 /* Follow collision chain, removing entries that
4082 don't survive this garbage collection. */
4083 ptrdiff_t prev
= -1;
4085 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4087 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4088 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4091 if (EQ (h
->weak
, Qkey
))
4092 remove_p
= !key_known_to_survive_p
;
4093 else if (EQ (h
->weak
, Qvalue
))
4094 remove_p
= !value_known_to_survive_p
;
4095 else if (EQ (h
->weak
, Qkey_or_value
))
4096 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4097 else if (EQ (h
->weak
, Qkey_and_value
))
4098 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4102 next
= HASH_NEXT (h
, i
);
4104 if (remove_entries_p
)
4108 /* Take out of collision chain. */
4110 set_hash_index_slot (h
, bucket
, next
);
4112 set_hash_next_slot (h
, prev
, next
);
4114 /* Add to free list. */
4115 set_hash_next_slot (h
, i
, h
->next_free
);
4118 /* Clear key, value, and hash. */
4119 set_hash_key_slot (h
, i
, Qnil
);
4120 set_hash_value_slot (h
, i
, Qnil
);
4121 set_hash_hash_slot (h
, i
, Qnil
);
4134 /* Make sure key and value survive. */
4135 if (!key_known_to_survive_p
)
4137 mark_object (HASH_KEY (h
, i
));
4141 if (!value_known_to_survive_p
)
4143 mark_object (HASH_VALUE (h
, i
));
4154 /* Remove elements from weak hash tables that don't survive the
4155 current garbage collection. Remove weak tables that don't survive
4156 from Vweak_hash_tables. Called from gc_sweep. */
4158 NO_INLINE
/* For better stack traces */
4160 sweep_weak_hash_tables (void)
4162 struct Lisp_Hash_Table
*h
, *used
, *next
;
4165 /* Mark all keys and values that are in use. Keep on marking until
4166 there is no more change. This is necessary for cases like
4167 value-weak table A containing an entry X -> Y, where Y is used in a
4168 key-weak table B, Z -> Y. If B comes after A in the list of weak
4169 tables, X -> Y might be removed from A, although when looking at B
4170 one finds that it shouldn't. */
4174 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4176 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4177 marked
|= sweep_weak_table (h
, 0);
4182 /* Remove tables and entries that aren't used. */
4183 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4185 next
= h
->next_weak
;
4187 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4189 /* TABLE is marked as used. Sweep its contents. */
4191 sweep_weak_table (h
, 1);
4193 /* Add table to the list of used weak hash tables. */
4194 h
->next_weak
= used
;
4199 weak_hash_tables
= used
;
4204 /***********************************************************************
4205 Hash Code Computation
4206 ***********************************************************************/
4208 /* Maximum depth up to which to dive into Lisp structures. */
4210 #define SXHASH_MAX_DEPTH 3
4212 /* Maximum length up to which to take list and vector elements into
4215 #define SXHASH_MAX_LEN 7
4217 /* Return a hash for string PTR which has length LEN. The hash value
4218 can be any EMACS_UINT value. */
4221 hash_string (char const *ptr
, ptrdiff_t len
)
4223 char const *p
= ptr
;
4224 char const *end
= p
+ len
;
4226 EMACS_UINT hash
= 0;
4231 hash
= sxhash_combine (hash
, c
);
4237 /* Return a hash for string PTR which has length LEN. The hash
4238 code returned is guaranteed to fit in a Lisp integer. */
4241 sxhash_string (char const *ptr
, ptrdiff_t len
)
4243 EMACS_UINT hash
= hash_string (ptr
, len
);
4244 return SXHASH_REDUCE (hash
);
4247 /* Return a hash for the floating point value VAL. */
4250 sxhash_float (double val
)
4252 EMACS_UINT hash
= 0;
4254 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4255 + (sizeof val
% sizeof hash
!= 0))
4259 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4263 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4264 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4265 hash
= sxhash_combine (hash
, u
.word
[i
]);
4266 return SXHASH_REDUCE (hash
);
4269 /* Return a hash for list LIST. DEPTH is the current depth in the
4270 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4273 sxhash_list (Lisp_Object list
, int depth
)
4275 EMACS_UINT hash
= 0;
4278 if (depth
< SXHASH_MAX_DEPTH
)
4280 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4281 list
= XCDR (list
), ++i
)
4283 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4284 hash
= sxhash_combine (hash
, hash2
);
4289 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4290 hash
= sxhash_combine (hash
, hash2
);
4293 return SXHASH_REDUCE (hash
);
4297 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4298 the Lisp structure. */
4301 sxhash_vector (Lisp_Object vec
, int depth
)
4303 EMACS_UINT hash
= ASIZE (vec
);
4306 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4307 for (i
= 0; i
< n
; ++i
)
4309 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4310 hash
= sxhash_combine (hash
, hash2
);
4313 return SXHASH_REDUCE (hash
);
4316 /* Return a hash for bool-vector VECTOR. */
4319 sxhash_bool_vector (Lisp_Object vec
)
4321 EMACS_INT size
= bool_vector_size (vec
);
4322 EMACS_UINT hash
= size
;
4325 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4326 for (i
= 0; i
< n
; ++i
)
4327 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4329 return SXHASH_REDUCE (hash
);
4333 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4334 structure. Value is an unsigned integer clipped to INTMASK. */
4337 sxhash (Lisp_Object obj
, int depth
)
4341 if (depth
> SXHASH_MAX_DEPTH
)
4344 switch (XTYPE (obj
))
4356 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4359 /* This can be everything from a vector to an overlay. */
4360 case Lisp_Vectorlike
:
4361 if (VECTORP (obj
) || RECORDP (obj
))
4362 /* According to the CL HyperSpec, two arrays are equal only if
4363 they are `eq', except for strings and bit-vectors. In
4364 Emacs, this works differently. We have to compare element
4365 by element. Same for records. */
4366 hash
= sxhash_vector (obj
, depth
);
4367 else if (BOOL_VECTOR_P (obj
))
4368 hash
= sxhash_bool_vector (obj
);
4370 /* Others are `equal' if they are `eq', so let's take their
4376 hash
= sxhash_list (obj
, depth
);
4380 hash
= sxhash_float (XFLOAT_DATA (obj
));
4392 /***********************************************************************
4394 ***********************************************************************/
4396 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4397 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4398 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4401 return make_number (hashfn_eq (NULL
, obj
));
4404 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4405 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4406 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4409 return make_number (hashfn_eql (NULL
, obj
));
4412 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4413 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4414 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4417 return make_number (hashfn_equal (NULL
, obj
));
4420 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4421 doc
: /* Create and return a new hash table.
4423 Arguments are specified as keyword/argument pairs. The following
4424 arguments are defined:
4426 :test TEST -- TEST must be a symbol that specifies how to compare
4427 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4428 `equal'. User-supplied test and hash functions can be specified via
4429 `define-hash-table-test'.
4431 :size SIZE -- A hint as to how many elements will be put in the table.
4434 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4435 fills up. If REHASH-SIZE is an integer, increase the size by that
4436 amount. If it is a float, it must be > 1.0, and the new size is the
4437 old size multiplied by that factor. Default is 1.5.
4439 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4440 Resize the hash table when the ratio (table entries / table size)
4441 exceeds an approximation to THRESHOLD. Default is 0.8125.
4443 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4444 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4445 returned is a weak table. Key/value pairs are removed from a weak
4446 hash table when there are no non-weak references pointing to their
4447 key, value, one of key or value, or both key and value, depending on
4448 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4451 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4452 to pure storage when Emacs is being dumped, making the contents of the
4453 table read only. Any further changes to purified tables will result
4456 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4457 (ptrdiff_t nargs
, Lisp_Object
*args
)
4459 Lisp_Object test
, weak
;
4461 struct hash_table_test testdesc
;
4465 /* The vector `used' is used to keep track of arguments that
4466 have been consumed. */
4467 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4468 memset (used
, 0, nargs
* sizeof *used
);
4470 /* See if there's a `:test TEST' among the arguments. */
4471 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4472 test
= i
? args
[i
] : Qeql
;
4474 testdesc
= hashtest_eq
;
4475 else if (EQ (test
, Qeql
))
4476 testdesc
= hashtest_eql
;
4477 else if (EQ (test
, Qequal
))
4478 testdesc
= hashtest_equal
;
4481 /* See if it is a user-defined test. */
4484 prop
= Fget (test
, Qhash_table_test
);
4485 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4486 signal_error ("Invalid hash table test", test
);
4487 testdesc
.name
= test
;
4488 testdesc
.user_cmp_function
= XCAR (prop
);
4489 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4490 testdesc
.hashfn
= hashfn_user_defined
;
4491 testdesc
.cmpfn
= cmpfn_user_defined
;
4494 /* See if there's a `:purecopy PURECOPY' argument. */
4495 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4496 pure
= i
&& !NILP (args
[i
]);
4497 /* See if there's a `:size SIZE' argument. */
4498 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4499 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4501 if (NILP (size_arg
))
4502 size
= DEFAULT_HASH_SIZE
;
4503 else if (NATNUMP (size_arg
))
4504 size
= XFASTINT (size_arg
);
4506 signal_error ("Invalid hash table size", size_arg
);
4508 /* Look for `:rehash-size SIZE'. */
4510 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4512 rehash_size
= DEFAULT_REHASH_SIZE
;
4513 else if (INTEGERP (args
[i
]) && 0 < XINT (args
[i
]))
4514 rehash_size
= - XINT (args
[i
]);
4515 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4516 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4518 signal_error ("Invalid hash table rehash size", args
[i
]);
4520 /* Look for `:rehash-threshold THRESHOLD'. */
4521 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4522 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4523 : !FLOATP (args
[i
]) ? 0
4524 : (float) XFLOAT_DATA (args
[i
]));
4525 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4526 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4528 /* Look for `:weakness WEAK'. */
4529 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4530 weak
= i
? args
[i
] : Qnil
;
4532 weak
= Qkey_and_value
;
4535 && !EQ (weak
, Qvalue
)
4536 && !EQ (weak
, Qkey_or_value
)
4537 && !EQ (weak
, Qkey_and_value
))
4538 signal_error ("Invalid hash table weakness", weak
);
4540 /* Now, all args should have been used up, or there's a problem. */
4541 for (i
= 0; i
< nargs
; ++i
)
4543 signal_error ("Invalid argument list", args
[i
]);
4546 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4551 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4552 doc
: /* Return a copy of hash table TABLE. */)
4555 return copy_hash_table (check_hash_table (table
));
4559 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4560 doc
: /* Return the number of elements in TABLE. */)
4563 return make_number (check_hash_table (table
)->count
);
4567 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4568 Shash_table_rehash_size
, 1, 1, 0,
4569 doc
: /* Return the current rehash size of TABLE. */)
4572 double rehash_size
= check_hash_table (table
)->rehash_size
;
4573 if (rehash_size
< 0)
4575 EMACS_INT s
= -rehash_size
;
4576 return make_number (min (s
, MOST_POSITIVE_FIXNUM
));
4579 return make_float (rehash_size
+ 1);
4583 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4584 Shash_table_rehash_threshold
, 1, 1, 0,
4585 doc
: /* Return the current rehash threshold of TABLE. */)
4588 return make_float (check_hash_table (table
)->rehash_threshold
);
4592 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4593 doc
: /* Return the size of TABLE.
4594 The size can be used as an argument to `make-hash-table' to create
4595 a hash table than can hold as many elements as TABLE holds
4596 without need for resizing. */)
4599 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4600 return make_number (HASH_TABLE_SIZE (h
));
4604 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4605 doc
: /* Return the test TABLE uses. */)
4608 return check_hash_table (table
)->test
.name
;
4612 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4614 doc
: /* Return the weakness of TABLE. */)
4617 return check_hash_table (table
)->weak
;
4621 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4622 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4625 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4629 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4630 doc
: /* Clear hash table TABLE and return it. */)
4633 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4634 CHECK_IMPURE (table
, h
);
4636 /* Be compatible with XEmacs. */
4641 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4642 doc
: /* Look up KEY in TABLE and return its associated value.
4643 If KEY is not found, return DFLT which defaults to nil. */)
4644 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4646 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4647 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4648 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4652 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4653 doc
: /* Associate KEY with VALUE in hash table TABLE.
4654 If KEY is already present in table, replace its current value with
4655 VALUE. In any case, return VALUE. */)
4656 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4658 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4659 CHECK_IMPURE (table
, h
);
4663 i
= hash_lookup (h
, key
, &hash
);
4665 set_hash_value_slot (h
, i
, value
);
4667 hash_put (h
, key
, value
, hash
);
4673 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4674 doc
: /* Remove KEY from TABLE. */)
4675 (Lisp_Object key
, Lisp_Object table
)
4677 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4678 CHECK_IMPURE (table
, h
);
4679 hash_remove_from_table (h
, key
);
4684 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4685 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4686 FUNCTION is called with two arguments, KEY and VALUE.
4687 `maphash' always returns nil. */)
4688 (Lisp_Object function
, Lisp_Object table
)
4690 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4692 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4693 if (!NILP (HASH_HASH (h
, i
)))
4694 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4700 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4701 Sdefine_hash_table_test
, 3, 3, 0,
4702 doc
: /* Define a new hash table test with name NAME, a symbol.
4704 In hash tables created with NAME specified as test, use TEST to
4705 compare keys, and HASH for computing hash codes of keys.
4707 TEST must be a function taking two arguments and returning non-nil if
4708 both arguments are the same. HASH must be a function taking one
4709 argument and returning an object that is the hash code of the argument.
4710 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4711 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4712 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4714 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4719 /************************************************************************
4720 MD5, SHA-1, and SHA-2
4721 ************************************************************************/
4729 make_digest_string (Lisp_Object digest
, int digest_size
)
4731 unsigned char *p
= SDATA (digest
);
4733 for (int i
= digest_size
- 1; i
>= 0; i
--)
4735 static char const hexdigit
[16] = "0123456789abcdef";
4737 p
[2 * i
] = hexdigit
[p_i
>> 4];
4738 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4743 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4746 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4747 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4750 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4751 register EMACS_INT b
, e
;
4752 register struct buffer
*bp
;
4755 void *(*hash_func
) (const char *, size_t, void *);
4758 CHECK_SYMBOL (algorithm
);
4760 if (STRINGP (object
))
4762 if (NILP (coding_system
))
4764 /* Decide the coding-system to encode the data with. */
4766 if (STRING_MULTIBYTE (object
))
4767 /* use default, we can't guess correct value */
4768 coding_system
= preferred_coding_system ();
4770 coding_system
= Qraw_text
;
4773 if (NILP (Fcoding_system_p (coding_system
)))
4775 /* Invalid coding system. */
4777 if (!NILP (noerror
))
4778 coding_system
= Qraw_text
;
4780 xsignal1 (Qcoding_system_error
, coding_system
);
4783 if (STRING_MULTIBYTE (object
))
4784 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4786 size
= SCHARS (object
);
4787 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4789 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4790 end_byte
= (end_char
== size
4792 : string_char_to_byte (object
, end_char
));
4796 struct buffer
*prev
= current_buffer
;
4798 record_unwind_current_buffer ();
4800 CHECK_BUFFER (object
);
4802 bp
= XBUFFER (object
);
4803 set_buffer_internal (bp
);
4809 CHECK_NUMBER_COERCE_MARKER (start
);
4817 CHECK_NUMBER_COERCE_MARKER (end
);
4822 temp
= b
, b
= e
, e
= temp
;
4824 if (!(BEGV
<= b
&& e
<= ZV
))
4825 args_out_of_range (start
, end
);
4827 if (NILP (coding_system
))
4829 /* Decide the coding-system to encode the data with.
4830 See fileio.c:Fwrite-region */
4832 if (!NILP (Vcoding_system_for_write
))
4833 coding_system
= Vcoding_system_for_write
;
4836 bool force_raw_text
= 0;
4838 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4839 if (NILP (coding_system
)
4840 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4842 coding_system
= Qnil
;
4843 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4847 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4849 /* Check file-coding-system-alist. */
4850 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4851 Qwrite_region
, start
, end
,
4852 Fbuffer_file_name (object
));
4853 if (CONSP (val
) && !NILP (XCDR (val
)))
4854 coding_system
= XCDR (val
);
4857 if (NILP (coding_system
)
4858 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4860 /* If we still have not decided a coding system, use the
4861 default value of buffer-file-coding-system. */
4862 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4866 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4867 /* Confirm that VAL can surely encode the current region. */
4868 coding_system
= call4 (Vselect_safe_coding_system_function
,
4869 make_number (b
), make_number (e
),
4870 coding_system
, Qnil
);
4873 coding_system
= Qraw_text
;
4876 if (NILP (Fcoding_system_p (coding_system
)))
4878 /* Invalid coding system. */
4880 if (!NILP (noerror
))
4881 coding_system
= Qraw_text
;
4883 xsignal1 (Qcoding_system_error
, coding_system
);
4887 object
= make_buffer_string (b
, e
, 0);
4888 set_buffer_internal (prev
);
4889 /* Discard the unwind protect for recovering the current
4893 if (STRING_MULTIBYTE (object
))
4894 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4896 end_byte
= SBYTES (object
);
4899 if (EQ (algorithm
, Qmd5
))
4901 digest_size
= MD5_DIGEST_SIZE
;
4902 hash_func
= md5_buffer
;
4904 else if (EQ (algorithm
, Qsha1
))
4906 digest_size
= SHA1_DIGEST_SIZE
;
4907 hash_func
= sha1_buffer
;
4909 else if (EQ (algorithm
, Qsha224
))
4911 digest_size
= SHA224_DIGEST_SIZE
;
4912 hash_func
= sha224_buffer
;
4914 else if (EQ (algorithm
, Qsha256
))
4916 digest_size
= SHA256_DIGEST_SIZE
;
4917 hash_func
= sha256_buffer
;
4919 else if (EQ (algorithm
, Qsha384
))
4921 digest_size
= SHA384_DIGEST_SIZE
;
4922 hash_func
= sha384_buffer
;
4924 else if (EQ (algorithm
, Qsha512
))
4926 digest_size
= SHA512_DIGEST_SIZE
;
4927 hash_func
= sha512_buffer
;
4930 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4932 /* allocate 2 x digest_size so that it can be re-used to hold the
4934 digest
= make_uninit_string (digest_size
* 2);
4936 hash_func (SSDATA (object
) + start_byte
,
4937 end_byte
- start_byte
,
4941 return make_digest_string (digest
, digest_size
);
4943 return make_unibyte_string (SSDATA (digest
), digest_size
);
4946 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4947 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4949 A message digest is a cryptographic checksum of a document, and the
4950 algorithm to calculate it is defined in RFC 1321.
4952 The two optional arguments START and END are character positions
4953 specifying for which part of OBJECT the message digest should be
4954 computed. If nil or omitted, the digest is computed for the whole
4957 The MD5 message digest is computed from the result of encoding the
4958 text in a coding system, not directly from the internal Emacs form of
4959 the text. The optional fourth argument CODING-SYSTEM specifies which
4960 coding system to encode the text with. It should be the same coding
4961 system that you used or will use when actually writing the text into a
4964 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4965 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4966 system would be chosen by default for writing this text into a file.
4968 If OBJECT is a string, the most preferred coding system (see the
4969 command `prefer-coding-system') is used.
4971 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4972 guesswork fails. Normally, an error is signaled in such case. */)
4973 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4975 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4978 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4979 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4980 ALGORITHM is a symbol specifying the hash to use:
4981 md5, sha1, sha224, sha256, sha384 or sha512.
4983 The two optional arguments START and END are positions specifying for
4984 which part of OBJECT to compute the hash. If nil or omitted, uses the
4987 If BINARY is non-nil, returns a string in binary form. */)
4988 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4990 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4993 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
4994 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
4995 This hash is performed on the raw internal format of the buffer,
4996 disregarding any coding systems. If nil, use the current buffer. */ )
4997 (Lisp_Object buffer_or_name
)
5001 struct sha1_ctx ctx
;
5003 if (NILP (buffer_or_name
))
5004 buffer
= Fcurrent_buffer ();
5006 buffer
= Fget_buffer (buffer_or_name
);
5008 nsberror (buffer_or_name
);
5010 b
= XBUFFER (buffer
);
5011 sha1_init_ctx (&ctx
);
5013 /* Process the first part of the buffer. */
5014 sha1_process_bytes (BUF_BEG_ADDR (b
),
5015 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5018 /* If the gap is before the end of the buffer, process the last half
5020 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5021 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5022 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5025 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5026 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5027 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5034 DEFSYM (Qmd5
, "md5");
5035 DEFSYM (Qsha1
, "sha1");
5036 DEFSYM (Qsha224
, "sha224");
5037 DEFSYM (Qsha256
, "sha256");
5038 DEFSYM (Qsha384
, "sha384");
5039 DEFSYM (Qsha512
, "sha512");
5041 /* Hash table stuff. */
5042 DEFSYM (Qhash_table_p
, "hash-table-p");
5044 DEFSYM (Qeql
, "eql");
5045 DEFSYM (Qequal
, "equal");
5046 DEFSYM (QCtest
, ":test");
5047 DEFSYM (QCsize
, ":size");
5048 DEFSYM (QCpurecopy
, ":purecopy");
5049 DEFSYM (QCrehash_size
, ":rehash-size");
5050 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5051 DEFSYM (QCweakness
, ":weakness");
5052 DEFSYM (Qkey
, "key");
5053 DEFSYM (Qvalue
, "value");
5054 DEFSYM (Qhash_table_test
, "hash-table-test");
5055 DEFSYM (Qkey_or_value
, "key-or-value");
5056 DEFSYM (Qkey_and_value
, "key-and-value");
5058 defsubr (&Ssxhash_eq
);
5059 defsubr (&Ssxhash_eql
);
5060 defsubr (&Ssxhash_equal
);
5061 defsubr (&Smake_hash_table
);
5062 defsubr (&Scopy_hash_table
);
5063 defsubr (&Shash_table_count
);
5064 defsubr (&Shash_table_rehash_size
);
5065 defsubr (&Shash_table_rehash_threshold
);
5066 defsubr (&Shash_table_size
);
5067 defsubr (&Shash_table_test
);
5068 defsubr (&Shash_table_weakness
);
5069 defsubr (&Shash_table_p
);
5070 defsubr (&Sclrhash
);
5071 defsubr (&Sgethash
);
5072 defsubr (&Sputhash
);
5073 defsubr (&Sremhash
);
5074 defsubr (&Smaphash
);
5075 defsubr (&Sdefine_hash_table_test
);
5077 DEFSYM (Qstring_lessp
, "string-lessp");
5078 DEFSYM (Qprovide
, "provide");
5079 DEFSYM (Qrequire
, "require");
5080 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5081 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5082 DEFSYM (Qwidget_type
, "widget-type");
5084 staticpro (&string_char_byte_cache_string
);
5085 string_char_byte_cache_string
= Qnil
;
5087 require_nesting_list
= Qnil
;
5088 staticpro (&require_nesting_list
);
5090 Fset (Qyes_or_no_p_history
, Qnil
);
5092 DEFVAR_LISP ("features", Vfeatures
,
5093 doc
: /* A list of symbols which are the features of the executing Emacs.
5094 Used by `featurep' and `require', and altered by `provide'. */);
5095 Vfeatures
= list1 (Qemacs
);
5096 DEFSYM (Qfeatures
, "features");
5097 /* Let people use lexically scoped vars named `features'. */
5098 Fmake_var_non_special (Qfeatures
);
5099 DEFSYM (Qsubfeatures
, "subfeatures");
5100 DEFSYM (Qfuncall
, "funcall");
5102 #ifdef HAVE_LANGINFO_CODESET
5103 DEFSYM (Qcodeset
, "codeset");
5104 DEFSYM (Qdays
, "days");
5105 DEFSYM (Qmonths
, "months");
5106 DEFSYM (Qpaper
, "paper");
5107 #endif /* HAVE_LANGINFO_CODESET */
5109 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5110 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5111 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5112 invoked by mouse clicks and mouse menu items.
5114 On some platforms, file selection dialogs are also enabled if this is
5118 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5119 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5120 This applies to commands from menus and tool bar buttons even when
5121 they are initiated from the keyboard. If `use-dialog-box' is nil,
5122 that disables the use of a file dialog, regardless of the value of
5124 use_file_dialog
= 1;
5126 defsubr (&Sidentity
);
5129 defsubr (&Ssafe_length
);
5130 defsubr (&Sstring_bytes
);
5131 defsubr (&Sstring_equal
);
5132 defsubr (&Scompare_strings
);
5133 defsubr (&Sstring_lessp
);
5134 defsubr (&Sstring_version_lessp
);
5135 defsubr (&Sstring_collate_lessp
);
5136 defsubr (&Sstring_collate_equalp
);
5139 defsubr (&Svconcat
);
5140 defsubr (&Scopy_sequence
);
5141 defsubr (&Sstring_make_multibyte
);
5142 defsubr (&Sstring_make_unibyte
);
5143 defsubr (&Sstring_as_multibyte
);
5144 defsubr (&Sstring_as_unibyte
);
5145 defsubr (&Sstring_to_multibyte
);
5146 defsubr (&Sstring_to_unibyte
);
5147 defsubr (&Scopy_alist
);
5148 defsubr (&Ssubstring
);
5149 defsubr (&Ssubstring_no_properties
);
5162 defsubr (&Snreverse
);
5163 defsubr (&Sreverse
);
5165 defsubr (&Splist_get
);
5167 defsubr (&Splist_put
);
5169 defsubr (&Slax_plist_get
);
5170 defsubr (&Slax_plist_put
);
5173 defsubr (&Sequal_including_properties
);
5174 defsubr (&Sfillarray
);
5175 defsubr (&Sclear_string
);
5180 defsubr (&Smapconcat
);
5181 defsubr (&Syes_or_no_p
);
5182 defsubr (&Sload_average
);
5183 defsubr (&Sfeaturep
);
5184 defsubr (&Srequire
);
5185 defsubr (&Sprovide
);
5186 defsubr (&Splist_member
);
5187 defsubr (&Swidget_put
);
5188 defsubr (&Swidget_get
);
5189 defsubr (&Swidget_apply
);
5190 defsubr (&Sbase64_encode_region
);
5191 defsubr (&Sbase64_decode_region
);
5192 defsubr (&Sbase64_encode_string
);
5193 defsubr (&Sbase64_decode_string
);
5195 defsubr (&Ssecure_hash
);
5196 defsubr (&Sbuffer_hash
);
5197 defsubr (&Slocale_info
);