1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2019 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 <https://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
40 #if defined WINDOWSNT && defined HAVE_GNUTLS3
41 # define gnutls_rnd w32_gnutls_rnd
44 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
45 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
46 enum equal_kind
{ EQUAL_NO_QUIT
, EQUAL_PLAIN
, EQUAL_INCLUDING_PROPERTIES
};
47 static bool internal_equal (Lisp_Object
, Lisp_Object
,
48 enum equal_kind
, int, Lisp_Object
);
50 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
51 doc
: /* Return the argument unchanged. */
58 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
59 doc
: /* Return a pseudo-random number.
60 All integers representable in Lisp, i.e. between `most-negative-fixnum'
61 and `most-positive-fixnum', inclusive, are equally likely.
63 With positive integer LIMIT, return random number in interval [0,LIMIT).
64 With argument t, set the random number seed from the system's entropy
65 pool if available, otherwise from less-random volatile data such as the time.
66 With a string argument, set the seed based on the string's contents.
67 Other values of LIMIT are ignored.
69 See Info node `(elisp)Random Numbers' for more details. */)
76 else if (STRINGP (limit
))
77 seed_random (SSDATA (limit
), SBYTES (limit
));
80 if (INTEGERP (limit
) && 0 < XINT (limit
))
83 /* Return the remainder, except reject the rare case where
84 get_random returns a number so close to INTMASK that the
85 remainder isn't random. */
86 EMACS_INT remainder
= val
% XINT (limit
);
87 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
88 return make_number (remainder
);
91 return make_number (val
);
94 /* Random data-structure functions. */
96 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
97 doc
: /* Return the length of vector, list or string SEQUENCE.
98 A byte-code function object is also allowed.
99 If the string contains multibyte characters, this is not necessarily
100 the number of bytes in the string; it is the number of characters.
101 To get the number of bytes, use `string-bytes'. */)
102 (register Lisp_Object sequence
)
104 register Lisp_Object val
;
106 if (STRINGP (sequence
))
107 XSETFASTINT (val
, SCHARS (sequence
));
108 else if (VECTORP (sequence
))
109 XSETFASTINT (val
, ASIZE (sequence
));
110 else if (CHAR_TABLE_P (sequence
))
111 XSETFASTINT (val
, MAX_CHAR
);
112 else if (BOOL_VECTOR_P (sequence
))
113 XSETFASTINT (val
, bool_vector_size (sequence
));
114 else if (COMPILEDP (sequence
) || RECORDP (sequence
))
115 XSETFASTINT (val
, PVSIZE (sequence
));
116 else if (CONSP (sequence
))
119 FOR_EACH_TAIL (sequence
)
121 CHECK_LIST_END (sequence
, sequence
);
122 if (MOST_POSITIVE_FIXNUM
< i
)
123 error ("List too long");
124 val
= make_number (i
);
126 else if (NILP (sequence
))
127 XSETFASTINT (val
, 0);
129 wrong_type_argument (Qsequencep
, sequence
);
134 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
135 doc
: /* Return the length of a list, but avoid error or infinite loop.
136 This function never gets an error. If LIST is not really a list,
137 it returns 0. If LIST is circular, it returns a finite value
138 which is at least the number of distinct elements. */)
142 FOR_EACH_TAIL_SAFE (list
)
144 return make_fixnum_or_float (len
);
147 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
148 doc
: /* Return the number of bytes in STRING.
149 If STRING is multibyte, this may be greater than the length of STRING. */)
152 CHECK_STRING (string
);
153 return make_number (SBYTES (string
));
156 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
157 doc
: /* Return t if two strings have identical contents.
158 Case is significant, but text properties are ignored.
159 Symbols are also allowed; their print names are used instead. */)
160 (register Lisp_Object s1
, Lisp_Object s2
)
163 s1
= SYMBOL_NAME (s1
);
165 s2
= SYMBOL_NAME (s2
);
169 if (SCHARS (s1
) != SCHARS (s2
)
170 || SBYTES (s1
) != SBYTES (s2
)
171 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
176 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
177 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
178 The arguments START1, END1, START2, and END2, if non-nil, are
179 positions specifying which parts of STR1 or STR2 to compare. In
180 string STR1, compare the part between START1 (inclusive) and END1
181 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
182 the string; if END1 is nil, it defaults to the length of the string.
183 Likewise, in string STR2, compare the part between START2 and END2.
184 Like in `substring', negative values are counted from the end.
186 The strings are compared by the numeric values of their characters.
187 For instance, STR1 is "less than" STR2 if its first differing
188 character has a smaller numeric value. If IGNORE-CASE is non-nil,
189 characters are converted to upper-case before comparing them. Unibyte
190 strings are converted to multibyte for comparison.
192 The value is t if the strings (or specified portions) match.
193 If string STR1 is less, the value is a negative number N;
194 - 1 - N is the number of characters that match at the beginning.
195 If string STR1 is greater, the value is a positive number N;
196 N - 1 is the number of characters that match at the beginning. */)
197 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
198 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
200 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
205 /* For backward compatibility, silently bring too-large positive end
206 values into range. */
207 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
208 end1
= make_number (SCHARS (str1
));
209 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
210 end2
= make_number (SCHARS (str2
));
212 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
213 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
218 i1_byte
= string_char_to_byte (str1
, i1
);
219 i2_byte
= string_char_to_byte (str2
, i2
);
221 while (i1
< to1
&& i2
< to2
)
223 /* When we find a mismatch, we must compare the
224 characters, not just the bytes. */
227 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
228 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
233 if (! NILP (ignore_case
))
235 c1
= XINT (Fupcase (make_number (c1
)));
236 c2
= XINT (Fupcase (make_number (c2
)));
242 /* Note that I1 has already been incremented
243 past the character that we are comparing;
244 hence we don't add or subtract 1 here. */
246 return make_number (- i1
+ from1
);
248 return make_number (i1
- from1
);
252 return make_number (i1
- from1
+ 1);
254 return make_number (- i1
+ from1
- 1);
259 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
260 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
262 Symbols are also allowed; their print names are used instead. */)
263 (register Lisp_Object string1
, Lisp_Object string2
)
265 register ptrdiff_t end
;
266 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
268 if (SYMBOLP (string1
))
269 string1
= SYMBOL_NAME (string1
);
270 if (SYMBOLP (string2
))
271 string2
= SYMBOL_NAME (string2
);
272 CHECK_STRING (string1
);
273 CHECK_STRING (string2
);
275 i1
= i1_byte
= i2
= i2_byte
= 0;
277 end
= SCHARS (string1
);
278 if (end
> SCHARS (string2
))
279 end
= SCHARS (string2
);
283 /* When we find a mismatch, we must compare the
284 characters, not just the bytes. */
287 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
288 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
291 return c1
< c2
? Qt
: Qnil
;
293 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
296 DEFUN ("string-version-lessp", Fstring_version_lessp
,
297 Sstring_version_lessp
, 2, 2, 0,
298 doc
: /* Return non-nil if S1 is less than S2, as version strings.
300 This function compares version strings S1 and S2:
301 1) By prefix lexicographically.
302 2) Then by version (similarly to version comparison of Debian's dpkg).
303 Leading zeros in version numbers are ignored.
304 3) If both prefix and version are equal, compare as ordinary strings.
306 For example, \"foo2.png\" compares less than \"foo12.png\".
308 Symbols are also allowed; their print names are used instead. */)
309 (Lisp_Object string1
, Lisp_Object string2
)
311 if (SYMBOLP (string1
))
312 string1
= SYMBOL_NAME (string1
);
313 if (SYMBOLP (string2
))
314 string2
= SYMBOL_NAME (string2
);
315 CHECK_STRING (string1
);
316 CHECK_STRING (string2
);
318 char *p1
= SSDATA (string1
);
319 char *p2
= SSDATA (string2
);
320 char *lim1
= p1
+ SBYTES (string1
);
321 char *lim2
= p2
+ SBYTES (string2
);
324 while ((cmp
= filevercmp (p1
, p2
)) == 0)
326 /* If the strings are identical through their first null bytes,
327 skip past identical prefixes and try again. */
328 ptrdiff_t size
= strlen (p1
) + 1;
332 return lim2
< p2
? Qnil
: Qt
;
337 return cmp
< 0 ? Qt
: Qnil
;
340 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
341 doc
: /* Return t if first arg string is less than second in collation order.
342 Symbols are also allowed; their print names are used instead.
344 This function obeys the conventions for collation order in your
345 locale settings. For example, punctuation and whitespace characters
346 might be considered less significant for sorting:
348 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
349 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
351 The optional argument LOCALE, a string, overrides the setting of your
352 current locale identifier for collation. The value is system
353 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
354 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
356 If IGNORE-CASE is non-nil, characters are converted to lower-case
357 before comparing them.
359 To emulate Unicode-compliant collation on MS-Windows systems,
360 bind `w32-collate-ignore-punctuation' to a non-nil value, since
361 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
363 If your system does not support a locale environment, this function
364 behaves like `string-lessp'. */)
365 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
367 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
368 /* Check parameters. */
370 s1
= SYMBOL_NAME (s1
);
372 s2
= SYMBOL_NAME (s2
);
376 CHECK_STRING (locale
);
378 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
380 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
381 return Fstring_lessp (s1
, s2
);
382 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
385 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
386 doc
: /* Return t if two strings have identical contents.
387 Symbols are also allowed; their print names are used instead.
389 This function obeys the conventions for collation order in your locale
390 settings. For example, characters with different coding points but
391 the same meaning might be considered as equal, like different grave
392 accent Unicode characters:
394 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
397 The optional argument LOCALE, a string, overrides the setting of your
398 current locale identifier for collation. The value is system
399 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
400 while it would be \"enu_USA.1252\" on MS Windows systems.
402 If IGNORE-CASE is non-nil, characters are converted to lower-case
403 before comparing them.
405 To emulate Unicode-compliant collation on MS-Windows systems,
406 bind `w32-collate-ignore-punctuation' to a non-nil value, since
407 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
409 If your system does not support a locale environment, this function
410 behaves like `string-equal'.
412 Do NOT use this function to compare file names for equality. */)
413 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
415 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
416 /* Check parameters. */
418 s1
= SYMBOL_NAME (s1
);
420 s2
= SYMBOL_NAME (s2
);
424 CHECK_STRING (locale
);
426 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
428 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
429 return Fstring_equal (s1
, s2
);
430 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
433 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
434 enum Lisp_Type target_type
, bool last_special
);
438 concat2 (Lisp_Object s1
, Lisp_Object s2
)
440 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
445 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
447 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
450 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
451 doc
: /* Concatenate all the arguments and make the result a list.
452 The result is a list whose elements are the elements of all the arguments.
453 Each argument may be a list, vector or string.
454 The last argument is not copied, just used as the tail of the new list.
455 usage: (append &rest SEQUENCES) */)
456 (ptrdiff_t nargs
, Lisp_Object
*args
)
458 return concat (nargs
, args
, Lisp_Cons
, 1);
461 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
462 doc
: /* Concatenate all the arguments and make the result a string.
463 The result is a string whose elements are the elements of all the arguments.
464 Each argument may be a string or a list or vector of characters (integers).
465 usage: (concat &rest SEQUENCES) */)
466 (ptrdiff_t nargs
, Lisp_Object
*args
)
468 return concat (nargs
, args
, Lisp_String
, 0);
471 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
472 doc
: /* Concatenate all the arguments and make the result a vector.
473 The result is a vector whose elements are the elements of all the arguments.
474 Each argument may be a list, vector or string.
475 usage: (vconcat &rest SEQUENCES) */)
476 (ptrdiff_t nargs
, Lisp_Object
*args
)
478 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
482 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
483 doc
: /* Return a copy of a list, vector, string, char-table or record.
484 The elements of a list, vector or record are not copied; they are
485 shared with the original.
486 If the original sequence is empty, this function may return
487 the same empty object instead of its copy. */)
490 if (NILP (arg
)) return arg
;
494 return Frecord (PVSIZE (arg
), XVECTOR (arg
)->contents
);
497 if (CHAR_TABLE_P (arg
))
499 return copy_char_table (arg
);
502 if (BOOL_VECTOR_P (arg
))
504 EMACS_INT nbits
= bool_vector_size (arg
);
505 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
506 Lisp_Object val
= make_uninit_bool_vector (nbits
);
507 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
511 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
512 wrong_type_argument (Qsequencep
, arg
);
514 return concat (1, &arg
, XTYPE (arg
), 0);
517 /* This structure holds information of an argument of `concat' that is
518 a string and has text properties to be copied. */
521 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
522 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
523 ptrdiff_t to
; /* refer to VAL (the target string) */
527 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
528 enum Lisp_Type target_type
, bool last_special
)
534 ptrdiff_t toindex_byte
= 0;
535 EMACS_INT result_len
;
536 EMACS_INT result_len_byte
;
538 Lisp_Object last_tail
;
541 /* When we make a multibyte string, we can't copy text properties
542 while concatenating each string because the length of resulting
543 string can't be decided until we finish the whole concatenation.
544 So, we record strings that have text properties to be copied
545 here, and copy the text properties after the concatenation. */
546 struct textprop_rec
*textprops
= NULL
;
547 /* Number of elements in textprops. */
548 ptrdiff_t num_textprops
= 0;
553 /* In append, the last arg isn't treated like the others */
554 if (last_special
&& nargs
> 0)
557 last_tail
= args
[nargs
];
562 /* Check each argument. */
563 for (argnum
= 0; argnum
< nargs
; argnum
++)
566 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
567 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
568 wrong_type_argument (Qsequencep
, this);
571 /* Compute total length in chars of arguments in RESULT_LEN.
572 If desired output is a string, also compute length in bytes
573 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
574 whether the result should be a multibyte string. */
578 for (argnum
= 0; argnum
< nargs
; argnum
++)
582 len
= XFASTINT (Flength (this));
583 if (target_type
== Lisp_String
)
585 /* We must count the number of bytes needed in the string
586 as well as the number of characters. */
590 ptrdiff_t this_len_byte
;
592 if (VECTORP (this) || COMPILEDP (this))
593 for (i
= 0; i
< len
; i
++)
596 CHECK_CHARACTER (ch
);
598 this_len_byte
= CHAR_BYTES (c
);
599 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
601 result_len_byte
+= this_len_byte
;
602 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
605 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
606 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
607 else if (CONSP (this))
608 for (; CONSP (this); this = XCDR (this))
611 CHECK_CHARACTER (ch
);
613 this_len_byte
= CHAR_BYTES (c
);
614 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
616 result_len_byte
+= this_len_byte
;
617 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
620 else if (STRINGP (this))
622 if (STRING_MULTIBYTE (this))
625 this_len_byte
= SBYTES (this);
628 this_len_byte
= count_size_as_multibyte (SDATA (this),
630 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
632 result_len_byte
+= this_len_byte
;
637 if (MOST_POSITIVE_FIXNUM
< result_len
)
638 memory_full (SIZE_MAX
);
641 if (! some_multibyte
)
642 result_len_byte
= result_len
;
644 /* Create the output object. */
645 if (target_type
== Lisp_Cons
)
646 val
= Fmake_list (make_number (result_len
), Qnil
);
647 else if (target_type
== Lisp_Vectorlike
)
648 val
= Fmake_vector (make_number (result_len
), Qnil
);
649 else if (some_multibyte
)
650 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
652 val
= make_uninit_string (result_len
);
654 /* In `append', if all but last arg are nil, return last arg. */
655 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
658 /* Copy the contents of the args into the result. */
660 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
662 toindex
= 0, toindex_byte
= 0;
666 SAFE_NALLOCA (textprops
, 1, nargs
);
668 for (argnum
= 0; argnum
< nargs
; argnum
++)
671 ptrdiff_t thisleni
= 0;
672 register ptrdiff_t thisindex
= 0;
673 register ptrdiff_t thisindex_byte
= 0;
677 thislen
= Flength (this), thisleni
= XINT (thislen
);
679 /* Between strings of the same kind, copy fast. */
680 if (STRINGP (this) && STRINGP (val
)
681 && STRING_MULTIBYTE (this) == some_multibyte
)
683 ptrdiff_t thislen_byte
= SBYTES (this);
685 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
686 if (string_intervals (this))
688 textprops
[num_textprops
].argnum
= argnum
;
689 textprops
[num_textprops
].from
= 0;
690 textprops
[num_textprops
++].to
= toindex
;
692 toindex_byte
+= thislen_byte
;
695 /* Copy a single-byte string to a multibyte string. */
696 else if (STRINGP (this) && STRINGP (val
))
698 if (string_intervals (this))
700 textprops
[num_textprops
].argnum
= argnum
;
701 textprops
[num_textprops
].from
= 0;
702 textprops
[num_textprops
++].to
= toindex
;
704 toindex_byte
+= copy_text (SDATA (this),
705 SDATA (val
) + toindex_byte
,
706 SCHARS (this), 0, 1);
710 /* Copy element by element. */
713 register Lisp_Object elt
;
715 /* Fetch next element of `this' arg into `elt', or break if
716 `this' is exhausted. */
717 if (NILP (this)) break;
719 elt
= XCAR (this), this = XCDR (this);
720 else if (thisindex
>= thisleni
)
722 else if (STRINGP (this))
725 if (STRING_MULTIBYTE (this))
726 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
731 c
= SREF (this, thisindex
); thisindex
++;
732 if (some_multibyte
&& !ASCII_CHAR_P (c
))
733 c
= BYTE8_TO_CHAR (c
);
735 XSETFASTINT (elt
, c
);
737 else if (BOOL_VECTOR_P (this))
739 elt
= bool_vector_ref (this, thisindex
);
744 elt
= AREF (this, thisindex
);
748 /* Store this element into the result. */
755 else if (VECTORP (val
))
757 ASET (val
, toindex
, elt
);
763 CHECK_CHARACTER (elt
);
766 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
768 SSET (val
, toindex_byte
++, c
);
774 XSETCDR (prev
, last_tail
);
776 if (num_textprops
> 0)
779 ptrdiff_t last_to_end
= -1;
781 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
783 this = args
[textprops
[argnum
].argnum
];
784 props
= text_property_list (this,
786 make_number (SCHARS (this)),
788 /* If successive arguments have properties, be sure that the
789 value of `composition' property be the copy. */
790 if (last_to_end
== textprops
[argnum
].to
)
791 make_composition_value_copy (props
);
792 add_text_properties_from_list (val
, props
,
793 make_number (textprops
[argnum
].to
));
794 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
802 static Lisp_Object string_char_byte_cache_string
;
803 static ptrdiff_t string_char_byte_cache_charpos
;
804 static ptrdiff_t string_char_byte_cache_bytepos
;
807 clear_string_char_byte_cache (void)
809 string_char_byte_cache_string
= Qnil
;
812 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
815 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
818 ptrdiff_t best_below
, best_below_byte
;
819 ptrdiff_t best_above
, best_above_byte
;
821 best_below
= best_below_byte
= 0;
822 best_above
= SCHARS (string
);
823 best_above_byte
= SBYTES (string
);
824 if (best_above
== best_above_byte
)
827 if (EQ (string
, string_char_byte_cache_string
))
829 if (string_char_byte_cache_charpos
< char_index
)
831 best_below
= string_char_byte_cache_charpos
;
832 best_below_byte
= string_char_byte_cache_bytepos
;
836 best_above
= string_char_byte_cache_charpos
;
837 best_above_byte
= string_char_byte_cache_bytepos
;
841 if (char_index
- best_below
< best_above
- char_index
)
843 unsigned char *p
= SDATA (string
) + best_below_byte
;
845 while (best_below
< char_index
)
847 p
+= BYTES_BY_CHAR_HEAD (*p
);
850 i_byte
= p
- SDATA (string
);
854 unsigned char *p
= SDATA (string
) + best_above_byte
;
856 while (best_above
> char_index
)
859 while (!CHAR_HEAD_P (*p
)) p
--;
862 i_byte
= p
- SDATA (string
);
865 string_char_byte_cache_bytepos
= i_byte
;
866 string_char_byte_cache_charpos
= char_index
;
867 string_char_byte_cache_string
= string
;
872 /* Return the character index corresponding to BYTE_INDEX in STRING. */
875 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
878 ptrdiff_t best_below
, best_below_byte
;
879 ptrdiff_t best_above
, best_above_byte
;
881 best_below
= best_below_byte
= 0;
882 best_above
= SCHARS (string
);
883 best_above_byte
= SBYTES (string
);
884 if (best_above
== best_above_byte
)
887 if (EQ (string
, string_char_byte_cache_string
))
889 if (string_char_byte_cache_bytepos
< byte_index
)
891 best_below
= string_char_byte_cache_charpos
;
892 best_below_byte
= string_char_byte_cache_bytepos
;
896 best_above
= string_char_byte_cache_charpos
;
897 best_above_byte
= string_char_byte_cache_bytepos
;
901 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
903 unsigned char *p
= SDATA (string
) + best_below_byte
;
904 unsigned char *pend
= SDATA (string
) + byte_index
;
908 p
+= BYTES_BY_CHAR_HEAD (*p
);
912 i_byte
= p
- SDATA (string
);
916 unsigned char *p
= SDATA (string
) + best_above_byte
;
917 unsigned char *pbeg
= SDATA (string
) + byte_index
;
922 while (!CHAR_HEAD_P (*p
)) p
--;
926 i_byte
= p
- SDATA (string
);
929 string_char_byte_cache_bytepos
= i_byte
;
930 string_char_byte_cache_charpos
= i
;
931 string_char_byte_cache_string
= string
;
936 /* Convert STRING to a multibyte string. */
939 string_make_multibyte (Lisp_Object string
)
946 if (STRING_MULTIBYTE (string
))
949 nbytes
= count_size_as_multibyte (SDATA (string
),
951 /* If all the chars are ASCII, they won't need any more bytes
952 once converted. In that case, we can return STRING itself. */
953 if (nbytes
== SBYTES (string
))
956 buf
= SAFE_ALLOCA (nbytes
);
957 copy_text (SDATA (string
), buf
, SBYTES (string
),
960 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
967 /* Convert STRING (if unibyte) to a multibyte string without changing
968 the number of characters. Characters 0200 trough 0237 are
969 converted to eight-bit characters. */
972 string_to_multibyte (Lisp_Object string
)
979 if (STRING_MULTIBYTE (string
))
982 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
983 /* If all the chars are ASCII, they won't need any more bytes once
985 if (nbytes
== SBYTES (string
))
986 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
988 buf
= SAFE_ALLOCA (nbytes
);
989 memcpy (buf
, SDATA (string
), SBYTES (string
));
990 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
992 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
999 /* Convert STRING to a single-byte string. */
1002 string_make_unibyte (Lisp_Object string
)
1009 if (! STRING_MULTIBYTE (string
))
1012 nchars
= SCHARS (string
);
1014 buf
= SAFE_ALLOCA (nchars
);
1015 copy_text (SDATA (string
), buf
, SBYTES (string
),
1018 ret
= make_unibyte_string ((char *) buf
, nchars
);
1024 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1026 doc
: /* Return the multibyte equivalent of STRING.
1027 If STRING is unibyte and contains non-ASCII characters, the function
1028 `unibyte-char-to-multibyte' is used to convert each unibyte character
1029 to a multibyte character. In this case, the returned string is a
1030 newly created string with no text properties. If STRING is multibyte
1031 or entirely ASCII, it is returned unchanged. In particular, when
1032 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1033 \(When the characters are all ASCII, Emacs primitives will treat the
1034 string the same way whether it is unibyte or multibyte.) */)
1035 (Lisp_Object string
)
1037 CHECK_STRING (string
);
1039 return string_make_multibyte (string
);
1042 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1044 doc
: /* Return the unibyte equivalent of STRING.
1045 Multibyte character codes above 255 are converted to unibyte
1046 by taking just the low 8 bits of each character's code. */)
1047 (Lisp_Object string
)
1049 CHECK_STRING (string
);
1051 return string_make_unibyte (string
);
1054 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1056 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1057 If STRING is unibyte, the result is STRING itself.
1058 Otherwise it is a newly created string, with no text properties.
1059 If STRING is multibyte and contains a character of charset
1060 `eight-bit', it is converted to the corresponding single byte. */)
1061 (Lisp_Object string
)
1063 CHECK_STRING (string
);
1065 if (STRING_MULTIBYTE (string
))
1067 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1068 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1070 string
= make_unibyte_string ((char *) str
, bytes
);
1076 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1078 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1079 If STRING is multibyte, the result is STRING itself.
1080 Otherwise it is a newly created string, with no text properties.
1082 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1083 part of a correct utf-8 sequence), it is converted to the corresponding
1084 multibyte character of charset `eight-bit'.
1085 See also `string-to-multibyte'.
1087 Beware, this often doesn't really do what you think it does.
1088 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1089 If you're not sure, whether to use `string-as-multibyte' or
1090 `string-to-multibyte', use `string-to-multibyte'. */)
1091 (Lisp_Object string
)
1093 CHECK_STRING (string
);
1095 if (! STRING_MULTIBYTE (string
))
1097 Lisp_Object new_string
;
1098 ptrdiff_t nchars
, nbytes
;
1100 parse_str_as_multibyte (SDATA (string
),
1103 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1104 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1105 if (nbytes
!= SBYTES (string
))
1106 str_as_multibyte (SDATA (new_string
), nbytes
,
1107 SBYTES (string
), NULL
);
1108 string
= new_string
;
1109 set_string_intervals (string
, NULL
);
1114 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1116 doc
: /* Return a multibyte string with the same individual chars as STRING.
1117 If STRING is multibyte, the result is STRING itself.
1118 Otherwise it is a newly created string, with no text properties.
1120 If STRING is unibyte and contains an 8-bit byte, it is converted to
1121 the corresponding multibyte character of charset `eight-bit'.
1123 This differs from `string-as-multibyte' by converting each byte of a correct
1124 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1125 correct sequence. */)
1126 (Lisp_Object string
)
1128 CHECK_STRING (string
);
1130 return string_to_multibyte (string
);
1133 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1135 doc
: /* Return a unibyte string with the same individual chars as STRING.
1136 If STRING is unibyte, the result is STRING itself.
1137 Otherwise it is a newly created string, with no text properties,
1138 where each `eight-bit' character is converted to the corresponding byte.
1139 If STRING contains a non-ASCII, non-`eight-bit' character,
1140 an error is signaled. */)
1141 (Lisp_Object string
)
1143 CHECK_STRING (string
);
1145 if (STRING_MULTIBYTE (string
))
1147 ptrdiff_t chars
= SCHARS (string
);
1148 unsigned char *str
= xmalloc (chars
);
1149 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1151 if (converted
< chars
)
1152 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1153 string
= make_unibyte_string ((char *) str
, chars
);
1160 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1161 doc
: /* Return a copy of ALIST.
1162 This is an alist which represents the same mapping from objects to objects,
1163 but does not share the alist structure with ALIST.
1164 The objects mapped (cars and cdrs of elements of the alist)
1165 are shared, however.
1166 Elements of ALIST that are not conses are also shared. */)
1171 alist
= concat (1, &alist
, Lisp_Cons
, false);
1172 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1174 Lisp_Object car
= XCAR (tem
);
1176 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1181 /* Check that ARRAY can have a valid subarray [FROM..TO),
1182 given that its size is SIZE.
1183 If FROM is nil, use 0; if TO is nil, use SIZE.
1184 Count negative values backwards from the end.
1185 Set *IFROM and *ITO to the two indexes used. */
1188 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1189 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1193 if (INTEGERP (from
))
1199 else if (NILP (from
))
1202 wrong_type_argument (Qintegerp
, from
);
1213 wrong_type_argument (Qintegerp
, to
);
1215 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1216 args_out_of_range_3 (array
, from
, to
);
1222 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1223 doc
: /* Return a new string whose contents are a substring of STRING.
1224 The returned string consists of the characters between index FROM
1225 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1226 zero-indexed: 0 means the first character of STRING. Negative values
1227 are counted from the end of STRING. If TO is nil, the substring runs
1228 to the end of STRING.
1230 The STRING argument may also be a vector. In that case, the return
1231 value is a new vector that contains the elements between index FROM
1232 \(inclusive) and index TO (exclusive) of that vector argument.
1234 With one argument, just copy STRING (with properties, if any). */)
1235 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1238 ptrdiff_t size
, ifrom
, ito
;
1240 size
= CHECK_VECTOR_OR_STRING (string
);
1241 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1243 if (STRINGP (string
))
1246 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1248 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1249 res
= make_specified_string (SSDATA (string
) + from_byte
,
1250 ito
- ifrom
, to_byte
- from_byte
,
1251 STRING_MULTIBYTE (string
));
1252 copy_text_properties (make_number (ifrom
), make_number (ito
),
1253 string
, make_number (0), res
, Qnil
);
1256 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1262 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1263 doc
: /* Return a substring of STRING, without text properties.
1264 It starts at index FROM and ends before TO.
1265 TO may be nil or omitted; then the substring runs to the end of STRING.
1266 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1267 If FROM or TO is negative, it counts from the end.
1269 With one argument, just copy STRING without its properties. */)
1270 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1272 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1274 CHECK_STRING (string
);
1276 size
= SCHARS (string
);
1277 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1279 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1281 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1282 return make_specified_string (SSDATA (string
) + from_byte
,
1283 to_char
- from_char
, to_byte
- from_byte
,
1284 STRING_MULTIBYTE (string
));
1287 /* Extract a substring of STRING, giving start and end positions
1288 both in characters and in bytes. */
1291 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1292 ptrdiff_t to
, ptrdiff_t to_byte
)
1295 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1297 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1298 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1300 if (STRINGP (string
))
1302 res
= make_specified_string (SSDATA (string
) + from_byte
,
1303 to
- from
, to_byte
- from_byte
,
1304 STRING_MULTIBYTE (string
));
1305 copy_text_properties (make_number (from
), make_number (to
),
1306 string
, make_number (0), res
, Qnil
);
1309 res
= Fvector (to
- from
, aref_addr (string
, from
));
1314 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1315 doc
: /* Take cdr N times on LIST, return the result. */)
1316 (Lisp_Object n
, Lisp_Object list
)
1319 Lisp_Object tail
= list
;
1320 for (EMACS_INT num
= XINT (n
); 0 < num
; num
--)
1324 CHECK_LIST_END (tail
, list
);
1333 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1334 doc
: /* Return the Nth element of LIST.
1335 N counts from zero. If LIST is not that long, nil is returned. */)
1336 (Lisp_Object n
, Lisp_Object list
)
1338 return Fcar (Fnthcdr (n
, list
));
1341 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1342 doc
: /* Return element of SEQUENCE at index N. */)
1343 (register Lisp_Object sequence
, Lisp_Object n
)
1346 if (CONSP (sequence
) || NILP (sequence
))
1347 return Fcar (Fnthcdr (n
, sequence
));
1349 /* Faref signals a "not array" error, so check here. */
1350 CHECK_ARRAY (sequence
, Qsequencep
);
1351 return Faref (sequence
, n
);
1354 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1355 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1356 The value is actually the tail of LIST whose car is ELT. */)
1357 (Lisp_Object elt
, Lisp_Object list
)
1359 Lisp_Object tail
= list
;
1360 FOR_EACH_TAIL (tail
)
1361 if (! NILP (Fequal (elt
, XCAR (tail
))))
1363 CHECK_LIST_END (tail
, list
);
1367 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1368 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1369 The value is actually the tail of LIST whose car is ELT. */)
1370 (Lisp_Object elt
, Lisp_Object list
)
1372 Lisp_Object tail
= list
;
1373 FOR_EACH_TAIL (tail
)
1374 if (EQ (XCAR (tail
), elt
))
1376 CHECK_LIST_END (tail
, list
);
1380 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1381 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1382 The value is actually the tail of LIST whose car is ELT. */)
1383 (Lisp_Object elt
, Lisp_Object list
)
1386 return Fmemq (elt
, list
);
1388 Lisp_Object tail
= list
;
1389 FOR_EACH_TAIL (tail
)
1391 Lisp_Object tem
= XCAR (tail
);
1392 if (FLOATP (tem
) && equal_no_quit (elt
, tem
))
1395 CHECK_LIST_END (tail
, list
);
1399 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1400 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1401 The value is actually the first element of LIST whose car is KEY.
1402 Elements of LIST that are not conses are ignored. */)
1403 (Lisp_Object key
, Lisp_Object list
)
1405 Lisp_Object tail
= list
;
1406 FOR_EACH_TAIL (tail
)
1407 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1409 CHECK_LIST_END (tail
, list
);
1413 /* Like Fassq but never report an error and do not allow quits.
1414 Use only on objects known to be non-circular lists. */
1417 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1419 for (; ! NILP (list
); list
= XCDR (list
))
1420 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1425 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 3, 0,
1426 doc
: /* Return non-nil if KEY is equal to the car of an element of LIST.
1427 The value is actually the first element of LIST whose car equals KEY.
1429 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1430 (Lisp_Object key
, Lisp_Object list
, Lisp_Object testfn
)
1432 Lisp_Object tail
= list
;
1433 FOR_EACH_TAIL (tail
)
1435 Lisp_Object car
= XCAR (tail
);
1438 ? (EQ (XCAR (car
), key
) || !NILP (Fequal
1440 : !NILP (call2 (testfn
, XCAR (car
), key
))))
1443 CHECK_LIST_END (tail
, list
);
1447 /* Like Fassoc but never report an error and do not allow quits.
1448 Use only on keys and lists known to be non-circular, and on keys
1449 that are not too deep and are not window configurations. */
1452 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1454 for (; ! NILP (list
); list
= XCDR (list
))
1456 Lisp_Object car
= XCAR (list
);
1458 && (EQ (XCAR (car
), key
) || equal_no_quit (XCAR (car
), key
)))
1464 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1465 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1466 The value is actually the first element of LIST whose cdr is KEY. */)
1467 (Lisp_Object key
, Lisp_Object list
)
1469 Lisp_Object tail
= list
;
1470 FOR_EACH_TAIL (tail
)
1471 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1473 CHECK_LIST_END (tail
, list
);
1477 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1478 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1479 The value is actually the first element of LIST whose cdr equals KEY. */)
1480 (Lisp_Object key
, Lisp_Object list
)
1482 Lisp_Object tail
= list
;
1483 FOR_EACH_TAIL (tail
)
1485 Lisp_Object car
= XCAR (tail
);
1487 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1490 CHECK_LIST_END (tail
, list
);
1494 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1495 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1496 More precisely, this function skips any members `eq' to ELT at the
1497 front of LIST, then removes members `eq' to ELT from the remaining
1498 sublist by modifying its list structure, then returns the resulting
1501 Write `(setq foo (delq element foo))' to be sure of correctly changing
1502 the value of a list `foo'. See also `remq', which does not modify the
1504 (Lisp_Object elt
, Lisp_Object list
)
1506 Lisp_Object prev
= Qnil
, tail
= list
;
1508 FOR_EACH_TAIL (tail
)
1510 Lisp_Object tem
= XCAR (tail
);
1516 Fsetcdr (prev
, XCDR (tail
));
1521 CHECK_LIST_END (tail
, list
);
1525 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1526 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1527 SEQ must be a sequence (i.e. a list, a vector, or a string).
1528 The return value is a sequence of the same type.
1530 If SEQ is a list, this behaves like `delq', except that it compares
1531 with `equal' instead of `eq'. In particular, it may remove elements
1532 by altering the list structure.
1534 If SEQ is not a list, deletion is never performed destructively;
1535 instead this function creates and returns a new vector or string.
1537 Write `(setq foo (delete element foo))' to be sure of correctly
1538 changing the value of a sequence `foo'. */)
1539 (Lisp_Object elt
, Lisp_Object seq
)
1545 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1546 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1549 if (n
!= ASIZE (seq
))
1551 struct Lisp_Vector
*p
= allocate_vector (n
);
1553 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1554 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1555 p
->contents
[n
++] = AREF (seq
, i
);
1557 XSETVECTOR (seq
, p
);
1560 else if (STRINGP (seq
))
1562 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1565 for (i
= nchars
= nbytes
= ibyte
= 0;
1567 ++i
, ibyte
+= cbytes
)
1569 if (STRING_MULTIBYTE (seq
))
1571 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1572 cbytes
= CHAR_BYTES (c
);
1580 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1587 if (nchars
!= SCHARS (seq
))
1591 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1592 if (!STRING_MULTIBYTE (seq
))
1593 STRING_SET_UNIBYTE (tem
);
1595 for (i
= nchars
= nbytes
= ibyte
= 0;
1597 ++i
, ibyte
+= cbytes
)
1599 if (STRING_MULTIBYTE (seq
))
1601 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1602 cbytes
= CHAR_BYTES (c
);
1610 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1612 unsigned char *from
= SDATA (seq
) + ibyte
;
1613 unsigned char *to
= SDATA (tem
) + nbytes
;
1619 for (n
= cbytes
; n
--; )
1629 Lisp_Object prev
= Qnil
, tail
= seq
;
1631 FOR_EACH_TAIL (tail
)
1633 if (!NILP (Fequal (elt
, XCAR (tail
))))
1638 Fsetcdr (prev
, XCDR (tail
));
1643 CHECK_LIST_END (tail
, seq
);
1649 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1650 doc
: /* Reverse order of items in a list, vector or string SEQ.
1651 If SEQ is a list, it should be nil-terminated.
1652 This function may destructively modify SEQ to produce the value. */)
1657 else if (STRINGP (seq
))
1658 return Freverse (seq
);
1659 else if (CONSP (seq
))
1661 Lisp_Object prev
, tail
, next
;
1663 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1666 /* If SEQ contains a cycle, attempting to reverse it
1667 in-place will inevitably come back to SEQ. */
1669 circular_list (seq
);
1670 Fsetcdr (tail
, prev
);
1673 CHECK_LIST_END (tail
, seq
);
1676 else if (VECTORP (seq
))
1678 ptrdiff_t i
, size
= ASIZE (seq
);
1680 for (i
= 0; i
< size
/ 2; i
++)
1682 Lisp_Object tem
= AREF (seq
, i
);
1683 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1684 ASET (seq
, size
- i
- 1, tem
);
1687 else if (BOOL_VECTOR_P (seq
))
1689 ptrdiff_t i
, size
= bool_vector_size (seq
);
1691 for (i
= 0; i
< size
/ 2; i
++)
1693 bool tem
= bool_vector_bitref (seq
, i
);
1694 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1695 bool_vector_set (seq
, size
- i
- 1, tem
);
1699 wrong_type_argument (Qarrayp
, seq
);
1703 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1704 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1705 See also the function `nreverse', which is used more often. */)
1712 else if (CONSP (seq
))
1716 new = Fcons (XCAR (seq
), new);
1717 CHECK_LIST_END (seq
, seq
);
1719 else if (VECTORP (seq
))
1721 ptrdiff_t i
, size
= ASIZE (seq
);
1723 new = make_uninit_vector (size
);
1724 for (i
= 0; i
< size
; i
++)
1725 ASET (new, i
, AREF (seq
, size
- i
- 1));
1727 else if (BOOL_VECTOR_P (seq
))
1730 EMACS_INT nbits
= bool_vector_size (seq
);
1732 new = make_uninit_bool_vector (nbits
);
1733 for (i
= 0; i
< nbits
; i
++)
1734 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1736 else if (STRINGP (seq
))
1738 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1744 new = make_uninit_string (size
);
1745 for (i
= 0; i
< size
; i
++)
1746 SSET (new, i
, SREF (seq
, size
- i
- 1));
1750 unsigned char *p
, *q
;
1752 new = make_uninit_multibyte_string (size
, bytes
);
1753 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1754 while (q
> SDATA (new))
1758 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1760 CHAR_STRING (ch
, q
);
1765 wrong_type_argument (Qsequencep
, seq
);
1769 /* Sort LIST using PREDICATE, preserving original order of elements
1770 considered as equal. */
1773 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1775 Lisp_Object front
, back
;
1776 Lisp_Object len
, tem
;
1780 len
= Flength (list
);
1781 length
= XINT (len
);
1785 XSETINT (len
, (length
/ 2) - 1);
1786 tem
= Fnthcdr (len
, list
);
1788 Fsetcdr (tem
, Qnil
);
1790 front
= Fsort (front
, predicate
);
1791 back
= Fsort (back
, predicate
);
1792 return merge (front
, back
, predicate
);
1795 /* Using PRED to compare, return whether A and B are in order.
1796 Compare stably when A appeared before B in the input. */
1798 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1800 return NILP (call2 (pred
, b
, a
));
1803 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1804 into DEST. Argument arrays must be nonempty and must not overlap,
1805 except that B might be the last part of DEST. */
1807 merge_vectors (Lisp_Object pred
,
1808 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1809 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1810 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1812 eassume (0 < alen
&& 0 < blen
);
1813 Lisp_Object
const *alim
= a
+ alen
;
1814 Lisp_Object
const *blim
= b
+ blen
;
1818 if (inorder (pred
, a
[0], b
[0]))
1824 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1833 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1840 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1841 temporary storage. LEN must be at least 2. */
1843 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1844 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1845 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1848 ptrdiff_t halflen
= len
>> 1;
1849 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1850 if (1 < len
- halflen
)
1851 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1852 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1855 /* Using PRED to compare, sort from LEN-length SRC into DST.
1856 Len must be positive. */
1858 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1859 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1860 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1863 ptrdiff_t halflen
= len
>> 1;
1869 sort_vector_inplace (pred
, halflen
, src
, dest
);
1870 if (1 < len
- halflen
)
1871 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1872 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1876 /* Sort VECTOR in place using PREDICATE, preserving original order of
1877 elements considered as equal. */
1880 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1882 ptrdiff_t len
= ASIZE (vector
);
1885 ptrdiff_t halflen
= len
>> 1;
1888 SAFE_ALLOCA_LISP (tmp
, halflen
);
1889 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1890 tmp
[i
] = make_number (0);
1891 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1895 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1896 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1897 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1898 modified by side effects. PREDICATE is called with two elements of
1899 SEQ, and should return non-nil if the first element should sort before
1901 (Lisp_Object seq
, Lisp_Object predicate
)
1904 seq
= sort_list (seq
, predicate
);
1905 else if (VECTORP (seq
))
1906 sort_vector (seq
, predicate
);
1907 else if (!NILP (seq
))
1908 wrong_type_argument (Qsequencep
, seq
);
1913 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1915 Lisp_Object l1
= org_l1
;
1916 Lisp_Object l2
= org_l2
;
1917 Lisp_Object tail
= Qnil
;
1918 Lisp_Object value
= Qnil
;
1938 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
1953 Fsetcdr (tail
, tem
);
1959 /* This does not check for quits. That is safe since it must terminate. */
1961 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1962 doc
: /* Extract a value from a property list.
1963 PLIST is a property list, which is a list of the form
1964 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1965 corresponding to the given PROP, or nil if PROP is not one of the
1966 properties on the list. This function never signals an error. */)
1967 (Lisp_Object plist
, Lisp_Object prop
)
1969 Lisp_Object tail
= plist
;
1970 FOR_EACH_TAIL_SAFE (tail
)
1972 if (! CONSP (XCDR (tail
)))
1974 if (EQ (prop
, XCAR (tail
)))
1975 return XCAR (XCDR (tail
));
1977 if (EQ (tail
, li
.tortoise
))
1984 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1985 doc
: /* Return the value of SYMBOL's PROPNAME property.
1986 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1987 (Lisp_Object symbol
, Lisp_Object propname
)
1989 CHECK_SYMBOL (symbol
);
1990 Lisp_Object propval
= Fplist_get (CDR (Fassq (symbol
, Voverriding_plist_environment
)),
1992 if (!NILP (propval
))
1994 return Fplist_get (XSYMBOL (symbol
)->u
.s
.plist
, propname
);
1997 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1998 doc
: /* Change value in PLIST of PROP to VAL.
1999 PLIST is a property list, which is a list of the form
2000 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2001 If PROP is already a property on the list, its value is set to VAL,
2002 otherwise the new PROP VAL pair is added. The new plist is returned;
2003 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2004 The PLIST is modified by side effects. */)
2005 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2007 Lisp_Object prev
= Qnil
, tail
= plist
;
2008 FOR_EACH_TAIL (tail
)
2010 if (! CONSP (XCDR (tail
)))
2013 if (EQ (prop
, XCAR (tail
)))
2015 Fsetcar (XCDR (tail
), val
);
2021 if (EQ (tail
, li
.tortoise
))
2022 circular_list (plist
);
2024 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2026 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2029 Fsetcdr (XCDR (prev
), newcell
);
2033 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2034 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2035 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2036 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2038 CHECK_SYMBOL (symbol
);
2040 (symbol
, Fplist_put (XSYMBOL (symbol
)->u
.s
.plist
, propname
, value
));
2044 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2045 doc
: /* Extract a value from a property list, comparing with `equal'.
2046 PLIST is a property list, which is a list of the form
2047 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2048 corresponding to the given PROP, or nil if PROP is not
2049 one of the properties on the list. */)
2050 (Lisp_Object plist
, Lisp_Object prop
)
2052 Lisp_Object tail
= plist
;
2053 FOR_EACH_TAIL (tail
)
2055 if (! CONSP (XCDR (tail
)))
2057 if (! NILP (Fequal (prop
, XCAR (tail
))))
2058 return XCAR (XCDR (tail
));
2060 if (EQ (tail
, li
.tortoise
))
2061 circular_list (plist
);
2064 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2069 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2070 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2071 PLIST is a property list, which is a list of the form
2072 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2073 If PROP is already a property on the list, its value is set to VAL,
2074 otherwise the new PROP VAL pair is added. The new plist is returned;
2075 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2076 The PLIST is modified by side effects. */)
2077 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2079 Lisp_Object prev
= Qnil
, tail
= plist
;
2080 FOR_EACH_TAIL (tail
)
2082 if (! CONSP (XCDR (tail
)))
2085 if (! NILP (Fequal (prop
, XCAR (tail
))))
2087 Fsetcar (XCDR (tail
), val
);
2093 if (EQ (tail
, li
.tortoise
))
2094 circular_list (plist
);
2096 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2097 Lisp_Object newcell
= list2 (prop
, val
);
2100 Fsetcdr (XCDR (prev
), newcell
);
2104 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2105 doc
: /* Return t if the two args are the same Lisp object.
2106 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2107 (Lisp_Object obj1
, Lisp_Object obj2
)
2110 return equal_no_quit (obj1
, obj2
) ? Qt
: Qnil
;
2112 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2115 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2116 doc
: /* Return t if two Lisp objects have similar structure and contents.
2117 They must have the same data type.
2118 Conses are compared by comparing the cars and the cdrs.
2119 Vectors and strings are compared element by element.
2120 Numbers are compared by value, but integers cannot equal floats.
2121 (Use `=' if you want integers and floats to be able to be equal.)
2122 Symbols must match exactly. */)
2123 (Lisp_Object o1
, Lisp_Object o2
)
2125 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2128 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2129 doc
: /* Return t if two Lisp objects have similar structure and contents.
2130 This is like `equal' except that it compares the text properties
2131 of strings. (`equal' ignores text properties.) */)
2132 (Lisp_Object o1
, Lisp_Object o2
)
2134 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2138 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2139 Use this only on arguments that are cycle-free and not too large and
2140 are not window configurations. */
2143 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2145 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2148 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2149 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2150 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2151 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2152 equal-including-properties.
2154 If DEPTH is the current depth of recursion; signal an error if it
2155 gets too deep. HT is a hash table used to detect cycles; if nil,
2156 it has not been allocated yet. But ignore the last two arguments
2157 if EQUAL_KIND == EQUAL_NO_QUIT. */
2160 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2161 int depth
, Lisp_Object ht
)
2166 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2168 error ("Stack overflow in equal");
2170 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2173 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2175 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2177 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2179 { /* `o1' was seen already. */
2180 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2181 if (!NILP (Fmemq (o2
, o2s
)))
2184 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2187 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2195 if (XTYPE (o1
) != XTYPE (o2
))
2202 double d1
= XFLOAT_DATA (o1
);
2203 double d2
= XFLOAT_DATA (o2
);
2204 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2205 though they are not =. */
2206 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2210 if (equal_kind
== EQUAL_NO_QUIT
)
2211 for (; CONSP (o1
); o1
= XCDR (o1
))
2215 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2218 if (EQ (XCDR (o1
), o2
))
2226 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2227 equal_kind
, depth
+ 1, ht
))
2230 if (EQ (XCDR (o1
), o2
))
2237 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2241 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2242 equal_kind
, depth
+ 1, ht
)
2243 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2244 equal_kind
, depth
+ 1, ht
))
2246 o1
= XOVERLAY (o1
)->plist
;
2247 o2
= XOVERLAY (o2
)->plist
;
2253 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2254 && (XMARKER (o1
)->buffer
== 0
2255 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2259 case Lisp_Vectorlike
:
2262 ptrdiff_t size
= ASIZE (o1
);
2263 /* Pseudovectors have the type encoded in the size field, so this test
2264 actually checks that the objects have the same type as well as the
2266 if (ASIZE (o2
) != size
)
2268 /* Boolvectors are compared much like strings. */
2269 if (BOOL_VECTOR_P (o1
))
2271 EMACS_INT size
= bool_vector_size (o1
);
2272 if (size
!= bool_vector_size (o2
))
2274 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2275 bool_vector_bytes (size
)))
2279 if (WINDOW_CONFIGURATIONP (o1
))
2281 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2282 return compare_window_configurations (o1
, o2
, false);
2285 /* Aside from them, only true vectors, char-tables, compiled
2286 functions, and fonts (font-spec, font-entity, font-object)
2287 are sensible to compare, so eliminate the others now. */
2288 if (size
& PSEUDOVECTOR_FLAG
)
2290 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2293 size
&= PSEUDOVECTOR_SIZE_MASK
;
2295 for (i
= 0; i
< size
; i
++)
2300 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2308 if (SCHARS (o1
) != SCHARS (o2
))
2310 if (SBYTES (o1
) != SBYTES (o2
))
2312 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2314 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2315 && !compare_string_intervals (o1
, o2
))
2327 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2328 doc
: /* Store each element of ARRAY with ITEM.
2329 ARRAY is a vector, string, char-table, or bool-vector. */)
2330 (Lisp_Object array
, Lisp_Object item
)
2332 register ptrdiff_t size
, idx
;
2334 if (VECTORP (array
))
2335 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2336 ASET (array
, idx
, item
);
2337 else if (CHAR_TABLE_P (array
))
2341 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2342 set_char_table_contents (array
, i
, item
);
2343 set_char_table_defalt (array
, item
);
2345 else if (STRINGP (array
))
2347 register unsigned char *p
= SDATA (array
);
2349 CHECK_CHARACTER (item
);
2350 charval
= XFASTINT (item
);
2351 size
= SCHARS (array
);
2352 if (STRING_MULTIBYTE (array
))
2354 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2355 int len
= CHAR_STRING (charval
, str
);
2356 ptrdiff_t size_byte
= SBYTES (array
);
2359 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2360 error ("Attempt to change byte length of a string");
2361 for (idx
= 0; idx
< size_byte
; idx
++)
2362 *p
++ = str
[idx
% len
];
2365 for (idx
= 0; idx
< size
; idx
++)
2368 else if (BOOL_VECTOR_P (array
))
2369 return bool_vector_fill (array
, item
);
2371 wrong_type_argument (Qarrayp
, array
);
2375 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2377 doc
: /* Clear the contents of STRING.
2378 This makes STRING unibyte and may change its length. */)
2379 (Lisp_Object string
)
2382 CHECK_STRING (string
);
2383 len
= SBYTES (string
);
2384 memset (SDATA (string
), 0, len
);
2385 STRING_SET_CHARS (string
, len
);
2386 STRING_SET_UNIBYTE (string
);
2392 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2394 return CALLN (Fnconc
, s1
, s2
);
2397 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2398 doc
: /* Concatenate any number of lists by altering them.
2399 Only the last argument is not altered, and need not be a list.
2400 usage: (nconc &rest LISTS) */)
2401 (ptrdiff_t nargs
, Lisp_Object
*args
)
2403 Lisp_Object val
= Qnil
;
2405 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2407 Lisp_Object tem
= args
[argnum
];
2408 if (NILP (tem
)) continue;
2413 if (argnum
+ 1 == nargs
) break;
2421 tem
= args
[argnum
+ 1];
2422 Fsetcdr (tail
, tem
);
2424 args
[argnum
+ 1] = tail
;
2430 /* This is the guts of all mapping functions.
2431 Apply FN to each element of SEQ, one by one, storing the results
2432 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2433 length of VALS, which should also be the length of SEQ. Return the
2434 number of results; although this is normally LENI, it can be less
2435 if SEQ is made shorter as a side effect of FN. */
2438 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2440 Lisp_Object tail
, dummy
;
2443 if (VECTORP (seq
) || COMPILEDP (seq
))
2445 for (i
= 0; i
< leni
; i
++)
2447 dummy
= call1 (fn
, AREF (seq
, i
));
2452 else if (BOOL_VECTOR_P (seq
))
2454 for (i
= 0; i
< leni
; i
++)
2456 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2461 else if (STRINGP (seq
))
2465 for (i
= 0, i_byte
= 0; i
< leni
;)
2468 ptrdiff_t i_before
= i
;
2470 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2471 XSETFASTINT (dummy
, c
);
2472 dummy
= call1 (fn
, dummy
);
2474 vals
[i_before
] = dummy
;
2477 else /* Must be a list, since Flength did not get an error */
2480 for (i
= 0; i
< leni
; i
++)
2484 dummy
= call1 (fn
, XCAR (tail
));
2494 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2495 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2496 In between each pair of results, stick in SEPARATOR. Thus, " " as
2497 SEPARATOR results in spaces between the values returned by FUNCTION.
2498 SEQUENCE may be a list, a vector, a bool-vector, or a string.
2499 SEPARATOR must be a string.
2500 FUNCTION must be a function of one argument, and must return a value
2501 that is a sequence of characters: either a string, or a vector or
2502 list of numbers that are valid character codepoints. */)
2503 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2506 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2507 if (CHAR_TABLE_P (sequence
))
2508 wrong_type_argument (Qlistp
, sequence
);
2509 EMACS_INT args_alloc
= 2 * leni
- 1;
2511 return empty_unibyte_string
;
2513 SAFE_ALLOCA_LISP (args
, args_alloc
);
2514 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2515 ptrdiff_t nargs
= 2 * nmapped
- 1;
2517 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2518 args
[i
+ i
] = args
[i
];
2520 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2521 args
[i
] = separator
;
2523 Lisp_Object ret
= Fconcat (nargs
, args
);
2528 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2529 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2530 The result is a list just as long as SEQUENCE.
2531 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2532 (Lisp_Object function
, Lisp_Object sequence
)
2535 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2536 if (CHAR_TABLE_P (sequence
))
2537 wrong_type_argument (Qlistp
, sequence
);
2539 SAFE_ALLOCA_LISP (args
, leni
);
2540 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2541 Lisp_Object ret
= Flist (nmapped
, args
);
2546 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2547 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2548 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2549 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2550 (Lisp_Object function
, Lisp_Object sequence
)
2552 register EMACS_INT leni
;
2554 leni
= XFASTINT (Flength (sequence
));
2555 if (CHAR_TABLE_P (sequence
))
2556 wrong_type_argument (Qlistp
, sequence
);
2557 mapcar1 (leni
, 0, function
, sequence
);
2562 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2563 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2564 the results by altering them (using `nconc').
2565 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2566 (Lisp_Object function
, Lisp_Object sequence
)
2569 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2570 if (CHAR_TABLE_P (sequence
))
2571 wrong_type_argument (Qlistp
, sequence
);
2573 SAFE_ALLOCA_LISP (args
, leni
);
2574 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2575 Lisp_Object ret
= Fnconc (nmapped
, args
);
2580 /* This is how C code calls `yes-or-no-p' and allows the user
2584 do_yes_or_no_p (Lisp_Object prompt
)
2586 return call1 (intern ("yes-or-no-p"), prompt
);
2589 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2590 doc
: /* Ask user a yes-or-no question.
2591 Return t if answer is yes, and nil if the answer is no.
2592 PROMPT is the string to display to ask the question. It should end in
2593 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2595 The user must confirm the answer with RET, and can edit it until it
2598 If dialog boxes are supported, a dialog box will be used
2599 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2600 (Lisp_Object prompt
)
2604 CHECK_STRING (prompt
);
2606 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2607 && use_dialog_box
&& ! NILP (last_input_event
))
2609 Lisp_Object pane
, menu
, obj
;
2610 redisplay_preserve_echo_area (4);
2611 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2612 Fcons (build_string ("No"), Qnil
));
2613 menu
= Fcons (prompt
, pane
);
2614 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2618 AUTO_STRING (yes_or_no
, "(yes or no) ");
2619 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2623 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2624 Qyes_or_no_p_history
, Qnil
,
2626 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2628 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2633 message1 ("Please answer yes or no.");
2634 Fsleep_for (make_number (2), Qnil
);
2638 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2639 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2641 Each of the three load averages is multiplied by 100, then converted
2644 When USE-FLOATS is non-nil, floats will be used instead of integers.
2645 These floats are not multiplied by 100.
2647 If the 5-minute or 15-minute load averages are not available, return a
2648 shortened list, containing only those averages which are available.
2650 An error is thrown if the load average can't be obtained. In some
2651 cases making it work would require Emacs being installed setuid or
2652 setgid so that it can read kernel information, and that usually isn't
2654 (Lisp_Object use_floats
)
2657 int loads
= getloadavg (load_ave
, 3);
2658 Lisp_Object ret
= Qnil
;
2661 error ("load-average not implemented for this operating system");
2665 Lisp_Object load
= (NILP (use_floats
)
2666 ? make_number (100.0 * load_ave
[loads
])
2667 : make_float (load_ave
[loads
]));
2668 ret
= Fcons (load
, ret
);
2674 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2675 doc
: /* Return t if FEATURE is present in this Emacs.
2677 Use this to conditionalize execution of lisp code based on the
2678 presence or absence of Emacs or environment extensions.
2679 Use `provide' to declare that a feature is available. This function
2680 looks at the value of the variable `features'. The optional argument
2681 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2682 (Lisp_Object feature
, Lisp_Object subfeature
)
2684 register Lisp_Object tem
;
2685 CHECK_SYMBOL (feature
);
2686 tem
= Fmemq (feature
, Vfeatures
);
2687 if (!NILP (tem
) && !NILP (subfeature
))
2688 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2689 return (NILP (tem
)) ? Qnil
: Qt
;
2692 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2693 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2694 The optional argument SUBFEATURES should be a list of symbols listing
2695 particular subfeatures supported in this version of FEATURE. */)
2696 (Lisp_Object feature
, Lisp_Object subfeatures
)
2698 register Lisp_Object tem
;
2699 CHECK_SYMBOL (feature
);
2700 CHECK_LIST (subfeatures
);
2701 if (!NILP (Vautoload_queue
))
2702 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2704 tem
= Fmemq (feature
, Vfeatures
);
2706 Vfeatures
= Fcons (feature
, Vfeatures
);
2707 if (!NILP (subfeatures
))
2708 Fput (feature
, Qsubfeatures
, subfeatures
);
2709 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2711 /* Run any load-hooks for this file. */
2712 tem
= Fassq (feature
, Vafter_load_alist
);
2714 Fmapc (Qfuncall
, XCDR (tem
));
2719 /* `require' and its subroutines. */
2721 /* List of features currently being require'd, innermost first. */
2723 static Lisp_Object require_nesting_list
;
2726 require_unwind (Lisp_Object old_value
)
2728 require_nesting_list
= old_value
;
2731 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2732 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2733 If FEATURE is not a member of the list `features', then the feature is
2734 not loaded; so load the file FILENAME.
2736 If FILENAME is omitted, the printname of FEATURE is used as the file
2737 name, and `load' will try to load this name appended with the suffix
2738 `.elc', `.el', or the system-dependent suffix for dynamic module
2739 files, in that order. The name without appended suffix will not be
2740 used. See `get-load-suffixes' for the complete list of suffixes.
2742 The directories in `load-path' are searched when trying to find the
2745 If the optional third argument NOERROR is non-nil, then return nil if
2746 the file is not found instead of signaling an error. Normally the
2747 return value is FEATURE.
2749 The normal messages at start and end of loading FILENAME are
2751 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2754 bool from_file
= load_in_progress
;
2756 CHECK_SYMBOL (feature
);
2758 /* Record the presence of `require' in this file
2759 even if the feature specified is already loaded.
2760 But not more than once in any file,
2761 and not when we aren't loading or reading from a file. */
2763 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2764 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2769 tem
= Fcons (Qrequire
, feature
);
2770 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2771 LOADHIST_ATTACH (tem
);
2773 tem
= Fmemq (feature
, Vfeatures
);
2777 ptrdiff_t count
= SPECPDL_INDEX ();
2780 /* This is to make sure that loadup.el gives a clear picture
2781 of what files are preloaded and when. */
2782 if (! NILP (Vpurify_flag
))
2783 error ("(require %s) while preparing to dump",
2784 SDATA (SYMBOL_NAME (feature
)));
2786 /* A certain amount of recursive `require' is legitimate,
2787 but if we require the same feature recursively 3 times,
2789 tem
= require_nesting_list
;
2790 while (! NILP (tem
))
2792 if (! NILP (Fequal (feature
, XCAR (tem
))))
2797 error ("Recursive `require' for feature `%s'",
2798 SDATA (SYMBOL_NAME (feature
)));
2800 /* Update the list for any nested `require's that occur. */
2801 record_unwind_protect (require_unwind
, require_nesting_list
);
2802 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2804 /* Value saved here is to be restored into Vautoload_queue */
2805 record_unwind_protect (un_autoload
, Vautoload_queue
);
2806 Vautoload_queue
= Qt
;
2808 /* Load the file. */
2809 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2810 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2812 /* If load failed entirely, return nil. */
2814 return unbind_to (count
, Qnil
);
2816 tem
= Fmemq (feature
, Vfeatures
);
2819 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
2820 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
2823 error ("Required feature `%s' was not provided", tem2
);
2825 /* Cf autoload-do-load. */
2826 error ("Loading file %s failed to provide feature `%s'",
2827 SDATA (tem3
), tem2
);
2830 /* Once loading finishes, don't undo it. */
2831 Vautoload_queue
= Qt
;
2832 feature
= unbind_to (count
, feature
);
2838 /* Primitives for work of the "widget" library.
2839 In an ideal world, this section would not have been necessary.
2840 However, lisp function calls being as slow as they are, it turns
2841 out that some functions in the widget library (wid-edit.el) are the
2842 bottleneck of Widget operation. Here is their translation to C,
2843 for the sole reason of efficiency. */
2845 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2846 doc
: /* Return non-nil if PLIST has the property PROP.
2847 PLIST is a property list, which is a list of the form
2848 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2849 Unlike `plist-get', this allows you to distinguish between a missing
2850 property and a property with the value nil.
2851 The value is actually the tail of PLIST whose car is PROP. */)
2852 (Lisp_Object plist
, Lisp_Object prop
)
2854 Lisp_Object tail
= plist
;
2855 FOR_EACH_TAIL (tail
)
2857 if (EQ (XCAR (tail
), prop
))
2862 if (EQ (tail
, li
.tortoise
))
2863 circular_list (tail
);
2865 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2869 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2870 doc
: /* In WIDGET, set PROPERTY to VALUE.
2871 The value can later be retrieved with `widget-get'. */)
2872 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2874 CHECK_CONS (widget
);
2875 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2879 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2880 doc
: /* In WIDGET, get the value of PROPERTY.
2881 The value could either be specified when the widget was created, or
2882 later with `widget-put'. */)
2883 (Lisp_Object widget
, Lisp_Object property
)
2891 CHECK_CONS (widget
);
2892 tmp
= Fplist_member (XCDR (widget
), property
);
2898 tmp
= XCAR (widget
);
2901 widget
= Fget (tmp
, Qwidget_type
);
2905 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2906 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2907 ARGS are passed as extra arguments to the function.
2908 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2909 (ptrdiff_t nargs
, Lisp_Object
*args
)
2911 Lisp_Object widget
= args
[0];
2912 Lisp_Object property
= args
[1];
2913 Lisp_Object propval
= Fwidget_get (widget
, property
);
2914 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2915 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2919 #ifdef HAVE_LANGINFO_CODESET
2920 #include <langinfo.h>
2923 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2924 doc
: /* Access locale data ITEM for the current C locale, if available.
2925 ITEM should be one of the following:
2927 `codeset', returning the character set as a string (locale item CODESET);
2929 `days', returning a 7-element vector of day names (locale items DAY_n);
2931 `months', returning a 12-element vector of month names (locale items MON_n);
2933 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2934 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2936 If the system can't provide such information through a call to
2937 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2939 See also Info node `(libc)Locales'.
2941 The data read from the system are decoded using `locale-coding-system'. */)
2945 #ifdef HAVE_LANGINFO_CODESET
2946 if (EQ (item
, Qcodeset
))
2948 str
= nl_langinfo (CODESET
);
2949 return build_string (str
);
2952 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2954 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2955 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2957 synchronize_system_time_locale ();
2958 for (i
= 0; i
< 7; i
++)
2960 str
= nl_langinfo (days
[i
]);
2961 AUTO_STRING (val
, str
);
2962 /* Fixme: Is this coding system necessarily right, even if
2963 it is consistent with CODESET? If not, what to do? */
2964 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2971 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2973 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2974 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2975 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2977 synchronize_system_time_locale ();
2978 for (i
= 0; i
< 12; i
++)
2980 str
= nl_langinfo (months
[i
]);
2981 AUTO_STRING (val
, str
);
2982 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2988 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2989 but is in the locale files. This could be used by ps-print. */
2991 else if (EQ (item
, Qpaper
))
2992 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2993 #endif /* PAPER_WIDTH */
2994 #endif /* HAVE_LANGINFO_CODESET*/
2998 /* base64 encode/decode functions (RFC 2045).
2999 Based on code from GNU recode. */
3001 #define MIME_LINE_LENGTH 76
3003 #define IS_ASCII(Character) \
3005 #define IS_BASE64(Character) \
3006 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3007 #define IS_BASE64_IGNORABLE(Character) \
3008 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3009 || (Character) == '\f' || (Character) == '\r')
3011 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3012 character or return retval if there are no characters left to
3014 #define READ_QUADRUPLET_BYTE(retval) \
3019 if (nchars_return) \
3020 *nchars_return = nchars; \
3025 while (IS_BASE64_IGNORABLE (c))
3027 /* Table of characters coding the 64 values. */
3028 static const char base64_value_to_char
[64] =
3030 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3031 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3032 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3033 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3034 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3035 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3036 '8', '9', '+', '/' /* 60-63 */
3039 /* Table of base64 values for first 128 characters. */
3040 static const short base64_char_to_value
[128] =
3042 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3043 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3044 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3045 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3046 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3047 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3048 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3049 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3050 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3051 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3052 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3053 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3054 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3057 /* The following diagram shows the logical steps by which three octets
3058 get transformed into four base64 characters.
3060 .--------. .--------. .--------.
3061 |aaaaaabb| |bbbbcccc| |ccdddddd|
3062 `--------' `--------' `--------'
3064 .--------+--------+--------+--------.
3065 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3066 `--------+--------+--------+--------'
3068 .--------+--------+--------+--------.
3069 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3070 `--------+--------+--------+--------'
3072 The octets are divided into 6 bit chunks, which are then encoded into
3073 base64 characters. */
3076 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3077 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3080 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3082 doc
: /* Base64-encode the region between BEG and END.
3083 Return the length of the encoded text.
3084 Optional third argument NO-LINE-BREAK means do not break long lines
3085 into shorter lines. */)
3086 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3089 ptrdiff_t allength
, length
;
3090 ptrdiff_t ibeg
, iend
, encoded_length
;
3091 ptrdiff_t old_pos
= PT
;
3094 validate_region (&beg
, &end
);
3096 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3097 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3098 move_gap_both (XFASTINT (beg
), ibeg
);
3100 /* We need to allocate enough room for encoding the text.
3101 We need 33 1/3% more space, plus a newline every 76
3102 characters, and then we round up. */
3103 length
= iend
- ibeg
;
3104 allength
= length
+ length
/3 + 1;
3105 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3107 encoded
= SAFE_ALLOCA (allength
);
3108 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3109 encoded
, length
, NILP (no_line_break
),
3110 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3111 if (encoded_length
> allength
)
3114 if (encoded_length
< 0)
3116 /* The encoding wasn't possible. */
3118 error ("Multibyte character in data for base64 encoding");
3121 /* Now we have encoded the region, so we insert the new contents
3122 and delete the old. (Insert first in order to preserve markers.) */
3123 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3124 insert (encoded
, encoded_length
);
3126 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3128 /* If point was outside of the region, restore it exactly; else just
3129 move to the beginning of the region. */
3130 if (old_pos
>= XFASTINT (end
))
3131 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3132 else if (old_pos
> XFASTINT (beg
))
3133 old_pos
= XFASTINT (beg
);
3136 /* We return the length of the encoded text. */
3137 return make_number (encoded_length
);
3140 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3142 doc
: /* Base64-encode STRING and return the result.
3143 Optional second argument NO-LINE-BREAK means do not break long lines
3144 into shorter lines. */)
3145 (Lisp_Object string
, Lisp_Object no_line_break
)
3147 ptrdiff_t allength
, length
, encoded_length
;
3149 Lisp_Object encoded_string
;
3152 CHECK_STRING (string
);
3154 /* We need to allocate enough room for encoding the text.
3155 We need 33 1/3% more space, plus a newline every 76
3156 characters, and then we round up. */
3157 length
= SBYTES (string
);
3158 allength
= length
+ length
/3 + 1;
3159 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3161 /* We need to allocate enough room for decoding the text. */
3162 encoded
= SAFE_ALLOCA (allength
);
3164 encoded_length
= base64_encode_1 (SSDATA (string
),
3165 encoded
, length
, NILP (no_line_break
),
3166 STRING_MULTIBYTE (string
));
3167 if (encoded_length
> allength
)
3170 if (encoded_length
< 0)
3172 /* The encoding wasn't possible. */
3173 error ("Multibyte character in data for base64 encoding");
3176 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3179 return encoded_string
;
3183 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3184 bool line_break
, bool multibyte
)
3197 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3198 if (CHAR_BYTE8_P (c
))
3199 c
= CHAR_TO_BYTE8 (c
);
3207 /* Wrap line every 76 characters. */
3211 if (counter
< MIME_LINE_LENGTH
/ 4)
3220 /* Process first byte of a triplet. */
3222 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3223 value
= (0x03 & c
) << 4;
3225 /* Process second byte of a triplet. */
3229 *e
++ = base64_value_to_char
[value
];
3237 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3238 if (CHAR_BYTE8_P (c
))
3239 c
= CHAR_TO_BYTE8 (c
);
3247 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3248 value
= (0x0f & c
) << 2;
3250 /* Process third byte of a triplet. */
3254 *e
++ = base64_value_to_char
[value
];
3261 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3262 if (CHAR_BYTE8_P (c
))
3263 c
= CHAR_TO_BYTE8 (c
);
3271 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3272 *e
++ = base64_value_to_char
[0x3f & c
];
3279 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3281 doc
: /* Base64-decode the region between BEG and END.
3282 Return the length of the decoded text.
3283 If the region can't be decoded, signal an error and don't modify the buffer. */)
3284 (Lisp_Object beg
, Lisp_Object end
)
3286 ptrdiff_t ibeg
, iend
, length
, allength
;
3288 ptrdiff_t old_pos
= PT
;
3289 ptrdiff_t decoded_length
;
3290 ptrdiff_t inserted_chars
;
3291 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3294 validate_region (&beg
, &end
);
3296 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3297 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3299 length
= iend
- ibeg
;
3301 /* We need to allocate enough room for decoding the text. If we are
3302 working on a multibyte buffer, each decoded code may occupy at
3304 allength
= multibyte
? length
* 2 : length
;
3305 decoded
= SAFE_ALLOCA (allength
);
3307 move_gap_both (XFASTINT (beg
), ibeg
);
3308 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3310 multibyte
, &inserted_chars
);
3311 if (decoded_length
> allength
)
3314 if (decoded_length
< 0)
3316 /* The decoding wasn't possible. */
3317 error ("Invalid base64 data");
3320 /* Now we have decoded the region, so we insert the new contents
3321 and delete the old. (Insert first in order to preserve markers.) */
3322 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3323 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3326 /* Delete the original text. */
3327 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3328 iend
+ decoded_length
, 1);
3330 /* If point was outside of the region, restore it exactly; else just
3331 move to the beginning of the region. */
3332 if (old_pos
>= XFASTINT (end
))
3333 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3334 else if (old_pos
> XFASTINT (beg
))
3335 old_pos
= XFASTINT (beg
);
3336 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3338 return make_number (inserted_chars
);
3341 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3343 doc
: /* Base64-decode STRING and return the result. */)
3344 (Lisp_Object string
)
3347 ptrdiff_t length
, decoded_length
;
3348 Lisp_Object decoded_string
;
3351 CHECK_STRING (string
);
3353 length
= SBYTES (string
);
3354 /* We need to allocate enough room for decoding the text. */
3355 decoded
= SAFE_ALLOCA (length
);
3357 /* The decoded result should be unibyte. */
3358 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3360 if (decoded_length
> length
)
3362 else if (decoded_length
>= 0)
3363 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3365 decoded_string
= Qnil
;
3368 if (!STRINGP (decoded_string
))
3369 error ("Invalid base64 data");
3371 return decoded_string
;
3374 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3375 MULTIBYTE, the decoded result should be in multibyte
3376 form. If NCHARS_RETURN is not NULL, store the number of produced
3377 characters in *NCHARS_RETURN. */
3380 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3381 bool multibyte
, ptrdiff_t *nchars_return
)
3383 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3386 unsigned long value
;
3387 ptrdiff_t nchars
= 0;
3391 /* Process first byte of a quadruplet. */
3393 READ_QUADRUPLET_BYTE (e
-to
);
3397 value
= base64_char_to_value
[c
] << 18;
3399 /* Process second byte of a quadruplet. */
3401 READ_QUADRUPLET_BYTE (-1);
3405 value
|= base64_char_to_value
[c
] << 12;
3407 c
= (unsigned char) (value
>> 16);
3408 if (multibyte
&& c
>= 128)
3409 e
+= BYTE8_STRING (c
, e
);
3414 /* Process third byte of a quadruplet. */
3416 READ_QUADRUPLET_BYTE (-1);
3420 READ_QUADRUPLET_BYTE (-1);
3429 value
|= base64_char_to_value
[c
] << 6;
3431 c
= (unsigned char) (0xff & value
>> 8);
3432 if (multibyte
&& c
>= 128)
3433 e
+= BYTE8_STRING (c
, e
);
3438 /* Process fourth byte of a quadruplet. */
3440 READ_QUADRUPLET_BYTE (-1);
3447 value
|= base64_char_to_value
[c
];
3449 c
= (unsigned char) (0xff & value
);
3450 if (multibyte
&& c
>= 128)
3451 e
+= BYTE8_STRING (c
, e
);
3460 /***********************************************************************
3462 ***** Hash Tables *****
3464 ***********************************************************************/
3466 /* Implemented by gerd@gnu.org. This hash table implementation was
3467 inspired by CMUCL hash tables. */
3471 1. For small tables, association lists are probably faster than
3472 hash tables because they have lower overhead.
3474 For uses of hash tables where the O(1) behavior of table
3475 operations is not a requirement, it might therefore be a good idea
3476 not to hash. Instead, we could just do a linear search in the
3477 key_and_value vector of the hash table. This could be done
3478 if a `:linear-search t' argument is given to make-hash-table. */
3481 /* The list of all weak hash tables. Don't staticpro this one. */
3483 static struct Lisp_Hash_Table
*weak_hash_tables
;
3486 /***********************************************************************
3488 ***********************************************************************/
3491 CHECK_HASH_TABLE (Lisp_Object x
)
3493 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3497 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3499 h
->key_and_value
= key_and_value
;
3502 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3507 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3509 gc_aset (h
->next
, idx
, make_number (val
));
3512 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3517 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3519 gc_aset (h
->hash
, idx
, val
);
3522 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3527 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3529 gc_aset (h
->index
, idx
, make_number (val
));
3532 /* If OBJ is a Lisp hash table, return a pointer to its struct
3533 Lisp_Hash_Table. Otherwise, signal an error. */
3535 static struct Lisp_Hash_Table
*
3536 check_hash_table (Lisp_Object obj
)
3538 CHECK_HASH_TABLE (obj
);
3539 return XHASH_TABLE (obj
);
3543 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3544 number. A number is "almost" a prime number if it is not divisible
3545 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3548 next_almost_prime (EMACS_INT n
)
3550 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3551 for (n
|= 1; ; n
+= 2)
3552 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3557 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3558 which USED[I] is non-zero. If found at index I in ARGS, set
3559 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3560 0. This function is used to extract a keyword/argument pair from
3561 a DEFUN parameter list. */
3564 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3568 for (i
= 1; i
< nargs
; i
++)
3569 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3580 /* Return a Lisp vector which has the same contents as VEC but has
3581 at least INCR_MIN more entries, where INCR_MIN is positive.
3582 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3583 than NITEMS_MAX. New entries in the resulting vector are
3587 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3589 struct Lisp_Vector
*v
;
3590 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3591 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3592 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3593 ? nitems_max
: C_language_max
);
3594 eassert (VECTORP (vec
));
3595 eassert (0 < incr_min
&& -1 <= nitems_max
);
3596 old_size
= ASIZE (vec
);
3597 incr_max
= n_max
- old_size
;
3598 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3599 if (incr_max
< incr
)
3600 memory_full (SIZE_MAX
);
3601 new_size
= old_size
+ incr
;
3602 v
= allocate_vector (new_size
);
3603 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3604 XSETVECTOR (vec
, v
);
3608 /* Likewise, except set new entries in the resulting vector to nil. */
3611 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3613 ptrdiff_t old_size
= ASIZE (vec
);
3614 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3615 ptrdiff_t new_size
= ASIZE (v
);
3616 memclear (XVECTOR (v
)->contents
+ old_size
,
3617 (new_size
- old_size
) * word_size
);
3622 /***********************************************************************
3624 ***********************************************************************/
3626 /* Return the index of the next entry in H following the one at IDX,
3630 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3632 return XINT (AREF (h
->next
, idx
));
3635 /* Return the index of the element in hash table H that is the start
3636 of the collision list at index IDX, or -1 if the list is empty. */
3639 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3641 return XINT (AREF (h
->index
, idx
));
3644 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3645 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3646 KEY2 are the same. */
3649 cmpfn_eql (struct hash_table_test
*ht
,
3653 return (FLOATP (key1
)
3655 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3659 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3660 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3661 KEY2 are the same. */
3664 cmpfn_equal (struct hash_table_test
*ht
,
3668 return !NILP (Fequal (key1
, key2
));
3672 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3673 HASH2 in hash table H using H->user_cmp_function. Value is true
3674 if KEY1 and KEY2 are the same. */
3677 cmpfn_user_defined (struct hash_table_test
*ht
,
3681 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3684 /* Value is a hash code for KEY for use in hash table H which uses
3685 `eq' to compare keys. The hash code returned is guaranteed to fit
3686 in a Lisp integer. */
3689 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3691 return XHASH (key
) ^ XTYPE (key
);
3694 /* Value is a hash code for KEY for use in hash table H which uses
3695 `equal' to compare keys. The hash code returned is guaranteed to fit
3696 in a Lisp integer. */
3699 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3701 return sxhash (key
, 0);
3704 /* Value is a hash code for KEY for use in hash table H which uses
3705 `eql' to compare keys. The hash code returned is guaranteed to fit
3706 in a Lisp integer. */
3709 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3711 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3714 /* Value is a hash code for KEY for use in hash table H which uses as
3715 user-defined function to compare keys. The hash code returned is
3716 guaranteed to fit in a Lisp integer. */
3719 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3721 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3722 return hashfn_eq (ht
, hash
);
3725 struct hash_table_test
const
3726 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3727 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3728 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3729 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3730 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3731 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3733 /* Allocate basically initialized hash table. */
3735 static struct Lisp_Hash_Table
*
3736 allocate_hash_table (void)
3738 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3739 count
, PVEC_HASH_TABLE
);
3742 /* An upper bound on the size of a hash table index. It must fit in
3743 ptrdiff_t and be a valid Emacs fixnum. */
3744 #define INDEX_SIZE_BOUND \
3745 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3747 /* Create and initialize a new hash table.
3749 TEST specifies the test the hash table will use to compare keys.
3750 It must be either one of the predefined tests `eq', `eql' or
3751 `equal' or a symbol denoting a user-defined test named TEST with
3752 test and hash functions USER_TEST and USER_HASH.
3754 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3756 If REHASH_SIZE is equal to a negative integer, this hash table's
3757 new size when it becomes full is computed by subtracting
3758 REHASH_SIZE from its old size. Otherwise it must be positive, and
3759 the table's new size is computed by multiplying its old size by
3762 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3763 be resized when the approximate ratio of table entries to table
3764 size exceeds REHASH_THRESHOLD.
3766 WEAK specifies the weakness of the table. If non-nil, it must be
3767 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3769 If PURECOPY is non-nil, the table can be copied to pure storage via
3770 `purecopy' when Emacs is being dumped. Such tables can no longer be
3771 changed after purecopy. */
3774 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
3775 float rehash_size
, float rehash_threshold
,
3776 Lisp_Object weak
, bool pure
)
3778 struct Lisp_Hash_Table
*h
;
3780 EMACS_INT index_size
;
3784 /* Preconditions. */
3785 eassert (SYMBOLP (test
.name
));
3786 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
3787 eassert (rehash_size
<= -1 || 0 < rehash_size
);
3788 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
3793 double threshold
= rehash_threshold
;
3794 index_float
= size
/ threshold
;
3795 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3796 ? next_almost_prime (index_float
)
3797 : INDEX_SIZE_BOUND
+ 1);
3798 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * size
))
3799 error ("Hash table too large");
3801 /* Allocate a table and initialize it. */
3802 h
= allocate_hash_table ();
3804 /* Initialize hash table slots. */
3807 h
->rehash_threshold
= rehash_threshold
;
3808 h
->rehash_size
= rehash_size
;
3810 h
->key_and_value
= Fmake_vector (make_number (2 * size
), Qnil
);
3811 h
->hash
= Fmake_vector (make_number (size
), Qnil
);
3812 h
->next
= Fmake_vector (make_number (size
), make_number (-1));
3813 h
->index
= Fmake_vector (make_number (index_size
), make_number (-1));
3816 /* Set up the free list. */
3817 for (i
= 0; i
< size
- 1; ++i
)
3818 set_hash_next_slot (h
, i
, i
+ 1);
3821 XSET_HASH_TABLE (table
, h
);
3822 eassert (HASH_TABLE_P (table
));
3823 eassert (XHASH_TABLE (table
) == h
);
3825 /* Maybe add this hash table to the list of all weak hash tables. */
3828 h
->next_weak
= weak_hash_tables
;
3829 weak_hash_tables
= h
;
3836 /* Return a copy of hash table H1. Keys and values are not copied,
3837 only the table itself is. */
3840 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3843 struct Lisp_Hash_Table
*h2
;
3845 h2
= allocate_hash_table ();
3847 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3848 h2
->hash
= Fcopy_sequence (h1
->hash
);
3849 h2
->next
= Fcopy_sequence (h1
->next
);
3850 h2
->index
= Fcopy_sequence (h1
->index
);
3851 XSET_HASH_TABLE (table
, h2
);
3853 /* Maybe add this hash table to the list of all weak hash tables. */
3854 if (!NILP (h2
->weak
))
3856 h2
->next_weak
= h1
->next_weak
;
3864 /* Resize hash table H if it's too full. If H cannot be resized
3865 because it's already too large, throw an error. */
3868 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3870 if (h
->next_free
< 0)
3872 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3873 EMACS_INT new_size
, index_size
, nsize
;
3875 double rehash_size
= h
->rehash_size
;
3878 if (rehash_size
< 0)
3879 new_size
= old_size
- rehash_size
;
3882 double float_new_size
= old_size
* (rehash_size
+ 1);
3883 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3884 new_size
= float_new_size
;
3886 new_size
= INDEX_SIZE_BOUND
+ 1;
3888 if (new_size
<= old_size
)
3889 new_size
= old_size
+ 1;
3890 double threshold
= h
->rehash_threshold
;
3891 index_float
= new_size
/ threshold
;
3892 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3893 ? next_almost_prime (index_float
)
3894 : INDEX_SIZE_BOUND
+ 1);
3895 nsize
= max (index_size
, 2 * new_size
);
3896 if (INDEX_SIZE_BOUND
< nsize
)
3897 error ("Hash table too large to resize");
3899 #ifdef ENABLE_CHECKING
3900 if (HASH_TABLE_P (Vpurify_flag
)
3901 && XHASH_TABLE (Vpurify_flag
) == h
)
3902 message ("Growing hash table to: %"pI
"d", new_size
);
3905 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3906 2 * (new_size
- old_size
), -1));
3907 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3908 set_hash_index (h
, Fmake_vector (make_number (index_size
),
3910 set_hash_next (h
, larger_vecalloc (h
->next
, new_size
- old_size
, -1));
3912 /* Update the free list. Do it so that new entries are added at
3913 the end of the free list. This makes some operations like
3915 for (i
= old_size
; i
< new_size
- 1; ++i
)
3916 set_hash_next_slot (h
, i
, i
+ 1);
3917 set_hash_next_slot (h
, i
, -1);
3919 if (h
->next_free
< 0)
3920 h
->next_free
= old_size
;
3923 ptrdiff_t last
= h
->next_free
;
3926 ptrdiff_t next
= HASH_NEXT (h
, last
);
3931 set_hash_next_slot (h
, last
, old_size
);
3935 for (i
= 0; i
< old_size
; ++i
)
3936 if (!NILP (HASH_HASH (h
, i
)))
3938 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3939 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3940 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3941 set_hash_index_slot (h
, start_of_bucket
, i
);
3947 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3948 the hash code of KEY. Value is the index of the entry in H
3949 matching KEY, or -1 if not found. */
3952 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3954 EMACS_UINT hash_code
;
3955 ptrdiff_t start_of_bucket
, i
;
3957 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3958 eassert ((hash_code
& ~INTMASK
) == 0);
3962 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3964 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
3965 if (EQ (key
, HASH_KEY (h
, i
))
3967 && hash_code
== XUINT (HASH_HASH (h
, i
))
3968 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3975 /* Put an entry into hash table H that associates KEY with VALUE.
3976 HASH is a previously computed hash code of KEY.
3977 Value is the index of the entry in H matching KEY. */
3980 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3983 ptrdiff_t start_of_bucket
, i
;
3985 eassert ((hash
& ~INTMASK
) == 0);
3987 /* Increment count after resizing because resizing may fail. */
3988 maybe_resize_hash_table (h
);
3991 /* Store key/value in the key_and_value vector. */
3993 h
->next_free
= HASH_NEXT (h
, i
);
3994 set_hash_key_slot (h
, i
, key
);
3995 set_hash_value_slot (h
, i
, value
);
3997 /* Remember its hash code. */
3998 set_hash_hash_slot (h
, i
, make_number (hash
));
4000 /* Add new entry to its collision chain. */
4001 start_of_bucket
= hash
% ASIZE (h
->index
);
4002 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4003 set_hash_index_slot (h
, start_of_bucket
, i
);
4008 /* Remove the entry matching KEY from hash table H, if there is one. */
4011 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4013 EMACS_UINT hash_code
= h
->test
.hashfn (&h
->test
, key
);
4014 eassert ((hash_code
& ~INTMASK
) == 0);
4015 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4016 ptrdiff_t prev
= -1;
4018 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4020 i
= HASH_NEXT (h
, i
))
4022 if (EQ (key
, HASH_KEY (h
, i
))
4024 && hash_code
== XUINT (HASH_HASH (h
, i
))
4025 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4027 /* Take entry out of collision chain. */
4029 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4031 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4033 /* Clear slots in key_and_value and add the slots to
4035 set_hash_key_slot (h
, i
, Qnil
);
4036 set_hash_value_slot (h
, i
, Qnil
);
4037 set_hash_hash_slot (h
, i
, Qnil
);
4038 set_hash_next_slot (h
, i
, h
->next_free
);
4041 eassert (h
->count
>= 0);
4050 /* Clear hash table H. */
4053 hash_clear (struct Lisp_Hash_Table
*h
)
4057 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4059 for (i
= 0; i
< size
; ++i
)
4061 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4062 set_hash_key_slot (h
, i
, Qnil
);
4063 set_hash_value_slot (h
, i
, Qnil
);
4064 set_hash_hash_slot (h
, i
, Qnil
);
4067 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4068 ASET (h
->index
, i
, make_number (-1));
4077 /************************************************************************
4079 ************************************************************************/
4081 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4082 entries from the table that don't survive the current GC.
4083 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4084 true if anything was marked. */
4087 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4089 ptrdiff_t n
= gc_asize (h
->index
);
4090 bool marked
= false;
4092 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4094 /* Follow collision chain, removing entries that
4095 don't survive this garbage collection. */
4096 ptrdiff_t prev
= -1;
4098 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4100 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4101 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4104 if (EQ (h
->weak
, Qkey
))
4105 remove_p
= !key_known_to_survive_p
;
4106 else if (EQ (h
->weak
, Qvalue
))
4107 remove_p
= !value_known_to_survive_p
;
4108 else if (EQ (h
->weak
, Qkey_or_value
))
4109 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4110 else if (EQ (h
->weak
, Qkey_and_value
))
4111 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4115 next
= HASH_NEXT (h
, i
);
4117 if (remove_entries_p
)
4121 /* Take out of collision chain. */
4123 set_hash_index_slot (h
, bucket
, next
);
4125 set_hash_next_slot (h
, prev
, next
);
4127 /* Add to free list. */
4128 set_hash_next_slot (h
, i
, h
->next_free
);
4131 /* Clear key, value, and hash. */
4132 set_hash_key_slot (h
, i
, Qnil
);
4133 set_hash_value_slot (h
, i
, Qnil
);
4134 set_hash_hash_slot (h
, i
, Qnil
);
4147 /* Make sure key and value survive. */
4148 if (!key_known_to_survive_p
)
4150 mark_object (HASH_KEY (h
, i
));
4154 if (!value_known_to_survive_p
)
4156 mark_object (HASH_VALUE (h
, i
));
4167 /* Remove elements from weak hash tables that don't survive the
4168 current garbage collection. Remove weak tables that don't survive
4169 from Vweak_hash_tables. Called from gc_sweep. */
4171 NO_INLINE
/* For better stack traces */
4173 sweep_weak_hash_tables (void)
4175 struct Lisp_Hash_Table
*h
, *used
, *next
;
4178 /* Mark all keys and values that are in use. Keep on marking until
4179 there is no more change. This is necessary for cases like
4180 value-weak table A containing an entry X -> Y, where Y is used in a
4181 key-weak table B, Z -> Y. If B comes after A in the list of weak
4182 tables, X -> Y might be removed from A, although when looking at B
4183 one finds that it shouldn't. */
4187 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4189 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4190 marked
|= sweep_weak_table (h
, 0);
4195 /* Remove tables and entries that aren't used. */
4196 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4198 next
= h
->next_weak
;
4200 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4202 /* TABLE is marked as used. Sweep its contents. */
4204 sweep_weak_table (h
, 1);
4206 /* Add table to the list of used weak hash tables. */
4207 h
->next_weak
= used
;
4212 weak_hash_tables
= used
;
4217 /***********************************************************************
4218 Hash Code Computation
4219 ***********************************************************************/
4221 /* Maximum depth up to which to dive into Lisp structures. */
4223 #define SXHASH_MAX_DEPTH 3
4225 /* Maximum length up to which to take list and vector elements into
4228 #define SXHASH_MAX_LEN 7
4230 /* Return a hash for string PTR which has length LEN. The hash value
4231 can be any EMACS_UINT value. */
4234 hash_string (char const *ptr
, ptrdiff_t len
)
4236 char const *p
= ptr
;
4237 char const *end
= p
+ len
;
4239 EMACS_UINT hash
= 0;
4244 hash
= sxhash_combine (hash
, c
);
4250 /* Return a hash for string PTR which has length LEN. The hash
4251 code returned is guaranteed to fit in a Lisp integer. */
4254 sxhash_string (char const *ptr
, ptrdiff_t len
)
4256 EMACS_UINT hash
= hash_string (ptr
, len
);
4257 return SXHASH_REDUCE (hash
);
4260 /* Return a hash for the floating point value VAL. */
4263 sxhash_float (double val
)
4265 EMACS_UINT hash
= 0;
4267 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4268 + (sizeof val
% sizeof hash
!= 0))
4272 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4276 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4277 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4278 hash
= sxhash_combine (hash
, u
.word
[i
]);
4279 return SXHASH_REDUCE (hash
);
4282 /* Return a hash for list LIST. DEPTH is the current depth in the
4283 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4286 sxhash_list (Lisp_Object list
, int depth
)
4288 EMACS_UINT hash
= 0;
4291 if (depth
< SXHASH_MAX_DEPTH
)
4293 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4294 list
= XCDR (list
), ++i
)
4296 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4297 hash
= sxhash_combine (hash
, hash2
);
4302 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4303 hash
= sxhash_combine (hash
, hash2
);
4306 return SXHASH_REDUCE (hash
);
4310 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4311 the Lisp structure. */
4314 sxhash_vector (Lisp_Object vec
, int depth
)
4316 EMACS_UINT hash
= ASIZE (vec
);
4319 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4320 for (i
= 0; i
< n
; ++i
)
4322 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4323 hash
= sxhash_combine (hash
, hash2
);
4326 return SXHASH_REDUCE (hash
);
4329 /* Return a hash for bool-vector VECTOR. */
4332 sxhash_bool_vector (Lisp_Object vec
)
4334 EMACS_INT size
= bool_vector_size (vec
);
4335 EMACS_UINT hash
= size
;
4338 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4339 for (i
= 0; i
< n
; ++i
)
4340 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4342 return SXHASH_REDUCE (hash
);
4346 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4347 structure. Value is an unsigned integer clipped to INTMASK. */
4350 sxhash (Lisp_Object obj
, int depth
)
4354 if (depth
> SXHASH_MAX_DEPTH
)
4357 switch (XTYPE (obj
))
4369 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4372 /* This can be everything from a vector to an overlay. */
4373 case Lisp_Vectorlike
:
4374 if (VECTORP (obj
) || RECORDP (obj
))
4375 /* According to the CL HyperSpec, two arrays are equal only if
4376 they are `eq', except for strings and bit-vectors. In
4377 Emacs, this works differently. We have to compare element
4378 by element. Same for records. */
4379 hash
= sxhash_vector (obj
, depth
);
4380 else if (BOOL_VECTOR_P (obj
))
4381 hash
= sxhash_bool_vector (obj
);
4383 /* Others are `equal' if they are `eq', so let's take their
4389 hash
= sxhash_list (obj
, depth
);
4393 hash
= sxhash_float (XFLOAT_DATA (obj
));
4405 /***********************************************************************
4407 ***********************************************************************/
4409 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4410 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4411 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4414 return make_number (hashfn_eq (NULL
, obj
));
4417 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4418 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4419 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4422 return make_number (hashfn_eql (NULL
, obj
));
4425 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4426 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4427 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4430 return make_number (hashfn_equal (NULL
, obj
));
4433 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4434 doc
: /* Create and return a new hash table.
4436 Arguments are specified as keyword/argument pairs. The following
4437 arguments are defined:
4439 :test TEST -- TEST must be a symbol that specifies how to compare
4440 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4441 `equal'. User-supplied test and hash functions can be specified via
4442 `define-hash-table-test'.
4444 :size SIZE -- A hint as to how many elements will be put in the table.
4447 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4448 fills up. If REHASH-SIZE is an integer, increase the size by that
4449 amount. If it is a float, it must be > 1.0, and the new size is the
4450 old size multiplied by that factor. Default is 1.5.
4452 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4453 Resize the hash table when the ratio (table entries / table size)
4454 exceeds an approximation to THRESHOLD. Default is 0.8125.
4456 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4457 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4458 returned is a weak table. Key/value pairs are removed from a weak
4459 hash table when there are no non-weak references pointing to their
4460 key, value, one of key or value, or both key and value, depending on
4461 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4464 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4465 to pure storage when Emacs is being dumped, making the contents of the
4466 table read only. Any further changes to purified tables will result
4469 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4470 (ptrdiff_t nargs
, Lisp_Object
*args
)
4472 Lisp_Object test
, weak
;
4474 struct hash_table_test testdesc
;
4478 /* The vector `used' is used to keep track of arguments that
4479 have been consumed. */
4480 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4481 memset (used
, 0, nargs
* sizeof *used
);
4483 /* See if there's a `:test TEST' among the arguments. */
4484 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4485 test
= i
? args
[i
] : Qeql
;
4487 testdesc
= hashtest_eq
;
4488 else if (EQ (test
, Qeql
))
4489 testdesc
= hashtest_eql
;
4490 else if (EQ (test
, Qequal
))
4491 testdesc
= hashtest_equal
;
4494 /* See if it is a user-defined test. */
4497 prop
= Fget (test
, Qhash_table_test
);
4498 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4499 signal_error ("Invalid hash table test", test
);
4500 testdesc
.name
= test
;
4501 testdesc
.user_cmp_function
= XCAR (prop
);
4502 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4503 testdesc
.hashfn
= hashfn_user_defined
;
4504 testdesc
.cmpfn
= cmpfn_user_defined
;
4507 /* See if there's a `:purecopy PURECOPY' argument. */
4508 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4509 pure
= i
&& !NILP (args
[i
]);
4510 /* See if there's a `:size SIZE' argument. */
4511 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4512 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4514 if (NILP (size_arg
))
4515 size
= DEFAULT_HASH_SIZE
;
4516 else if (NATNUMP (size_arg
))
4517 size
= XFASTINT (size_arg
);
4519 signal_error ("Invalid hash table size", size_arg
);
4521 /* Look for `:rehash-size SIZE'. */
4523 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4525 rehash_size
= DEFAULT_REHASH_SIZE
;
4526 else if (INTEGERP (args
[i
]) && 0 < XINT (args
[i
]))
4527 rehash_size
= - XINT (args
[i
]);
4528 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4529 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4531 signal_error ("Invalid hash table rehash size", args
[i
]);
4533 /* Look for `:rehash-threshold THRESHOLD'. */
4534 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4535 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4536 : !FLOATP (args
[i
]) ? 0
4537 : (float) XFLOAT_DATA (args
[i
]));
4538 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4539 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4541 /* Look for `:weakness WEAK'. */
4542 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4543 weak
= i
? args
[i
] : Qnil
;
4545 weak
= Qkey_and_value
;
4548 && !EQ (weak
, Qvalue
)
4549 && !EQ (weak
, Qkey_or_value
)
4550 && !EQ (weak
, Qkey_and_value
))
4551 signal_error ("Invalid hash table weakness", weak
);
4553 /* Now, all args should have been used up, or there's a problem. */
4554 for (i
= 0; i
< nargs
; ++i
)
4556 signal_error ("Invalid argument list", args
[i
]);
4559 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4564 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4565 doc
: /* Return a copy of hash table TABLE. */)
4568 return copy_hash_table (check_hash_table (table
));
4572 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4573 doc
: /* Return the number of elements in TABLE. */)
4576 return make_number (check_hash_table (table
)->count
);
4580 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4581 Shash_table_rehash_size
, 1, 1, 0,
4582 doc
: /* Return the current rehash size of TABLE. */)
4585 double rehash_size
= check_hash_table (table
)->rehash_size
;
4586 if (rehash_size
< 0)
4588 EMACS_INT s
= -rehash_size
;
4589 return make_number (min (s
, MOST_POSITIVE_FIXNUM
));
4592 return make_float (rehash_size
+ 1);
4596 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4597 Shash_table_rehash_threshold
, 1, 1, 0,
4598 doc
: /* Return the current rehash threshold of TABLE. */)
4601 return make_float (check_hash_table (table
)->rehash_threshold
);
4605 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4606 doc
: /* Return the size of TABLE.
4607 The size can be used as an argument to `make-hash-table' to create
4608 a hash table than can hold as many elements as TABLE holds
4609 without need for resizing. */)
4612 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4613 return make_number (HASH_TABLE_SIZE (h
));
4617 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4618 doc
: /* Return the test TABLE uses. */)
4621 return check_hash_table (table
)->test
.name
;
4625 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4627 doc
: /* Return the weakness of TABLE. */)
4630 return check_hash_table (table
)->weak
;
4634 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4635 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4638 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4642 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4643 doc
: /* Clear hash table TABLE and return it. */)
4646 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4647 CHECK_IMPURE (table
, h
);
4649 /* Be compatible with XEmacs. */
4654 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4655 doc
: /* Look up KEY in TABLE and return its associated value.
4656 If KEY is not found, return DFLT which defaults to nil. */)
4657 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4659 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4660 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4661 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4665 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4666 doc
: /* Associate KEY with VALUE in hash table TABLE.
4667 If KEY is already present in table, replace its current value with
4668 VALUE. In any case, return VALUE. */)
4669 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4671 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4672 CHECK_IMPURE (table
, h
);
4676 i
= hash_lookup (h
, key
, &hash
);
4678 set_hash_value_slot (h
, i
, value
);
4680 hash_put (h
, key
, value
, hash
);
4686 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4687 doc
: /* Remove KEY from TABLE. */)
4688 (Lisp_Object key
, Lisp_Object table
)
4690 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4691 CHECK_IMPURE (table
, h
);
4692 hash_remove_from_table (h
, key
);
4697 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4698 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4699 FUNCTION is called with two arguments, KEY and VALUE.
4700 `maphash' always returns nil. */)
4701 (Lisp_Object function
, Lisp_Object table
)
4703 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4705 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4706 if (!NILP (HASH_HASH (h
, i
)))
4707 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4713 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4714 Sdefine_hash_table_test
, 3, 3, 0,
4715 doc
: /* Define a new hash table test with name NAME, a symbol.
4717 In hash tables created with NAME specified as test, use TEST to
4718 compare keys, and HASH for computing hash codes of keys.
4720 TEST must be a function taking two arguments and returning non-nil if
4721 both arguments are the same. HASH must be a function taking one
4722 argument and returning an object that is the hash code of the argument.
4723 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4724 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4725 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4727 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4732 /************************************************************************
4733 MD5, SHA-1, and SHA-2
4734 ************************************************************************/
4742 make_digest_string (Lisp_Object digest
, int digest_size
)
4744 unsigned char *p
= SDATA (digest
);
4746 for (int i
= digest_size
- 1; i
>= 0; i
--)
4748 static char const hexdigit
[16] = "0123456789abcdef";
4750 p
[2 * i
] = hexdigit
[p_i
>> 4];
4751 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4756 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms
,
4757 Ssecure_hash_algorithms
, 0, 0, 0,
4758 doc
: /* Return a list of all the supported `secure_hash' algorithms. */)
4761 return listn (CONSTYPE_HEAP
, 6,
4770 /* Extract data from a string or a buffer. SPEC is a list of
4771 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
4772 specified with `secure-hash' and in Info node
4773 `(elisp)Format of GnuTLS Cryptography Inputs'. */
4775 extract_data_from_object (Lisp_Object spec
,
4776 ptrdiff_t *start_byte
,
4777 ptrdiff_t *end_byte
)
4779 Lisp_Object object
= XCAR (spec
);
4781 if (CONSP (spec
)) spec
= XCDR (spec
);
4782 Lisp_Object start
= CAR_SAFE (spec
);
4784 if (CONSP (spec
)) spec
= XCDR (spec
);
4785 Lisp_Object end
= CAR_SAFE (spec
);
4787 if (CONSP (spec
)) spec
= XCDR (spec
);
4788 Lisp_Object coding_system
= CAR_SAFE (spec
);
4790 if (CONSP (spec
)) spec
= XCDR (spec
);
4791 Lisp_Object noerror
= CAR_SAFE (spec
);
4793 if (STRINGP (object
))
4795 if (NILP (coding_system
))
4797 /* Decide the coding-system to encode the data with. */
4799 if (STRING_MULTIBYTE (object
))
4800 /* use default, we can't guess correct value */
4801 coding_system
= preferred_coding_system ();
4803 coding_system
= Qraw_text
;
4806 if (NILP (Fcoding_system_p (coding_system
)))
4808 /* Invalid coding system. */
4810 if (!NILP (noerror
))
4811 coding_system
= Qraw_text
;
4813 xsignal1 (Qcoding_system_error
, coding_system
);
4816 if (STRING_MULTIBYTE (object
))
4817 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4819 ptrdiff_t size
= SCHARS (object
), start_char
, end_char
;
4820 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4822 *start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4823 *end_byte
= (end_char
== size
4825 : string_char_to_byte (object
, end_char
));
4827 else if (BUFFERP (object
))
4829 struct buffer
*prev
= current_buffer
;
4832 record_unwind_current_buffer ();
4834 CHECK_BUFFER (object
);
4836 struct buffer
*bp
= XBUFFER (object
);
4837 set_buffer_internal (bp
);
4843 CHECK_NUMBER_COERCE_MARKER (start
);
4851 CHECK_NUMBER_COERCE_MARKER (end
);
4862 if (!(BEGV
<= b
&& e
<= ZV
))
4863 args_out_of_range (start
, end
);
4865 if (NILP (coding_system
))
4867 /* Decide the coding-system to encode the data with.
4868 See fileio.c:Fwrite-region */
4870 if (!NILP (Vcoding_system_for_write
))
4871 coding_system
= Vcoding_system_for_write
;
4874 bool force_raw_text
= 0;
4876 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4877 if (NILP (coding_system
)
4878 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4880 coding_system
= Qnil
;
4881 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4885 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4887 /* Check file-coding-system-alist. */
4888 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4889 Qwrite_region
, start
, end
,
4890 Fbuffer_file_name (object
));
4891 if (CONSP (val
) && !NILP (XCDR (val
)))
4892 coding_system
= XCDR (val
);
4895 if (NILP (coding_system
)
4896 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4898 /* If we still have not decided a coding system, use the
4899 default value of buffer-file-coding-system. */
4900 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4904 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4905 /* Confirm that VAL can surely encode the current region. */
4906 coding_system
= call4 (Vselect_safe_coding_system_function
,
4907 make_number (b
), make_number (e
),
4908 coding_system
, Qnil
);
4911 coding_system
= Qraw_text
;
4914 if (NILP (Fcoding_system_p (coding_system
)))
4916 /* Invalid coding system. */
4918 if (!NILP (noerror
))
4919 coding_system
= Qraw_text
;
4921 xsignal1 (Qcoding_system_error
, coding_system
);
4925 object
= make_buffer_string (b
, e
, 0);
4926 set_buffer_internal (prev
);
4927 /* Discard the unwind protect for recovering the current
4931 if (STRING_MULTIBYTE (object
))
4932 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4934 *end_byte
= SBYTES (object
);
4936 else if (EQ (object
, Qiv_auto
))
4939 /* Format: (iv-auto REQUIRED-LENGTH). */
4941 if (! NATNUMP (start
))
4942 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
4945 EMACS_INT start_hold
= XFASTINT (start
);
4946 object
= make_uninit_string (start_hold
);
4947 gnutls_rnd (GNUTLS_RND_NONCE
, SSDATA (object
), start_hold
);
4950 *end_byte
= start_hold
;
4953 error ("GnuTLS is not available, so `iv-auto' can't be used");
4957 if (!STRINGP (object
))
4958 signal_error ("Invalid object argument",
4959 NILP (object
) ? build_string ("nil") : object
);
4960 return SSDATA (object
);
4964 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4967 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4968 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4971 ptrdiff_t start_byte
, end_byte
;
4973 void *(*hash_func
) (const char *, size_t, void *);
4976 CHECK_SYMBOL (algorithm
);
4978 Lisp_Object spec
= list5 (object
, start
, end
, coding_system
, noerror
);
4980 const char *input
= extract_data_from_object (spec
, &start_byte
, &end_byte
);
4983 error ("secure_hash: failed to extract data from object, aborting!");
4985 if (EQ (algorithm
, Qmd5
))
4987 digest_size
= MD5_DIGEST_SIZE
;
4988 hash_func
= md5_buffer
;
4990 else if (EQ (algorithm
, Qsha1
))
4992 digest_size
= SHA1_DIGEST_SIZE
;
4993 hash_func
= sha1_buffer
;
4995 else if (EQ (algorithm
, Qsha224
))
4997 digest_size
= SHA224_DIGEST_SIZE
;
4998 hash_func
= sha224_buffer
;
5000 else if (EQ (algorithm
, Qsha256
))
5002 digest_size
= SHA256_DIGEST_SIZE
;
5003 hash_func
= sha256_buffer
;
5005 else if (EQ (algorithm
, Qsha384
))
5007 digest_size
= SHA384_DIGEST_SIZE
;
5008 hash_func
= sha384_buffer
;
5010 else if (EQ (algorithm
, Qsha512
))
5012 digest_size
= SHA512_DIGEST_SIZE
;
5013 hash_func
= sha512_buffer
;
5016 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5018 /* allocate 2 x digest_size so that it can be re-used to hold the
5020 digest
= make_uninit_string (digest_size
* 2);
5022 hash_func (input
+ start_byte
,
5023 end_byte
- start_byte
,
5027 return make_digest_string (digest
, digest_size
);
5029 return make_unibyte_string (SSDATA (digest
), digest_size
);
5032 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5033 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5035 A message digest is a cryptographic checksum of a document, and the
5036 algorithm to calculate it is defined in RFC 1321.
5038 The two optional arguments START and END are character positions
5039 specifying for which part of OBJECT the message digest should be
5040 computed. If nil or omitted, the digest is computed for the whole
5043 The MD5 message digest is computed from the result of encoding the
5044 text in a coding system, not directly from the internal Emacs form of
5045 the text. The optional fourth argument CODING-SYSTEM specifies which
5046 coding system to encode the text with. It should be the same coding
5047 system that you used or will use when actually writing the text into a
5050 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5051 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5052 system would be chosen by default for writing this text into a file.
5054 If OBJECT is a string, the most preferred coding system (see the
5055 command `prefer-coding-system') is used.
5057 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5058 guesswork fails. Normally, an error is signaled in such case. */)
5059 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5061 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5064 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5065 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5066 ALGORITHM is a symbol specifying the hash to use:
5067 md5, sha1, sha224, sha256, sha384 or sha512.
5069 The two optional arguments START and END are positions specifying for
5070 which part of OBJECT to compute the hash. If nil or omitted, uses the
5073 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5075 If BINARY is non-nil, returns a string in binary form. */)
5076 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5078 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5081 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5082 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5083 This hash is performed on the raw internal format of the buffer,
5084 disregarding any coding systems. If nil, use the current buffer. */ )
5085 (Lisp_Object buffer_or_name
)
5089 struct sha1_ctx ctx
;
5091 if (NILP (buffer_or_name
))
5092 buffer
= Fcurrent_buffer ();
5094 buffer
= Fget_buffer (buffer_or_name
);
5096 nsberror (buffer_or_name
);
5098 b
= XBUFFER (buffer
);
5099 sha1_init_ctx (&ctx
);
5101 /* Process the first part of the buffer. */
5102 sha1_process_bytes (BUF_BEG_ADDR (b
),
5103 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5106 /* If the gap is before the end of the buffer, process the last half
5108 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5109 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5110 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5113 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5114 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5115 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5122 /* Hash table stuff. */
5123 DEFSYM (Qhash_table_p
, "hash-table-p");
5125 DEFSYM (Qeql
, "eql");
5126 DEFSYM (Qequal
, "equal");
5127 DEFSYM (QCtest
, ":test");
5128 DEFSYM (QCsize
, ":size");
5129 DEFSYM (QCpurecopy
, ":purecopy");
5130 DEFSYM (QCrehash_size
, ":rehash-size");
5131 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5132 DEFSYM (QCweakness
, ":weakness");
5133 DEFSYM (Qkey
, "key");
5134 DEFSYM (Qvalue
, "value");
5135 DEFSYM (Qhash_table_test
, "hash-table-test");
5136 DEFSYM (Qkey_or_value
, "key-or-value");
5137 DEFSYM (Qkey_and_value
, "key-and-value");
5139 defsubr (&Ssxhash_eq
);
5140 defsubr (&Ssxhash_eql
);
5141 defsubr (&Ssxhash_equal
);
5142 defsubr (&Smake_hash_table
);
5143 defsubr (&Scopy_hash_table
);
5144 defsubr (&Shash_table_count
);
5145 defsubr (&Shash_table_rehash_size
);
5146 defsubr (&Shash_table_rehash_threshold
);
5147 defsubr (&Shash_table_size
);
5148 defsubr (&Shash_table_test
);
5149 defsubr (&Shash_table_weakness
);
5150 defsubr (&Shash_table_p
);
5151 defsubr (&Sclrhash
);
5152 defsubr (&Sgethash
);
5153 defsubr (&Sputhash
);
5154 defsubr (&Sremhash
);
5155 defsubr (&Smaphash
);
5156 defsubr (&Sdefine_hash_table_test
);
5158 /* Crypto and hashing stuff. */
5159 DEFSYM (Qiv_auto
, "iv-auto");
5161 DEFSYM (Qmd5
, "md5");
5162 DEFSYM (Qsha1
, "sha1");
5163 DEFSYM (Qsha224
, "sha224");
5164 DEFSYM (Qsha256
, "sha256");
5165 DEFSYM (Qsha384
, "sha384");
5166 DEFSYM (Qsha512
, "sha512");
5168 /* Miscellaneous stuff. */
5170 DEFSYM (Qstring_lessp
, "string-lessp");
5171 DEFSYM (Qprovide
, "provide");
5172 DEFSYM (Qrequire
, "require");
5173 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5174 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5175 DEFSYM (Qwidget_type
, "widget-type");
5177 DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment
,
5178 doc
: /* An alist that overrides the plists of the symbols which it lists.
5179 Used by the byte-compiler to apply `define-symbol-prop' during
5181 Voverriding_plist_environment
= Qnil
;
5182 DEFSYM (Qoverriding_plist_environment
, "overriding-plist-environment");
5184 staticpro (&string_char_byte_cache_string
);
5185 string_char_byte_cache_string
= Qnil
;
5187 require_nesting_list
= Qnil
;
5188 staticpro (&require_nesting_list
);
5190 Fset (Qyes_or_no_p_history
, Qnil
);
5192 DEFVAR_LISP ("features", Vfeatures
,
5193 doc
: /* A list of symbols which are the features of the executing Emacs.
5194 Used by `featurep' and `require', and altered by `provide'. */);
5195 Vfeatures
= list1 (Qemacs
);
5196 DEFSYM (Qfeatures
, "features");
5197 /* Let people use lexically scoped vars named `features'. */
5198 Fmake_var_non_special (Qfeatures
);
5199 DEFSYM (Qsubfeatures
, "subfeatures");
5200 DEFSYM (Qfuncall
, "funcall");
5201 DEFSYM (Qplistp
, "plistp");
5203 #ifdef HAVE_LANGINFO_CODESET
5204 DEFSYM (Qcodeset
, "codeset");
5205 DEFSYM (Qdays
, "days");
5206 DEFSYM (Qmonths
, "months");
5207 DEFSYM (Qpaper
, "paper");
5208 #endif /* HAVE_LANGINFO_CODESET */
5210 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5211 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5212 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5213 invoked by mouse clicks and mouse menu items.
5215 On some platforms, file selection dialogs are also enabled if this is
5219 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5220 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5221 This applies to commands from menus and tool bar buttons even when
5222 they are initiated from the keyboard. If `use-dialog-box' is nil,
5223 that disables the use of a file dialog, regardless of the value of
5225 use_file_dialog
= 1;
5227 defsubr (&Sidentity
);
5230 defsubr (&Ssafe_length
);
5231 defsubr (&Sstring_bytes
);
5232 defsubr (&Sstring_equal
);
5233 defsubr (&Scompare_strings
);
5234 defsubr (&Sstring_lessp
);
5235 defsubr (&Sstring_version_lessp
);
5236 defsubr (&Sstring_collate_lessp
);
5237 defsubr (&Sstring_collate_equalp
);
5240 defsubr (&Svconcat
);
5241 defsubr (&Scopy_sequence
);
5242 defsubr (&Sstring_make_multibyte
);
5243 defsubr (&Sstring_make_unibyte
);
5244 defsubr (&Sstring_as_multibyte
);
5245 defsubr (&Sstring_as_unibyte
);
5246 defsubr (&Sstring_to_multibyte
);
5247 defsubr (&Sstring_to_unibyte
);
5248 defsubr (&Scopy_alist
);
5249 defsubr (&Ssubstring
);
5250 defsubr (&Ssubstring_no_properties
);
5263 defsubr (&Snreverse
);
5264 defsubr (&Sreverse
);
5266 defsubr (&Splist_get
);
5268 defsubr (&Splist_put
);
5270 defsubr (&Slax_plist_get
);
5271 defsubr (&Slax_plist_put
);
5274 defsubr (&Sequal_including_properties
);
5275 defsubr (&Sfillarray
);
5276 defsubr (&Sclear_string
);
5281 defsubr (&Smapconcat
);
5282 defsubr (&Syes_or_no_p
);
5283 defsubr (&Sload_average
);
5284 defsubr (&Sfeaturep
);
5285 defsubr (&Srequire
);
5286 defsubr (&Sprovide
);
5287 defsubr (&Splist_member
);
5288 defsubr (&Swidget_put
);
5289 defsubr (&Swidget_get
);
5290 defsubr (&Swidget_apply
);
5291 defsubr (&Sbase64_encode_region
);
5292 defsubr (&Sbase64_decode_region
);
5293 defsubr (&Sbase64_encode_string
);
5294 defsubr (&Sbase64_decode_string
);
5296 defsubr (&Ssecure_hash_algorithms
);
5297 defsubr (&Ssecure_hash
);
5298 defsubr (&Sbuffer_hash
);
5299 defsubr (&Slocale_info
);