1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2017 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
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. */)
488 if (NILP (arg
)) return arg
;
492 return Frecord (PVSIZE (arg
), XVECTOR (arg
)->contents
);
495 if (CHAR_TABLE_P (arg
))
497 return copy_char_table (arg
);
500 if (BOOL_VECTOR_P (arg
))
502 EMACS_INT nbits
= bool_vector_size (arg
);
503 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
504 Lisp_Object val
= make_uninit_bool_vector (nbits
);
505 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
509 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
510 wrong_type_argument (Qsequencep
, arg
);
512 return concat (1, &arg
, XTYPE (arg
), 0);
515 /* This structure holds information of an argument of `concat' that is
516 a string and has text properties to be copied. */
519 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
520 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
521 ptrdiff_t to
; /* refer to VAL (the target string) */
525 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
526 enum Lisp_Type target_type
, bool last_special
)
532 ptrdiff_t toindex_byte
= 0;
533 EMACS_INT result_len
;
534 EMACS_INT result_len_byte
;
536 Lisp_Object last_tail
;
539 /* When we make a multibyte string, we can't copy text properties
540 while concatenating each string because the length of resulting
541 string can't be decided until we finish the whole concatenation.
542 So, we record strings that have text properties to be copied
543 here, and copy the text properties after the concatenation. */
544 struct textprop_rec
*textprops
= NULL
;
545 /* Number of elements in textprops. */
546 ptrdiff_t num_textprops
= 0;
551 /* In append, the last arg isn't treated like the others */
552 if (last_special
&& nargs
> 0)
555 last_tail
= args
[nargs
];
560 /* Check each argument. */
561 for (argnum
= 0; argnum
< nargs
; argnum
++)
564 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
565 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
566 wrong_type_argument (Qsequencep
, this);
569 /* Compute total length in chars of arguments in RESULT_LEN.
570 If desired output is a string, also compute length in bytes
571 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
572 whether the result should be a multibyte string. */
576 for (argnum
= 0; argnum
< nargs
; argnum
++)
580 len
= XFASTINT (Flength (this));
581 if (target_type
== Lisp_String
)
583 /* We must count the number of bytes needed in the string
584 as well as the number of characters. */
588 ptrdiff_t this_len_byte
;
590 if (VECTORP (this) || COMPILEDP (this))
591 for (i
= 0; i
< len
; i
++)
594 CHECK_CHARACTER (ch
);
596 this_len_byte
= CHAR_BYTES (c
);
597 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
599 result_len_byte
+= this_len_byte
;
600 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
603 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
604 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
605 else if (CONSP (this))
606 for (; CONSP (this); this = XCDR (this))
609 CHECK_CHARACTER (ch
);
611 this_len_byte
= CHAR_BYTES (c
);
612 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
614 result_len_byte
+= this_len_byte
;
615 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
618 else if (STRINGP (this))
620 if (STRING_MULTIBYTE (this))
623 this_len_byte
= SBYTES (this);
626 this_len_byte
= count_size_as_multibyte (SDATA (this),
628 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
630 result_len_byte
+= this_len_byte
;
635 if (MOST_POSITIVE_FIXNUM
< result_len
)
636 memory_full (SIZE_MAX
);
639 if (! some_multibyte
)
640 result_len_byte
= result_len
;
642 /* Create the output object. */
643 if (target_type
== Lisp_Cons
)
644 val
= Fmake_list (make_number (result_len
), Qnil
);
645 else if (target_type
== Lisp_Vectorlike
)
646 val
= Fmake_vector (make_number (result_len
), Qnil
);
647 else if (some_multibyte
)
648 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
650 val
= make_uninit_string (result_len
);
652 /* In `append', if all but last arg are nil, return last arg. */
653 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
656 /* Copy the contents of the args into the result. */
658 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
660 toindex
= 0, toindex_byte
= 0;
664 SAFE_NALLOCA (textprops
, 1, nargs
);
666 for (argnum
= 0; argnum
< nargs
; argnum
++)
669 ptrdiff_t thisleni
= 0;
670 register ptrdiff_t thisindex
= 0;
671 register ptrdiff_t thisindex_byte
= 0;
675 thislen
= Flength (this), thisleni
= XINT (thislen
);
677 /* Between strings of the same kind, copy fast. */
678 if (STRINGP (this) && STRINGP (val
)
679 && STRING_MULTIBYTE (this) == some_multibyte
)
681 ptrdiff_t thislen_byte
= SBYTES (this);
683 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
684 if (string_intervals (this))
686 textprops
[num_textprops
].argnum
= argnum
;
687 textprops
[num_textprops
].from
= 0;
688 textprops
[num_textprops
++].to
= toindex
;
690 toindex_byte
+= thislen_byte
;
693 /* Copy a single-byte string to a multibyte string. */
694 else if (STRINGP (this) && STRINGP (val
))
696 if (string_intervals (this))
698 textprops
[num_textprops
].argnum
= argnum
;
699 textprops
[num_textprops
].from
= 0;
700 textprops
[num_textprops
++].to
= toindex
;
702 toindex_byte
+= copy_text (SDATA (this),
703 SDATA (val
) + toindex_byte
,
704 SCHARS (this), 0, 1);
708 /* Copy element by element. */
711 register Lisp_Object elt
;
713 /* Fetch next element of `this' arg into `elt', or break if
714 `this' is exhausted. */
715 if (NILP (this)) break;
717 elt
= XCAR (this), this = XCDR (this);
718 else if (thisindex
>= thisleni
)
720 else if (STRINGP (this))
723 if (STRING_MULTIBYTE (this))
724 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
729 c
= SREF (this, thisindex
); thisindex
++;
730 if (some_multibyte
&& !ASCII_CHAR_P (c
))
731 c
= BYTE8_TO_CHAR (c
);
733 XSETFASTINT (elt
, c
);
735 else if (BOOL_VECTOR_P (this))
737 elt
= bool_vector_ref (this, thisindex
);
742 elt
= AREF (this, thisindex
);
746 /* Store this element into the result. */
753 else if (VECTORP (val
))
755 ASET (val
, toindex
, elt
);
761 CHECK_CHARACTER (elt
);
764 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
766 SSET (val
, toindex_byte
++, c
);
772 XSETCDR (prev
, last_tail
);
774 if (num_textprops
> 0)
777 ptrdiff_t last_to_end
= -1;
779 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
781 this = args
[textprops
[argnum
].argnum
];
782 props
= text_property_list (this,
784 make_number (SCHARS (this)),
786 /* If successive arguments have properties, be sure that the
787 value of `composition' property be the copy. */
788 if (last_to_end
== textprops
[argnum
].to
)
789 make_composition_value_copy (props
);
790 add_text_properties_from_list (val
, props
,
791 make_number (textprops
[argnum
].to
));
792 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
800 static Lisp_Object string_char_byte_cache_string
;
801 static ptrdiff_t string_char_byte_cache_charpos
;
802 static ptrdiff_t string_char_byte_cache_bytepos
;
805 clear_string_char_byte_cache (void)
807 string_char_byte_cache_string
= Qnil
;
810 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
813 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
816 ptrdiff_t best_below
, best_below_byte
;
817 ptrdiff_t best_above
, best_above_byte
;
819 best_below
= best_below_byte
= 0;
820 best_above
= SCHARS (string
);
821 best_above_byte
= SBYTES (string
);
822 if (best_above
== best_above_byte
)
825 if (EQ (string
, string_char_byte_cache_string
))
827 if (string_char_byte_cache_charpos
< char_index
)
829 best_below
= string_char_byte_cache_charpos
;
830 best_below_byte
= string_char_byte_cache_bytepos
;
834 best_above
= string_char_byte_cache_charpos
;
835 best_above_byte
= string_char_byte_cache_bytepos
;
839 if (char_index
- best_below
< best_above
- char_index
)
841 unsigned char *p
= SDATA (string
) + best_below_byte
;
843 while (best_below
< char_index
)
845 p
+= BYTES_BY_CHAR_HEAD (*p
);
848 i_byte
= p
- SDATA (string
);
852 unsigned char *p
= SDATA (string
) + best_above_byte
;
854 while (best_above
> char_index
)
857 while (!CHAR_HEAD_P (*p
)) p
--;
860 i_byte
= p
- SDATA (string
);
863 string_char_byte_cache_bytepos
= i_byte
;
864 string_char_byte_cache_charpos
= char_index
;
865 string_char_byte_cache_string
= string
;
870 /* Return the character index corresponding to BYTE_INDEX in STRING. */
873 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
876 ptrdiff_t best_below
, best_below_byte
;
877 ptrdiff_t best_above
, best_above_byte
;
879 best_below
= best_below_byte
= 0;
880 best_above
= SCHARS (string
);
881 best_above_byte
= SBYTES (string
);
882 if (best_above
== best_above_byte
)
885 if (EQ (string
, string_char_byte_cache_string
))
887 if (string_char_byte_cache_bytepos
< byte_index
)
889 best_below
= string_char_byte_cache_charpos
;
890 best_below_byte
= string_char_byte_cache_bytepos
;
894 best_above
= string_char_byte_cache_charpos
;
895 best_above_byte
= string_char_byte_cache_bytepos
;
899 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
901 unsigned char *p
= SDATA (string
) + best_below_byte
;
902 unsigned char *pend
= SDATA (string
) + byte_index
;
906 p
+= BYTES_BY_CHAR_HEAD (*p
);
910 i_byte
= p
- SDATA (string
);
914 unsigned char *p
= SDATA (string
) + best_above_byte
;
915 unsigned char *pbeg
= SDATA (string
) + byte_index
;
920 while (!CHAR_HEAD_P (*p
)) p
--;
924 i_byte
= p
- SDATA (string
);
927 string_char_byte_cache_bytepos
= i_byte
;
928 string_char_byte_cache_charpos
= i
;
929 string_char_byte_cache_string
= string
;
934 /* Convert STRING to a multibyte string. */
937 string_make_multibyte (Lisp_Object string
)
944 if (STRING_MULTIBYTE (string
))
947 nbytes
= count_size_as_multibyte (SDATA (string
),
949 /* If all the chars are ASCII, they won't need any more bytes
950 once converted. In that case, we can return STRING itself. */
951 if (nbytes
== SBYTES (string
))
954 buf
= SAFE_ALLOCA (nbytes
);
955 copy_text (SDATA (string
), buf
, SBYTES (string
),
958 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
965 /* Convert STRING (if unibyte) to a multibyte string without changing
966 the number of characters. Characters 0200 trough 0237 are
967 converted to eight-bit characters. */
970 string_to_multibyte (Lisp_Object string
)
977 if (STRING_MULTIBYTE (string
))
980 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
981 /* If all the chars are ASCII, they won't need any more bytes once
983 if (nbytes
== SBYTES (string
))
984 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
986 buf
= SAFE_ALLOCA (nbytes
);
987 memcpy (buf
, SDATA (string
), SBYTES (string
));
988 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
990 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
997 /* Convert STRING to a single-byte string. */
1000 string_make_unibyte (Lisp_Object string
)
1007 if (! STRING_MULTIBYTE (string
))
1010 nchars
= SCHARS (string
);
1012 buf
= SAFE_ALLOCA (nchars
);
1013 copy_text (SDATA (string
), buf
, SBYTES (string
),
1016 ret
= make_unibyte_string ((char *) buf
, nchars
);
1022 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1024 doc
: /* Return the multibyte equivalent of STRING.
1025 If STRING is unibyte and contains non-ASCII characters, the function
1026 `unibyte-char-to-multibyte' is used to convert each unibyte character
1027 to a multibyte character. In this case, the returned string is a
1028 newly created string with no text properties. If STRING is multibyte
1029 or entirely ASCII, it is returned unchanged. In particular, when
1030 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1031 \(When the characters are all ASCII, Emacs primitives will treat the
1032 string the same way whether it is unibyte or multibyte.) */)
1033 (Lisp_Object string
)
1035 CHECK_STRING (string
);
1037 return string_make_multibyte (string
);
1040 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1042 doc
: /* Return the unibyte equivalent of STRING.
1043 Multibyte character codes are converted to unibyte according to
1044 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1045 If the lookup in the translation table fails, this function takes just
1046 the low 8 bits of each character. */)
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 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1993 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1994 doc
: /* Change value in PLIST of PROP to VAL.
1995 PLIST is a property list, which is a list of the form
1996 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1997 If PROP is already a property on the list, its value is set to VAL,
1998 otherwise the new PROP VAL pair is added. The new plist is returned;
1999 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2000 The PLIST is modified by side effects. */)
2001 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2003 Lisp_Object prev
= Qnil
, tail
= plist
;
2004 FOR_EACH_TAIL (tail
)
2006 if (! CONSP (XCDR (tail
)))
2009 if (EQ (prop
, XCAR (tail
)))
2011 Fsetcar (XCDR (tail
), val
);
2017 if (EQ (tail
, li
.tortoise
))
2018 circular_list (plist
);
2020 CHECK_LIST_END (tail
, plist
);
2022 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2025 Fsetcdr (XCDR (prev
), newcell
);
2029 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2030 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2031 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2032 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2034 CHECK_SYMBOL (symbol
);
2036 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2040 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2041 doc
: /* Extract a value from a property list, comparing with `equal'.
2042 PLIST is a property list, which is a list of the form
2043 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2044 corresponding to the given PROP, or nil if PROP is not
2045 one of the properties on the list. */)
2046 (Lisp_Object plist
, Lisp_Object prop
)
2048 Lisp_Object tail
= plist
;
2049 FOR_EACH_TAIL (tail
)
2051 if (! CONSP (XCDR (tail
)))
2053 if (! NILP (Fequal (prop
, XCAR (tail
))))
2054 return XCAR (XCDR (tail
));
2056 if (EQ (tail
, li
.tortoise
))
2057 circular_list (plist
);
2060 CHECK_LIST_END (tail
, plist
);
2065 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2066 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2067 PLIST is a property list, which is a list of the form
2068 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2069 If PROP is already a property on the list, its value is set to VAL,
2070 otherwise the new PROP VAL pair is added. The new plist is returned;
2071 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2072 The PLIST is modified by side effects. */)
2073 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2075 Lisp_Object prev
= Qnil
, tail
= plist
;
2076 FOR_EACH_TAIL (tail
)
2078 if (! CONSP (XCDR (tail
)))
2081 if (! NILP (Fequal (prop
, XCAR (tail
))))
2083 Fsetcar (XCDR (tail
), val
);
2089 if (EQ (tail
, li
.tortoise
))
2090 circular_list (plist
);
2092 CHECK_LIST_END (tail
, plist
);
2093 Lisp_Object newcell
= list2 (prop
, val
);
2096 Fsetcdr (XCDR (prev
), newcell
);
2100 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2101 doc
: /* Return t if the two args are the same Lisp object.
2102 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2103 (Lisp_Object obj1
, Lisp_Object obj2
)
2106 return equal_no_quit (obj1
, obj2
) ? Qt
: Qnil
;
2108 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2111 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2112 doc
: /* Return t if two Lisp objects have similar structure and contents.
2113 They must have the same data type.
2114 Conses are compared by comparing the cars and the cdrs.
2115 Vectors and strings are compared element by element.
2116 Numbers are compared by value, but integers cannot equal floats.
2117 (Use `=' if you want integers and floats to be able to be equal.)
2118 Symbols must match exactly. */)
2119 (Lisp_Object o1
, Lisp_Object o2
)
2121 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2124 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2125 doc
: /* Return t if two Lisp objects have similar structure and contents.
2126 This is like `equal' except that it compares the text properties
2127 of strings. (`equal' ignores text properties.) */)
2128 (Lisp_Object o1
, Lisp_Object o2
)
2130 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2134 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2135 Use this only on arguments that are cycle-free and not too large and
2136 are not window configurations. */
2139 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2141 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2144 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2145 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2146 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2147 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2148 equal-including-properties.
2150 If DEPTH is the current depth of recursion; signal an error if it
2151 gets too deep. HT is a hash table used to detect cycles; if nil,
2152 it has not been allocated yet. But ignore the last two arguments
2153 if EQUAL_KIND == EQUAL_NO_QUIT. */
2156 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2157 int depth
, Lisp_Object ht
)
2162 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2164 error ("Stack overflow in equal");
2166 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2169 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2171 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2173 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2175 { /* `o1' was seen already. */
2176 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2177 if (!NILP (Fmemq (o2
, o2s
)))
2180 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2183 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2191 if (XTYPE (o1
) != XTYPE (o2
))
2198 double d1
= XFLOAT_DATA (o1
);
2199 double d2
= XFLOAT_DATA (o2
);
2200 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2201 though they are not =. */
2202 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2206 if (equal_kind
== EQUAL_NO_QUIT
)
2207 for (; CONSP (o1
); o1
= XCDR (o1
))
2211 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2214 if (EQ (XCDR (o1
), o2
))
2222 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2223 equal_kind
, depth
+ 1, ht
))
2226 if (EQ (XCDR (o1
), o2
))
2233 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2237 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2238 equal_kind
, depth
+ 1, ht
)
2239 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2240 equal_kind
, depth
+ 1, ht
))
2242 o1
= XOVERLAY (o1
)->plist
;
2243 o2
= XOVERLAY (o2
)->plist
;
2249 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2250 && (XMARKER (o1
)->buffer
== 0
2251 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2255 case Lisp_Vectorlike
:
2258 ptrdiff_t size
= ASIZE (o1
);
2259 /* Pseudovectors have the type encoded in the size field, so this test
2260 actually checks that the objects have the same type as well as the
2262 if (ASIZE (o2
) != size
)
2264 /* Boolvectors are compared much like strings. */
2265 if (BOOL_VECTOR_P (o1
))
2267 EMACS_INT size
= bool_vector_size (o1
);
2268 if (size
!= bool_vector_size (o2
))
2270 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2271 bool_vector_bytes (size
)))
2275 if (WINDOW_CONFIGURATIONP (o1
))
2277 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2278 return compare_window_configurations (o1
, o2
, false);
2281 /* Aside from them, only true vectors, char-tables, compiled
2282 functions, and fonts (font-spec, font-entity, font-object)
2283 are sensible to compare, so eliminate the others now. */
2284 if (size
& PSEUDOVECTOR_FLAG
)
2286 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2289 size
&= PSEUDOVECTOR_SIZE_MASK
;
2291 for (i
= 0; i
< size
; i
++)
2296 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2304 if (SCHARS (o1
) != SCHARS (o2
))
2306 if (SBYTES (o1
) != SBYTES (o2
))
2308 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2310 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2311 && !compare_string_intervals (o1
, o2
))
2323 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2324 doc
: /* Store each element of ARRAY with ITEM.
2325 ARRAY is a vector, string, char-table, or bool-vector. */)
2326 (Lisp_Object array
, Lisp_Object item
)
2328 register ptrdiff_t size
, idx
;
2330 if (VECTORP (array
))
2331 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2332 ASET (array
, idx
, item
);
2333 else if (CHAR_TABLE_P (array
))
2337 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2338 set_char_table_contents (array
, i
, item
);
2339 set_char_table_defalt (array
, item
);
2341 else if (STRINGP (array
))
2343 register unsigned char *p
= SDATA (array
);
2345 CHECK_CHARACTER (item
);
2346 charval
= XFASTINT (item
);
2347 size
= SCHARS (array
);
2348 if (STRING_MULTIBYTE (array
))
2350 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2351 int len
= CHAR_STRING (charval
, str
);
2352 ptrdiff_t size_byte
= SBYTES (array
);
2355 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2356 error ("Attempt to change byte length of a string");
2357 for (idx
= 0; idx
< size_byte
; idx
++)
2358 *p
++ = str
[idx
% len
];
2361 for (idx
= 0; idx
< size
; idx
++)
2364 else if (BOOL_VECTOR_P (array
))
2365 return bool_vector_fill (array
, item
);
2367 wrong_type_argument (Qarrayp
, array
);
2371 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2373 doc
: /* Clear the contents of STRING.
2374 This makes STRING unibyte and may change its length. */)
2375 (Lisp_Object string
)
2378 CHECK_STRING (string
);
2379 len
= SBYTES (string
);
2380 memset (SDATA (string
), 0, len
);
2381 STRING_SET_CHARS (string
, len
);
2382 STRING_SET_UNIBYTE (string
);
2388 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2390 return CALLN (Fnconc
, s1
, s2
);
2393 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2394 doc
: /* Concatenate any number of lists by altering them.
2395 Only the last argument is not altered, and need not be a list.
2396 usage: (nconc &rest LISTS) */)
2397 (ptrdiff_t nargs
, Lisp_Object
*args
)
2399 Lisp_Object val
= Qnil
;
2401 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2403 Lisp_Object tem
= args
[argnum
];
2404 if (NILP (tem
)) continue;
2409 if (argnum
+ 1 == nargs
) break;
2417 tem
= args
[argnum
+ 1];
2418 Fsetcdr (tail
, tem
);
2420 args
[argnum
+ 1] = tail
;
2426 /* This is the guts of all mapping functions.
2427 Apply FN to each element of SEQ, one by one, storing the results
2428 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2429 length of VALS, which should also be the length of SEQ. Return the
2430 number of results; although this is normally LENI, it can be less
2431 if SEQ is made shorter as a side effect of FN. */
2434 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2436 Lisp_Object tail
, dummy
;
2439 if (VECTORP (seq
) || COMPILEDP (seq
))
2441 for (i
= 0; i
< leni
; i
++)
2443 dummy
= call1 (fn
, AREF (seq
, i
));
2448 else if (BOOL_VECTOR_P (seq
))
2450 for (i
= 0; i
< leni
; i
++)
2452 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2457 else if (STRINGP (seq
))
2461 for (i
= 0, i_byte
= 0; i
< leni
;)
2464 ptrdiff_t i_before
= i
;
2466 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2467 XSETFASTINT (dummy
, c
);
2468 dummy
= call1 (fn
, dummy
);
2470 vals
[i_before
] = dummy
;
2473 else /* Must be a list, since Flength did not get an error */
2476 for (i
= 0; i
< leni
; i
++)
2480 dummy
= call1 (fn
, XCAR (tail
));
2490 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2491 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2492 In between each pair of results, stick in SEPARATOR. Thus, " " as
2493 SEPARATOR results in spaces between the values returned by FUNCTION.
2494 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2495 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2498 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2499 if (CHAR_TABLE_P (sequence
))
2500 wrong_type_argument (Qlistp
, sequence
);
2501 EMACS_INT args_alloc
= 2 * leni
- 1;
2503 return empty_unibyte_string
;
2505 SAFE_ALLOCA_LISP (args
, args_alloc
);
2506 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2507 ptrdiff_t nargs
= 2 * nmapped
- 1;
2509 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2510 args
[i
+ i
] = args
[i
];
2512 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2513 args
[i
] = separator
;
2515 Lisp_Object ret
= Fconcat (nargs
, args
);
2520 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2521 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2522 The result is a list just as long as SEQUENCE.
2523 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2524 (Lisp_Object function
, Lisp_Object sequence
)
2527 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2528 if (CHAR_TABLE_P (sequence
))
2529 wrong_type_argument (Qlistp
, sequence
);
2531 SAFE_ALLOCA_LISP (args
, leni
);
2532 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2533 Lisp_Object ret
= Flist (nmapped
, args
);
2538 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2539 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2540 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2541 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2542 (Lisp_Object function
, Lisp_Object sequence
)
2544 register EMACS_INT leni
;
2546 leni
= XFASTINT (Flength (sequence
));
2547 if (CHAR_TABLE_P (sequence
))
2548 wrong_type_argument (Qlistp
, sequence
);
2549 mapcar1 (leni
, 0, function
, sequence
);
2554 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2555 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2556 the results by altering them (using `nconc').
2557 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2558 (Lisp_Object function
, Lisp_Object sequence
)
2561 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2562 if (CHAR_TABLE_P (sequence
))
2563 wrong_type_argument (Qlistp
, sequence
);
2565 SAFE_ALLOCA_LISP (args
, leni
);
2566 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2567 Lisp_Object ret
= Fnconc (nmapped
, args
);
2572 /* This is how C code calls `yes-or-no-p' and allows the user
2576 do_yes_or_no_p (Lisp_Object prompt
)
2578 return call1 (intern ("yes-or-no-p"), prompt
);
2581 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2582 doc
: /* Ask user a yes-or-no question.
2583 Return t if answer is yes, and nil if the answer is no.
2584 PROMPT is the string to display to ask the question. It should end in
2585 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2587 The user must confirm the answer with RET, and can edit it until it
2590 If dialog boxes are supported, a dialog box will be used
2591 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2592 (Lisp_Object prompt
)
2596 CHECK_STRING (prompt
);
2598 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2599 && use_dialog_box
&& ! NILP (last_input_event
))
2601 Lisp_Object pane
, menu
, obj
;
2602 redisplay_preserve_echo_area (4);
2603 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2604 Fcons (build_string ("No"), Qnil
));
2605 menu
= Fcons (prompt
, pane
);
2606 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2610 AUTO_STRING (yes_or_no
, "(yes or no) ");
2611 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2615 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2616 Qyes_or_no_p_history
, Qnil
,
2618 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2620 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2625 message1 ("Please answer yes or no.");
2626 Fsleep_for (make_number (2), Qnil
);
2630 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2631 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2633 Each of the three load averages is multiplied by 100, then converted
2636 When USE-FLOATS is non-nil, floats will be used instead of integers.
2637 These floats are not multiplied by 100.
2639 If the 5-minute or 15-minute load averages are not available, return a
2640 shortened list, containing only those averages which are available.
2642 An error is thrown if the load average can't be obtained. In some
2643 cases making it work would require Emacs being installed setuid or
2644 setgid so that it can read kernel information, and that usually isn't
2646 (Lisp_Object use_floats
)
2649 int loads
= getloadavg (load_ave
, 3);
2650 Lisp_Object ret
= Qnil
;
2653 error ("load-average not implemented for this operating system");
2657 Lisp_Object load
= (NILP (use_floats
)
2658 ? make_number (100.0 * load_ave
[loads
])
2659 : make_float (load_ave
[loads
]));
2660 ret
= Fcons (load
, ret
);
2666 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2667 doc
: /* Return t if FEATURE is present in this Emacs.
2669 Use this to conditionalize execution of lisp code based on the
2670 presence or absence of Emacs or environment extensions.
2671 Use `provide' to declare that a feature is available. This function
2672 looks at the value of the variable `features'. The optional argument
2673 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2674 (Lisp_Object feature
, Lisp_Object subfeature
)
2676 register Lisp_Object tem
;
2677 CHECK_SYMBOL (feature
);
2678 tem
= Fmemq (feature
, Vfeatures
);
2679 if (!NILP (tem
) && !NILP (subfeature
))
2680 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2681 return (NILP (tem
)) ? Qnil
: Qt
;
2684 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2685 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2686 The optional argument SUBFEATURES should be a list of symbols listing
2687 particular subfeatures supported in this version of FEATURE. */)
2688 (Lisp_Object feature
, Lisp_Object subfeatures
)
2690 register Lisp_Object tem
;
2691 CHECK_SYMBOL (feature
);
2692 CHECK_LIST (subfeatures
);
2693 if (!NILP (Vautoload_queue
))
2694 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2696 tem
= Fmemq (feature
, Vfeatures
);
2698 Vfeatures
= Fcons (feature
, Vfeatures
);
2699 if (!NILP (subfeatures
))
2700 Fput (feature
, Qsubfeatures
, subfeatures
);
2701 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2703 /* Run any load-hooks for this file. */
2704 tem
= Fassq (feature
, Vafter_load_alist
);
2706 Fmapc (Qfuncall
, XCDR (tem
));
2711 /* `require' and its subroutines. */
2713 /* List of features currently being require'd, innermost first. */
2715 static Lisp_Object require_nesting_list
;
2718 require_unwind (Lisp_Object old_value
)
2720 require_nesting_list
= old_value
;
2723 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2724 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2725 If FEATURE is not a member of the list `features', then the feature is
2726 not loaded; so load the file FILENAME.
2728 If FILENAME is omitted, the printname of FEATURE is used as the file
2729 name, and `load' will try to load this name appended with the suffix
2730 `.elc', `.el', or the system-dependent suffix for dynamic module
2731 files, in that order. The name without appended suffix will not be
2732 used. See `get-load-suffixes' for the complete list of suffixes.
2734 The directories in `load-path' are searched when trying to find the
2737 If the optional third argument NOERROR is non-nil, then return nil if
2738 the file is not found instead of signaling an error. Normally the
2739 return value is FEATURE.
2741 The normal messages at start and end of loading FILENAME are
2743 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2746 bool from_file
= load_in_progress
;
2748 CHECK_SYMBOL (feature
);
2750 /* Record the presence of `require' in this file
2751 even if the feature specified is already loaded.
2752 But not more than once in any file,
2753 and not when we aren't loading or reading from a file. */
2755 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2756 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2761 tem
= Fcons (Qrequire
, feature
);
2762 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2763 LOADHIST_ATTACH (tem
);
2765 tem
= Fmemq (feature
, Vfeatures
);
2769 ptrdiff_t count
= SPECPDL_INDEX ();
2772 /* This is to make sure that loadup.el gives a clear picture
2773 of what files are preloaded and when. */
2774 if (! NILP (Vpurify_flag
))
2775 error ("(require %s) while preparing to dump",
2776 SDATA (SYMBOL_NAME (feature
)));
2778 /* A certain amount of recursive `require' is legitimate,
2779 but if we require the same feature recursively 3 times,
2781 tem
= require_nesting_list
;
2782 while (! NILP (tem
))
2784 if (! NILP (Fequal (feature
, XCAR (tem
))))
2789 error ("Recursive `require' for feature `%s'",
2790 SDATA (SYMBOL_NAME (feature
)));
2792 /* Update the list for any nested `require's that occur. */
2793 record_unwind_protect (require_unwind
, require_nesting_list
);
2794 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2796 /* Value saved here is to be restored into Vautoload_queue */
2797 record_unwind_protect (un_autoload
, Vautoload_queue
);
2798 Vautoload_queue
= Qt
;
2800 /* Load the file. */
2801 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2802 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2804 /* If load failed entirely, return nil. */
2806 return unbind_to (count
, Qnil
);
2808 tem
= Fmemq (feature
, Vfeatures
);
2811 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
2812 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
2815 error ("Required feature `%s' was not provided", tem2
);
2817 /* Cf autoload-do-load. */
2818 error ("Loading file %s failed to provide feature `%s'",
2819 SDATA (tem3
), tem2
);
2822 /* Once loading finishes, don't undo it. */
2823 Vautoload_queue
= Qt
;
2824 feature
= unbind_to (count
, feature
);
2830 /* Primitives for work of the "widget" library.
2831 In an ideal world, this section would not have been necessary.
2832 However, lisp function calls being as slow as they are, it turns
2833 out that some functions in the widget library (wid-edit.el) are the
2834 bottleneck of Widget operation. Here is their translation to C,
2835 for the sole reason of efficiency. */
2837 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2838 doc
: /* Return non-nil if PLIST has the property PROP.
2839 PLIST is a property list, which is a list of the form
2840 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2841 Unlike `plist-get', this allows you to distinguish between a missing
2842 property and a property with the value nil.
2843 The value is actually the tail of PLIST whose car is PROP. */)
2844 (Lisp_Object plist
, Lisp_Object prop
)
2846 Lisp_Object tail
= plist
;
2847 FOR_EACH_TAIL (tail
)
2849 if (EQ (XCAR (tail
), prop
))
2854 if (EQ (tail
, li
.tortoise
))
2855 circular_list (tail
);
2857 CHECK_LIST_END (tail
, plist
);
2861 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2862 doc
: /* In WIDGET, set PROPERTY to VALUE.
2863 The value can later be retrieved with `widget-get'. */)
2864 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2866 CHECK_CONS (widget
);
2867 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2871 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2872 doc
: /* In WIDGET, get the value of PROPERTY.
2873 The value could either be specified when the widget was created, or
2874 later with `widget-put'. */)
2875 (Lisp_Object widget
, Lisp_Object property
)
2883 CHECK_CONS (widget
);
2884 tmp
= Fplist_member (XCDR (widget
), property
);
2890 tmp
= XCAR (widget
);
2893 widget
= Fget (tmp
, Qwidget_type
);
2897 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2898 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2899 ARGS are passed as extra arguments to the function.
2900 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2901 (ptrdiff_t nargs
, Lisp_Object
*args
)
2903 Lisp_Object widget
= args
[0];
2904 Lisp_Object property
= args
[1];
2905 Lisp_Object propval
= Fwidget_get (widget
, property
);
2906 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2907 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2911 #ifdef HAVE_LANGINFO_CODESET
2912 #include <langinfo.h>
2915 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2916 doc
: /* Access locale data ITEM for the current C locale, if available.
2917 ITEM should be one of the following:
2919 `codeset', returning the character set as a string (locale item CODESET);
2921 `days', returning a 7-element vector of day names (locale items DAY_n);
2923 `months', returning a 12-element vector of month names (locale items MON_n);
2925 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2926 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2928 If the system can't provide such information through a call to
2929 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2931 See also Info node `(libc)Locales'.
2933 The data read from the system are decoded using `locale-coding-system'. */)
2937 #ifdef HAVE_LANGINFO_CODESET
2938 if (EQ (item
, Qcodeset
))
2940 str
= nl_langinfo (CODESET
);
2941 return build_string (str
);
2944 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2946 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2947 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2949 synchronize_system_time_locale ();
2950 for (i
= 0; i
< 7; i
++)
2952 str
= nl_langinfo (days
[i
]);
2953 AUTO_STRING (val
, str
);
2954 /* Fixme: Is this coding system necessarily right, even if
2955 it is consistent with CODESET? If not, what to do? */
2956 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2963 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2965 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2966 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2967 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2969 synchronize_system_time_locale ();
2970 for (i
= 0; i
< 12; i
++)
2972 str
= nl_langinfo (months
[i
]);
2973 AUTO_STRING (val
, str
);
2974 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2980 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2981 but is in the locale files. This could be used by ps-print. */
2983 else if (EQ (item
, Qpaper
))
2984 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2985 #endif /* PAPER_WIDTH */
2986 #endif /* HAVE_LANGINFO_CODESET*/
2990 /* base64 encode/decode functions (RFC 2045).
2991 Based on code from GNU recode. */
2993 #define MIME_LINE_LENGTH 76
2995 #define IS_ASCII(Character) \
2997 #define IS_BASE64(Character) \
2998 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2999 #define IS_BASE64_IGNORABLE(Character) \
3000 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3001 || (Character) == '\f' || (Character) == '\r')
3003 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3004 character or return retval if there are no characters left to
3006 #define READ_QUADRUPLET_BYTE(retval) \
3011 if (nchars_return) \
3012 *nchars_return = nchars; \
3017 while (IS_BASE64_IGNORABLE (c))
3019 /* Table of characters coding the 64 values. */
3020 static const char base64_value_to_char
[64] =
3022 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3023 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3024 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3025 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3026 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3027 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3028 '8', '9', '+', '/' /* 60-63 */
3031 /* Table of base64 values for first 128 characters. */
3032 static const short base64_char_to_value
[128] =
3034 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3035 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3036 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3037 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3038 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3039 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3040 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3041 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3042 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3043 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3044 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3045 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3046 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3049 /* The following diagram shows the logical steps by which three octets
3050 get transformed into four base64 characters.
3052 .--------. .--------. .--------.
3053 |aaaaaabb| |bbbbcccc| |ccdddddd|
3054 `--------' `--------' `--------'
3056 .--------+--------+--------+--------.
3057 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3058 `--------+--------+--------+--------'
3060 .--------+--------+--------+--------.
3061 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3062 `--------+--------+--------+--------'
3064 The octets are divided into 6 bit chunks, which are then encoded into
3065 base64 characters. */
3068 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3069 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3072 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3074 doc
: /* Base64-encode the region between BEG and END.
3075 Return the length of the encoded text.
3076 Optional third argument NO-LINE-BREAK means do not break long lines
3077 into shorter lines. */)
3078 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3081 ptrdiff_t allength
, length
;
3082 ptrdiff_t ibeg
, iend
, encoded_length
;
3083 ptrdiff_t old_pos
= PT
;
3086 validate_region (&beg
, &end
);
3088 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3089 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3090 move_gap_both (XFASTINT (beg
), ibeg
);
3092 /* We need to allocate enough room for encoding the text.
3093 We need 33 1/3% more space, plus a newline every 76
3094 characters, and then we round up. */
3095 length
= iend
- ibeg
;
3096 allength
= length
+ length
/3 + 1;
3097 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3099 encoded
= SAFE_ALLOCA (allength
);
3100 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3101 encoded
, length
, NILP (no_line_break
),
3102 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3103 if (encoded_length
> allength
)
3106 if (encoded_length
< 0)
3108 /* The encoding wasn't possible. */
3110 error ("Multibyte character in data for base64 encoding");
3113 /* Now we have encoded the region, so we insert the new contents
3114 and delete the old. (Insert first in order to preserve markers.) */
3115 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3116 insert (encoded
, encoded_length
);
3118 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3120 /* If point was outside of the region, restore it exactly; else just
3121 move to the beginning of the region. */
3122 if (old_pos
>= XFASTINT (end
))
3123 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3124 else if (old_pos
> XFASTINT (beg
))
3125 old_pos
= XFASTINT (beg
);
3128 /* We return the length of the encoded text. */
3129 return make_number (encoded_length
);
3132 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3134 doc
: /* Base64-encode STRING and return the result.
3135 Optional second argument NO-LINE-BREAK means do not break long lines
3136 into shorter lines. */)
3137 (Lisp_Object string
, Lisp_Object no_line_break
)
3139 ptrdiff_t allength
, length
, encoded_length
;
3141 Lisp_Object encoded_string
;
3144 CHECK_STRING (string
);
3146 /* We need to allocate enough room for encoding the text.
3147 We need 33 1/3% more space, plus a newline every 76
3148 characters, and then we round up. */
3149 length
= SBYTES (string
);
3150 allength
= length
+ length
/3 + 1;
3151 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3153 /* We need to allocate enough room for decoding the text. */
3154 encoded
= SAFE_ALLOCA (allength
);
3156 encoded_length
= base64_encode_1 (SSDATA (string
),
3157 encoded
, length
, NILP (no_line_break
),
3158 STRING_MULTIBYTE (string
));
3159 if (encoded_length
> allength
)
3162 if (encoded_length
< 0)
3164 /* The encoding wasn't possible. */
3165 error ("Multibyte character in data for base64 encoding");
3168 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3171 return encoded_string
;
3175 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3176 bool line_break
, bool multibyte
)
3189 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3190 if (CHAR_BYTE8_P (c
))
3191 c
= CHAR_TO_BYTE8 (c
);
3199 /* Wrap line every 76 characters. */
3203 if (counter
< MIME_LINE_LENGTH
/ 4)
3212 /* Process first byte of a triplet. */
3214 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3215 value
= (0x03 & c
) << 4;
3217 /* Process second byte of a triplet. */
3221 *e
++ = base64_value_to_char
[value
];
3229 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3230 if (CHAR_BYTE8_P (c
))
3231 c
= CHAR_TO_BYTE8 (c
);
3239 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3240 value
= (0x0f & c
) << 2;
3242 /* Process third byte of a triplet. */
3246 *e
++ = base64_value_to_char
[value
];
3253 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3254 if (CHAR_BYTE8_P (c
))
3255 c
= CHAR_TO_BYTE8 (c
);
3263 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3264 *e
++ = base64_value_to_char
[0x3f & c
];
3271 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3273 doc
: /* Base64-decode the region between BEG and END.
3274 Return the length of the decoded text.
3275 If the region can't be decoded, signal an error and don't modify the buffer. */)
3276 (Lisp_Object beg
, Lisp_Object end
)
3278 ptrdiff_t ibeg
, iend
, length
, allength
;
3280 ptrdiff_t old_pos
= PT
;
3281 ptrdiff_t decoded_length
;
3282 ptrdiff_t inserted_chars
;
3283 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3286 validate_region (&beg
, &end
);
3288 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3289 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3291 length
= iend
- ibeg
;
3293 /* We need to allocate enough room for decoding the text. If we are
3294 working on a multibyte buffer, each decoded code may occupy at
3296 allength
= multibyte
? length
* 2 : length
;
3297 decoded
= SAFE_ALLOCA (allength
);
3299 move_gap_both (XFASTINT (beg
), ibeg
);
3300 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3302 multibyte
, &inserted_chars
);
3303 if (decoded_length
> allength
)
3306 if (decoded_length
< 0)
3308 /* The decoding wasn't possible. */
3309 error ("Invalid base64 data");
3312 /* Now we have decoded the region, so we insert the new contents
3313 and delete the old. (Insert first in order to preserve markers.) */
3314 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3315 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3318 /* Delete the original text. */
3319 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3320 iend
+ decoded_length
, 1);
3322 /* If point was outside of the region, restore it exactly; else just
3323 move to the beginning of the region. */
3324 if (old_pos
>= XFASTINT (end
))
3325 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3326 else if (old_pos
> XFASTINT (beg
))
3327 old_pos
= XFASTINT (beg
);
3328 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3330 return make_number (inserted_chars
);
3333 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3335 doc
: /* Base64-decode STRING and return the result. */)
3336 (Lisp_Object string
)
3339 ptrdiff_t length
, decoded_length
;
3340 Lisp_Object decoded_string
;
3343 CHECK_STRING (string
);
3345 length
= SBYTES (string
);
3346 /* We need to allocate enough room for decoding the text. */
3347 decoded
= SAFE_ALLOCA (length
);
3349 /* The decoded result should be unibyte. */
3350 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3352 if (decoded_length
> length
)
3354 else if (decoded_length
>= 0)
3355 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3357 decoded_string
= Qnil
;
3360 if (!STRINGP (decoded_string
))
3361 error ("Invalid base64 data");
3363 return decoded_string
;
3366 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3367 MULTIBYTE, the decoded result should be in multibyte
3368 form. If NCHARS_RETURN is not NULL, store the number of produced
3369 characters in *NCHARS_RETURN. */
3372 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3373 bool multibyte
, ptrdiff_t *nchars_return
)
3375 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3378 unsigned long value
;
3379 ptrdiff_t nchars
= 0;
3383 /* Process first byte of a quadruplet. */
3385 READ_QUADRUPLET_BYTE (e
-to
);
3389 value
= base64_char_to_value
[c
] << 18;
3391 /* Process second byte of a quadruplet. */
3393 READ_QUADRUPLET_BYTE (-1);
3397 value
|= base64_char_to_value
[c
] << 12;
3399 c
= (unsigned char) (value
>> 16);
3400 if (multibyte
&& c
>= 128)
3401 e
+= BYTE8_STRING (c
, e
);
3406 /* Process third byte of a quadruplet. */
3408 READ_QUADRUPLET_BYTE (-1);
3412 READ_QUADRUPLET_BYTE (-1);
3421 value
|= base64_char_to_value
[c
] << 6;
3423 c
= (unsigned char) (0xff & value
>> 8);
3424 if (multibyte
&& c
>= 128)
3425 e
+= BYTE8_STRING (c
, e
);
3430 /* Process fourth byte of a quadruplet. */
3432 READ_QUADRUPLET_BYTE (-1);
3439 value
|= base64_char_to_value
[c
];
3441 c
= (unsigned char) (0xff & value
);
3442 if (multibyte
&& c
>= 128)
3443 e
+= BYTE8_STRING (c
, e
);
3452 /***********************************************************************
3454 ***** Hash Tables *****
3456 ***********************************************************************/
3458 /* Implemented by gerd@gnu.org. This hash table implementation was
3459 inspired by CMUCL hash tables. */
3463 1. For small tables, association lists are probably faster than
3464 hash tables because they have lower overhead.
3466 For uses of hash tables where the O(1) behavior of table
3467 operations is not a requirement, it might therefore be a good idea
3468 not to hash. Instead, we could just do a linear search in the
3469 key_and_value vector of the hash table. This could be done
3470 if a `:linear-search t' argument is given to make-hash-table. */
3473 /* The list of all weak hash tables. Don't staticpro this one. */
3475 static struct Lisp_Hash_Table
*weak_hash_tables
;
3478 /***********************************************************************
3480 ***********************************************************************/
3483 CHECK_HASH_TABLE (Lisp_Object x
)
3485 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3489 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3491 h
->key_and_value
= key_and_value
;
3494 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3499 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3501 gc_aset (h
->next
, idx
, make_number (val
));
3504 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3509 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3511 gc_aset (h
->hash
, idx
, val
);
3514 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3519 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3521 gc_aset (h
->index
, idx
, make_number (val
));
3524 /* If OBJ is a Lisp hash table, return a pointer to its struct
3525 Lisp_Hash_Table. Otherwise, signal an error. */
3527 static struct Lisp_Hash_Table
*
3528 check_hash_table (Lisp_Object obj
)
3530 CHECK_HASH_TABLE (obj
);
3531 return XHASH_TABLE (obj
);
3535 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3536 number. A number is "almost" a prime number if it is not divisible
3537 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3540 next_almost_prime (EMACS_INT n
)
3542 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3543 for (n
|= 1; ; n
+= 2)
3544 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3549 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3550 which USED[I] is non-zero. If found at index I in ARGS, set
3551 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3552 0. This function is used to extract a keyword/argument pair from
3553 a DEFUN parameter list. */
3556 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3560 for (i
= 1; i
< nargs
; i
++)
3561 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3572 /* Return a Lisp vector which has the same contents as VEC but has
3573 at least INCR_MIN more entries, where INCR_MIN is positive.
3574 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3575 than NITEMS_MAX. New entries in the resulting vector are
3579 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3581 struct Lisp_Vector
*v
;
3582 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3583 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3584 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3585 ? nitems_max
: C_language_max
);
3586 eassert (VECTORP (vec
));
3587 eassert (0 < incr_min
&& -1 <= nitems_max
);
3588 old_size
= ASIZE (vec
);
3589 incr_max
= n_max
- old_size
;
3590 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3591 if (incr_max
< incr
)
3592 memory_full (SIZE_MAX
);
3593 new_size
= old_size
+ incr
;
3594 v
= allocate_vector (new_size
);
3595 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3596 XSETVECTOR (vec
, v
);
3600 /* Likewise, except set new entries in the resulting vector to nil. */
3603 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3605 ptrdiff_t old_size
= ASIZE (vec
);
3606 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3607 ptrdiff_t new_size
= ASIZE (v
);
3608 memclear (XVECTOR (v
)->contents
+ old_size
,
3609 (new_size
- old_size
) * word_size
);
3614 /***********************************************************************
3616 ***********************************************************************/
3618 /* Return the index of the next entry in H following the one at IDX,
3622 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3624 return XINT (AREF (h
->next
, idx
));
3627 /* Return the index of the element in hash table H that is the start
3628 of the collision list at index IDX, or -1 if the list is empty. */
3631 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3633 return XINT (AREF (h
->index
, idx
));
3636 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3637 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3638 KEY2 are the same. */
3641 cmpfn_eql (struct hash_table_test
*ht
,
3645 return (FLOATP (key1
)
3647 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3651 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3652 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3653 KEY2 are the same. */
3656 cmpfn_equal (struct hash_table_test
*ht
,
3660 return !NILP (Fequal (key1
, key2
));
3664 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3665 HASH2 in hash table H using H->user_cmp_function. Value is true
3666 if KEY1 and KEY2 are the same. */
3669 cmpfn_user_defined (struct hash_table_test
*ht
,
3673 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3676 /* Value is a hash code for KEY for use in hash table H which uses
3677 `eq' to compare keys. The hash code returned is guaranteed to fit
3678 in a Lisp integer. */
3681 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3683 return XHASH (key
) ^ XTYPE (key
);
3686 /* Value is a hash code for KEY for use in hash table H which uses
3687 `equal' to compare keys. The hash code returned is guaranteed to fit
3688 in a Lisp integer. */
3691 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3693 return sxhash (key
, 0);
3696 /* Value is a hash code for KEY for use in hash table H which uses
3697 `eql' to compare keys. The hash code returned is guaranteed to fit
3698 in a Lisp integer. */
3701 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3703 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3706 /* Value is a hash code for KEY for use in hash table H which uses as
3707 user-defined function to compare keys. The hash code returned is
3708 guaranteed to fit in a Lisp integer. */
3711 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3713 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3714 return hashfn_eq (ht
, hash
);
3717 struct hash_table_test
const
3718 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3719 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3720 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3721 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3722 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3723 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3725 /* Allocate basically initialized hash table. */
3727 static struct Lisp_Hash_Table
*
3728 allocate_hash_table (void)
3730 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3731 count
, PVEC_HASH_TABLE
);
3734 /* An upper bound on the size of a hash table index. It must fit in
3735 ptrdiff_t and be a valid Emacs fixnum. */
3736 #define INDEX_SIZE_BOUND \
3737 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3739 /* Create and initialize a new hash table.
3741 TEST specifies the test the hash table will use to compare keys.
3742 It must be either one of the predefined tests `eq', `eql' or
3743 `equal' or a symbol denoting a user-defined test named TEST with
3744 test and hash functions USER_TEST and USER_HASH.
3746 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3748 If REHASH_SIZE is equal to a negative integer, this hash table's
3749 new size when it becomes full is computed by subtracting
3750 REHASH_SIZE from its old size. Otherwise it must be positive, and
3751 the table's new size is computed by multiplying its old size by
3754 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3755 be resized when the approximate ratio of table entries to table
3756 size exceeds REHASH_THRESHOLD.
3758 WEAK specifies the weakness of the table. If non-nil, it must be
3759 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3761 If PURECOPY is non-nil, the table can be copied to pure storage via
3762 `purecopy' when Emacs is being dumped. Such tables can no longer be
3763 changed after purecopy. */
3766 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
3767 float rehash_size
, float rehash_threshold
,
3768 Lisp_Object weak
, bool pure
)
3770 struct Lisp_Hash_Table
*h
;
3772 EMACS_INT index_size
;
3776 /* Preconditions. */
3777 eassert (SYMBOLP (test
.name
));
3778 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
3779 eassert (rehash_size
<= -1 || 0 < rehash_size
);
3780 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
3785 double threshold
= rehash_threshold
;
3786 index_float
= size
/ threshold
;
3787 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3788 ? next_almost_prime (index_float
)
3789 : INDEX_SIZE_BOUND
+ 1);
3790 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * size
))
3791 error ("Hash table too large");
3793 /* Allocate a table and initialize it. */
3794 h
= allocate_hash_table ();
3796 /* Initialize hash table slots. */
3799 h
->rehash_threshold
= rehash_threshold
;
3800 h
->rehash_size
= rehash_size
;
3802 h
->key_and_value
= Fmake_vector (make_number (2 * size
), Qnil
);
3803 h
->hash
= Fmake_vector (make_number (size
), Qnil
);
3804 h
->next
= Fmake_vector (make_number (size
), make_number (-1));
3805 h
->index
= Fmake_vector (make_number (index_size
), make_number (-1));
3808 /* Set up the free list. */
3809 for (i
= 0; i
< size
- 1; ++i
)
3810 set_hash_next_slot (h
, i
, i
+ 1);
3813 XSET_HASH_TABLE (table
, h
);
3814 eassert (HASH_TABLE_P (table
));
3815 eassert (XHASH_TABLE (table
) == h
);
3817 /* Maybe add this hash table to the list of all weak hash tables. */
3820 h
->next_weak
= weak_hash_tables
;
3821 weak_hash_tables
= h
;
3828 /* Return a copy of hash table H1. Keys and values are not copied,
3829 only the table itself is. */
3832 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3835 struct Lisp_Hash_Table
*h2
;
3837 h2
= allocate_hash_table ();
3839 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3840 h2
->hash
= Fcopy_sequence (h1
->hash
);
3841 h2
->next
= Fcopy_sequence (h1
->next
);
3842 h2
->index
= Fcopy_sequence (h1
->index
);
3843 XSET_HASH_TABLE (table
, h2
);
3845 /* Maybe add this hash table to the list of all weak hash tables. */
3846 if (!NILP (h2
->weak
))
3848 h2
->next_weak
= h1
->next_weak
;
3856 /* Resize hash table H if it's too full. If H cannot be resized
3857 because it's already too large, throw an error. */
3860 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3862 if (h
->next_free
< 0)
3864 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3865 EMACS_INT new_size
, index_size
, nsize
;
3867 double rehash_size
= h
->rehash_size
;
3870 if (rehash_size
< 0)
3871 new_size
= old_size
- rehash_size
;
3874 double float_new_size
= old_size
* (rehash_size
+ 1);
3875 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3876 new_size
= float_new_size
;
3878 new_size
= INDEX_SIZE_BOUND
+ 1;
3880 if (new_size
<= old_size
)
3881 new_size
= old_size
+ 1;
3882 double threshold
= h
->rehash_threshold
;
3883 index_float
= new_size
/ threshold
;
3884 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3885 ? next_almost_prime (index_float
)
3886 : INDEX_SIZE_BOUND
+ 1);
3887 nsize
= max (index_size
, 2 * new_size
);
3888 if (INDEX_SIZE_BOUND
< nsize
)
3889 error ("Hash table too large to resize");
3891 #ifdef ENABLE_CHECKING
3892 if (HASH_TABLE_P (Vpurify_flag
)
3893 && XHASH_TABLE (Vpurify_flag
) == h
)
3894 message ("Growing hash table to: %"pI
"d", new_size
);
3897 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3898 2 * (new_size
- old_size
), -1));
3899 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3900 set_hash_index (h
, Fmake_vector (make_number (index_size
),
3902 set_hash_next (h
, larger_vecalloc (h
->next
, new_size
- old_size
, -1));
3904 /* Update the free list. Do it so that new entries are added at
3905 the end of the free list. This makes some operations like
3907 for (i
= old_size
; i
< new_size
- 1; ++i
)
3908 set_hash_next_slot (h
, i
, i
+ 1);
3909 set_hash_next_slot (h
, i
, -1);
3911 if (h
->next_free
< 0)
3912 h
->next_free
= old_size
;
3915 ptrdiff_t last
= h
->next_free
;
3918 ptrdiff_t next
= HASH_NEXT (h
, last
);
3923 set_hash_next_slot (h
, last
, old_size
);
3927 for (i
= 0; i
< old_size
; ++i
)
3928 if (!NILP (HASH_HASH (h
, i
)))
3930 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3931 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3932 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3933 set_hash_index_slot (h
, start_of_bucket
, i
);
3939 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3940 the hash code of KEY. Value is the index of the entry in H
3941 matching KEY, or -1 if not found. */
3944 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3946 EMACS_UINT hash_code
;
3947 ptrdiff_t start_of_bucket
, i
;
3949 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3950 eassert ((hash_code
& ~INTMASK
) == 0);
3954 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3956 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
3957 if (EQ (key
, HASH_KEY (h
, i
))
3959 && hash_code
== XUINT (HASH_HASH (h
, i
))
3960 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3967 /* Put an entry into hash table H that associates KEY with VALUE.
3968 HASH is a previously computed hash code of KEY.
3969 Value is the index of the entry in H matching KEY. */
3972 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3975 ptrdiff_t start_of_bucket
, i
;
3977 eassert ((hash
& ~INTMASK
) == 0);
3979 /* Increment count after resizing because resizing may fail. */
3980 maybe_resize_hash_table (h
);
3983 /* Store key/value in the key_and_value vector. */
3985 h
->next_free
= HASH_NEXT (h
, i
);
3986 set_hash_key_slot (h
, i
, key
);
3987 set_hash_value_slot (h
, i
, value
);
3989 /* Remember its hash code. */
3990 set_hash_hash_slot (h
, i
, make_number (hash
));
3992 /* Add new entry to its collision chain. */
3993 start_of_bucket
= hash
% ASIZE (h
->index
);
3994 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3995 set_hash_index_slot (h
, start_of_bucket
, i
);
4000 /* Remove the entry matching KEY from hash table H, if there is one. */
4003 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4005 EMACS_UINT hash_code
= h
->test
.hashfn (&h
->test
, key
);
4006 eassert ((hash_code
& ~INTMASK
) == 0);
4007 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4008 ptrdiff_t prev
= -1;
4010 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4012 i
= HASH_NEXT (h
, i
))
4014 if (EQ (key
, HASH_KEY (h
, i
))
4016 && hash_code
== XUINT (HASH_HASH (h
, i
))
4017 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4019 /* Take entry out of collision chain. */
4021 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4023 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4025 /* Clear slots in key_and_value and add the slots to
4027 set_hash_key_slot (h
, i
, Qnil
);
4028 set_hash_value_slot (h
, i
, Qnil
);
4029 set_hash_hash_slot (h
, i
, Qnil
);
4030 set_hash_next_slot (h
, i
, h
->next_free
);
4033 eassert (h
->count
>= 0);
4042 /* Clear hash table H. */
4045 hash_clear (struct Lisp_Hash_Table
*h
)
4049 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4051 for (i
= 0; i
< size
; ++i
)
4053 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4054 set_hash_key_slot (h
, i
, Qnil
);
4055 set_hash_value_slot (h
, i
, Qnil
);
4056 set_hash_hash_slot (h
, i
, Qnil
);
4059 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4060 ASET (h
->index
, i
, make_number (-1));
4069 /************************************************************************
4071 ************************************************************************/
4073 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4074 entries from the table that don't survive the current GC.
4075 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4076 true if anything was marked. */
4079 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4081 ptrdiff_t n
= gc_asize (h
->index
);
4082 bool marked
= false;
4084 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4086 /* Follow collision chain, removing entries that
4087 don't survive this garbage collection. */
4088 ptrdiff_t prev
= -1;
4090 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4092 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4093 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4096 if (EQ (h
->weak
, Qkey
))
4097 remove_p
= !key_known_to_survive_p
;
4098 else if (EQ (h
->weak
, Qvalue
))
4099 remove_p
= !value_known_to_survive_p
;
4100 else if (EQ (h
->weak
, Qkey_or_value
))
4101 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4102 else if (EQ (h
->weak
, Qkey_and_value
))
4103 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4107 next
= HASH_NEXT (h
, i
);
4109 if (remove_entries_p
)
4113 /* Take out of collision chain. */
4115 set_hash_index_slot (h
, bucket
, next
);
4117 set_hash_next_slot (h
, prev
, next
);
4119 /* Add to free list. */
4120 set_hash_next_slot (h
, i
, h
->next_free
);
4123 /* Clear key, value, and hash. */
4124 set_hash_key_slot (h
, i
, Qnil
);
4125 set_hash_value_slot (h
, i
, Qnil
);
4126 set_hash_hash_slot (h
, i
, Qnil
);
4139 /* Make sure key and value survive. */
4140 if (!key_known_to_survive_p
)
4142 mark_object (HASH_KEY (h
, i
));
4146 if (!value_known_to_survive_p
)
4148 mark_object (HASH_VALUE (h
, i
));
4159 /* Remove elements from weak hash tables that don't survive the
4160 current garbage collection. Remove weak tables that don't survive
4161 from Vweak_hash_tables. Called from gc_sweep. */
4163 NO_INLINE
/* For better stack traces */
4165 sweep_weak_hash_tables (void)
4167 struct Lisp_Hash_Table
*h
, *used
, *next
;
4170 /* Mark all keys and values that are in use. Keep on marking until
4171 there is no more change. This is necessary for cases like
4172 value-weak table A containing an entry X -> Y, where Y is used in a
4173 key-weak table B, Z -> Y. If B comes after A in the list of weak
4174 tables, X -> Y might be removed from A, although when looking at B
4175 one finds that it shouldn't. */
4179 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4181 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4182 marked
|= sweep_weak_table (h
, 0);
4187 /* Remove tables and entries that aren't used. */
4188 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4190 next
= h
->next_weak
;
4192 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4194 /* TABLE is marked as used. Sweep its contents. */
4196 sweep_weak_table (h
, 1);
4198 /* Add table to the list of used weak hash tables. */
4199 h
->next_weak
= used
;
4204 weak_hash_tables
= used
;
4209 /***********************************************************************
4210 Hash Code Computation
4211 ***********************************************************************/
4213 /* Maximum depth up to which to dive into Lisp structures. */
4215 #define SXHASH_MAX_DEPTH 3
4217 /* Maximum length up to which to take list and vector elements into
4220 #define SXHASH_MAX_LEN 7
4222 /* Return a hash for string PTR which has length LEN. The hash value
4223 can be any EMACS_UINT value. */
4226 hash_string (char const *ptr
, ptrdiff_t len
)
4228 char const *p
= ptr
;
4229 char const *end
= p
+ len
;
4231 EMACS_UINT hash
= 0;
4236 hash
= sxhash_combine (hash
, c
);
4242 /* Return a hash for string PTR which has length LEN. The hash
4243 code returned is guaranteed to fit in a Lisp integer. */
4246 sxhash_string (char const *ptr
, ptrdiff_t len
)
4248 EMACS_UINT hash
= hash_string (ptr
, len
);
4249 return SXHASH_REDUCE (hash
);
4252 /* Return a hash for the floating point value VAL. */
4255 sxhash_float (double val
)
4257 EMACS_UINT hash
= 0;
4259 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4260 + (sizeof val
% sizeof hash
!= 0))
4264 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4268 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4269 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4270 hash
= sxhash_combine (hash
, u
.word
[i
]);
4271 return SXHASH_REDUCE (hash
);
4274 /* Return a hash for list LIST. DEPTH is the current depth in the
4275 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4278 sxhash_list (Lisp_Object list
, int depth
)
4280 EMACS_UINT hash
= 0;
4283 if (depth
< SXHASH_MAX_DEPTH
)
4285 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4286 list
= XCDR (list
), ++i
)
4288 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4289 hash
= sxhash_combine (hash
, hash2
);
4294 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4295 hash
= sxhash_combine (hash
, hash2
);
4298 return SXHASH_REDUCE (hash
);
4302 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4303 the Lisp structure. */
4306 sxhash_vector (Lisp_Object vec
, int depth
)
4308 EMACS_UINT hash
= ASIZE (vec
);
4311 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4312 for (i
= 0; i
< n
; ++i
)
4314 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4315 hash
= sxhash_combine (hash
, hash2
);
4318 return SXHASH_REDUCE (hash
);
4321 /* Return a hash for bool-vector VECTOR. */
4324 sxhash_bool_vector (Lisp_Object vec
)
4326 EMACS_INT size
= bool_vector_size (vec
);
4327 EMACS_UINT hash
= size
;
4330 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4331 for (i
= 0; i
< n
; ++i
)
4332 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4334 return SXHASH_REDUCE (hash
);
4338 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4339 structure. Value is an unsigned integer clipped to INTMASK. */
4342 sxhash (Lisp_Object obj
, int depth
)
4346 if (depth
> SXHASH_MAX_DEPTH
)
4349 switch (XTYPE (obj
))
4361 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4364 /* This can be everything from a vector to an overlay. */
4365 case Lisp_Vectorlike
:
4366 if (VECTORP (obj
) || RECORDP (obj
))
4367 /* According to the CL HyperSpec, two arrays are equal only if
4368 they are `eq', except for strings and bit-vectors. In
4369 Emacs, this works differently. We have to compare element
4370 by element. Same for records. */
4371 hash
= sxhash_vector (obj
, depth
);
4372 else if (BOOL_VECTOR_P (obj
))
4373 hash
= sxhash_bool_vector (obj
);
4375 /* Others are `equal' if they are `eq', so let's take their
4381 hash
= sxhash_list (obj
, depth
);
4385 hash
= sxhash_float (XFLOAT_DATA (obj
));
4397 /***********************************************************************
4399 ***********************************************************************/
4401 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4402 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4403 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4406 return make_number (hashfn_eq (NULL
, obj
));
4409 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4410 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4411 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4414 return make_number (hashfn_eql (NULL
, obj
));
4417 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4418 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4419 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4422 return make_number (hashfn_equal (NULL
, obj
));
4425 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4426 doc
: /* Create and return a new hash table.
4428 Arguments are specified as keyword/argument pairs. The following
4429 arguments are defined:
4431 :test TEST -- TEST must be a symbol that specifies how to compare
4432 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4433 `equal'. User-supplied test and hash functions can be specified via
4434 `define-hash-table-test'.
4436 :size SIZE -- A hint as to how many elements will be put in the table.
4439 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4440 fills up. If REHASH-SIZE is an integer, increase the size by that
4441 amount. If it is a float, it must be > 1.0, and the new size is the
4442 old size multiplied by that factor. Default is 1.5.
4444 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4445 Resize the hash table when the ratio (table entries / table size)
4446 exceeds an approximation to THRESHOLD. Default is 0.8125.
4448 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4449 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4450 returned is a weak table. Key/value pairs are removed from a weak
4451 hash table when there are no non-weak references pointing to their
4452 key, value, one of key or value, or both key and value, depending on
4453 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4456 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4457 to pure storage when Emacs is being dumped, making the contents of the
4458 table read only. Any further changes to purified tables will result
4461 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4462 (ptrdiff_t nargs
, Lisp_Object
*args
)
4464 Lisp_Object test
, weak
;
4466 struct hash_table_test testdesc
;
4470 /* The vector `used' is used to keep track of arguments that
4471 have been consumed. */
4472 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4473 memset (used
, 0, nargs
* sizeof *used
);
4475 /* See if there's a `:test TEST' among the arguments. */
4476 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4477 test
= i
? args
[i
] : Qeql
;
4479 testdesc
= hashtest_eq
;
4480 else if (EQ (test
, Qeql
))
4481 testdesc
= hashtest_eql
;
4482 else if (EQ (test
, Qequal
))
4483 testdesc
= hashtest_equal
;
4486 /* See if it is a user-defined test. */
4489 prop
= Fget (test
, Qhash_table_test
);
4490 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4491 signal_error ("Invalid hash table test", test
);
4492 testdesc
.name
= test
;
4493 testdesc
.user_cmp_function
= XCAR (prop
);
4494 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4495 testdesc
.hashfn
= hashfn_user_defined
;
4496 testdesc
.cmpfn
= cmpfn_user_defined
;
4499 /* See if there's a `:purecopy PURECOPY' argument. */
4500 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4501 pure
= i
&& !NILP (args
[i
]);
4502 /* See if there's a `:size SIZE' argument. */
4503 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4504 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4506 if (NILP (size_arg
))
4507 size
= DEFAULT_HASH_SIZE
;
4508 else if (NATNUMP (size_arg
))
4509 size
= XFASTINT (size_arg
);
4511 signal_error ("Invalid hash table size", size_arg
);
4513 /* Look for `:rehash-size SIZE'. */
4515 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4517 rehash_size
= DEFAULT_REHASH_SIZE
;
4518 else if (INTEGERP (args
[i
]) && 0 < XINT (args
[i
]))
4519 rehash_size
= - XINT (args
[i
]);
4520 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4521 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4523 signal_error ("Invalid hash table rehash size", args
[i
]);
4525 /* Look for `:rehash-threshold THRESHOLD'. */
4526 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4527 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4528 : !FLOATP (args
[i
]) ? 0
4529 : (float) XFLOAT_DATA (args
[i
]));
4530 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4531 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4533 /* Look for `:weakness WEAK'. */
4534 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4535 weak
= i
? args
[i
] : Qnil
;
4537 weak
= Qkey_and_value
;
4540 && !EQ (weak
, Qvalue
)
4541 && !EQ (weak
, Qkey_or_value
)
4542 && !EQ (weak
, Qkey_and_value
))
4543 signal_error ("Invalid hash table weakness", weak
);
4545 /* Now, all args should have been used up, or there's a problem. */
4546 for (i
= 0; i
< nargs
; ++i
)
4548 signal_error ("Invalid argument list", args
[i
]);
4551 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4556 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4557 doc
: /* Return a copy of hash table TABLE. */)
4560 return copy_hash_table (check_hash_table (table
));
4564 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4565 doc
: /* Return the number of elements in TABLE. */)
4568 return make_number (check_hash_table (table
)->count
);
4572 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4573 Shash_table_rehash_size
, 1, 1, 0,
4574 doc
: /* Return the current rehash size of TABLE. */)
4577 double rehash_size
= check_hash_table (table
)->rehash_size
;
4578 if (rehash_size
< 0)
4580 EMACS_INT s
= -rehash_size
;
4581 return make_number (min (s
, MOST_POSITIVE_FIXNUM
));
4584 return make_float (rehash_size
+ 1);
4588 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4589 Shash_table_rehash_threshold
, 1, 1, 0,
4590 doc
: /* Return the current rehash threshold of TABLE. */)
4593 return make_float (check_hash_table (table
)->rehash_threshold
);
4597 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4598 doc
: /* Return the size of TABLE.
4599 The size can be used as an argument to `make-hash-table' to create
4600 a hash table than can hold as many elements as TABLE holds
4601 without need for resizing. */)
4604 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4605 return make_number (HASH_TABLE_SIZE (h
));
4609 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4610 doc
: /* Return the test TABLE uses. */)
4613 return check_hash_table (table
)->test
.name
;
4617 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4619 doc
: /* Return the weakness of TABLE. */)
4622 return check_hash_table (table
)->weak
;
4626 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4627 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4630 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4634 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4635 doc
: /* Clear hash table TABLE and return it. */)
4638 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4639 CHECK_IMPURE (table
, h
);
4641 /* Be compatible with XEmacs. */
4646 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4647 doc
: /* Look up KEY in TABLE and return its associated value.
4648 If KEY is not found, return DFLT which defaults to nil. */)
4649 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4651 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4652 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4653 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4657 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4658 doc
: /* Associate KEY with VALUE in hash table TABLE.
4659 If KEY is already present in table, replace its current value with
4660 VALUE. In any case, return VALUE. */)
4661 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4663 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4664 CHECK_IMPURE (table
, h
);
4668 i
= hash_lookup (h
, key
, &hash
);
4670 set_hash_value_slot (h
, i
, value
);
4672 hash_put (h
, key
, value
, hash
);
4678 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4679 doc
: /* Remove KEY from TABLE. */)
4680 (Lisp_Object key
, Lisp_Object table
)
4682 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4683 CHECK_IMPURE (table
, h
);
4684 hash_remove_from_table (h
, key
);
4689 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4690 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4691 FUNCTION is called with two arguments, KEY and VALUE.
4692 `maphash' always returns nil. */)
4693 (Lisp_Object function
, Lisp_Object table
)
4695 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4697 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4698 if (!NILP (HASH_HASH (h
, i
)))
4699 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4705 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4706 Sdefine_hash_table_test
, 3, 3, 0,
4707 doc
: /* Define a new hash table test with name NAME, a symbol.
4709 In hash tables created with NAME specified as test, use TEST to
4710 compare keys, and HASH for computing hash codes of keys.
4712 TEST must be a function taking two arguments and returning non-nil if
4713 both arguments are the same. HASH must be a function taking one
4714 argument and returning an object that is the hash code of the argument.
4715 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4716 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4717 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4719 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4724 /************************************************************************
4725 MD5, SHA-1, and SHA-2
4726 ************************************************************************/
4734 make_digest_string (Lisp_Object digest
, int digest_size
)
4736 unsigned char *p
= SDATA (digest
);
4738 for (int i
= digest_size
- 1; i
>= 0; i
--)
4740 static char const hexdigit
[16] = "0123456789abcdef";
4742 p
[2 * i
] = hexdigit
[p_i
>> 4];
4743 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4748 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms
,
4749 Ssecure_hash_algorithms
, 0, 0, 0,
4750 doc
: /* Return a list of all the supported `secure_hash' algorithms. */)
4753 return listn (CONSTYPE_HEAP
, 6,
4762 /* Extract data from a string or a buffer. SPEC is a list of
4763 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
4764 specified with `secure-hash' and in Info node
4765 `(elisp)Format of GnuTLS Cryptography Inputs'. */
4767 extract_data_from_object (Lisp_Object spec
,
4768 ptrdiff_t *start_byte
,
4769 ptrdiff_t *end_byte
)
4771 Lisp_Object object
= XCAR (spec
);
4773 if (CONSP (spec
)) spec
= XCDR (spec
);
4774 Lisp_Object start
= CAR_SAFE (spec
);
4776 if (CONSP (spec
)) spec
= XCDR (spec
);
4777 Lisp_Object end
= CAR_SAFE (spec
);
4779 if (CONSP (spec
)) spec
= XCDR (spec
);
4780 Lisp_Object coding_system
= CAR_SAFE (spec
);
4782 if (CONSP (spec
)) spec
= XCDR (spec
);
4783 Lisp_Object noerror
= CAR_SAFE (spec
);
4785 if (STRINGP (object
))
4787 if (NILP (coding_system
))
4789 /* Decide the coding-system to encode the data with. */
4791 if (STRING_MULTIBYTE (object
))
4792 /* use default, we can't guess correct value */
4793 coding_system
= preferred_coding_system ();
4795 coding_system
= Qraw_text
;
4798 if (NILP (Fcoding_system_p (coding_system
)))
4800 /* Invalid coding system. */
4802 if (!NILP (noerror
))
4803 coding_system
= Qraw_text
;
4805 xsignal1 (Qcoding_system_error
, coding_system
);
4808 if (STRING_MULTIBYTE (object
))
4809 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4811 ptrdiff_t size
= SCHARS (object
), start_char
, end_char
;
4812 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4814 *start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4815 *end_byte
= (end_char
== size
4817 : string_char_to_byte (object
, end_char
));
4819 else if (BUFFERP (object
))
4821 struct buffer
*prev
= current_buffer
;
4824 record_unwind_current_buffer ();
4826 CHECK_BUFFER (object
);
4828 struct buffer
*bp
= XBUFFER (object
);
4829 set_buffer_internal (bp
);
4835 CHECK_NUMBER_COERCE_MARKER (start
);
4843 CHECK_NUMBER_COERCE_MARKER (end
);
4854 if (!(BEGV
<= b
&& e
<= ZV
))
4855 args_out_of_range (start
, end
);
4857 if (NILP (coding_system
))
4859 /* Decide the coding-system to encode the data with.
4860 See fileio.c:Fwrite-region */
4862 if (!NILP (Vcoding_system_for_write
))
4863 coding_system
= Vcoding_system_for_write
;
4866 bool force_raw_text
= 0;
4868 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4869 if (NILP (coding_system
)
4870 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4872 coding_system
= Qnil
;
4873 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4877 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4879 /* Check file-coding-system-alist. */
4880 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4881 Qwrite_region
, start
, end
,
4882 Fbuffer_file_name (object
));
4883 if (CONSP (val
) && !NILP (XCDR (val
)))
4884 coding_system
= XCDR (val
);
4887 if (NILP (coding_system
)
4888 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4890 /* If we still have not decided a coding system, use the
4891 default value of buffer-file-coding-system. */
4892 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4896 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4897 /* Confirm that VAL can surely encode the current region. */
4898 coding_system
= call4 (Vselect_safe_coding_system_function
,
4899 make_number (b
), make_number (e
),
4900 coding_system
, Qnil
);
4903 coding_system
= Qraw_text
;
4906 if (NILP (Fcoding_system_p (coding_system
)))
4908 /* Invalid coding system. */
4910 if (!NILP (noerror
))
4911 coding_system
= Qraw_text
;
4913 xsignal1 (Qcoding_system_error
, coding_system
);
4917 object
= make_buffer_string (b
, e
, 0);
4918 set_buffer_internal (prev
);
4919 /* Discard the unwind protect for recovering the current
4923 if (STRING_MULTIBYTE (object
))
4924 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4926 *end_byte
= SBYTES (object
);
4928 else if (EQ (object
, Qiv_auto
))
4931 /* Format: (iv-auto REQUIRED-LENGTH). */
4933 if (! NATNUMP (start
))
4934 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
4937 EMACS_INT start_hold
= XFASTINT (start
);
4938 object
= make_uninit_string (start_hold
);
4939 gnutls_rnd (GNUTLS_RND_NONCE
, SSDATA (object
), start_hold
);
4942 *end_byte
= start_hold
;
4945 error ("GnuTLS is not available, so `iv-auto' can't be used");
4949 return SSDATA (object
);
4953 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4956 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4957 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4960 ptrdiff_t start_byte
, end_byte
;
4962 void *(*hash_func
) (const char *, size_t, void *);
4965 CHECK_SYMBOL (algorithm
);
4967 Lisp_Object spec
= list5 (object
, start
, end
, coding_system
, noerror
);
4969 const char *input
= extract_data_from_object (spec
, &start_byte
, &end_byte
);
4972 error ("secure_hash: failed to extract data from object, aborting!");
4974 if (EQ (algorithm
, Qmd5
))
4976 digest_size
= MD5_DIGEST_SIZE
;
4977 hash_func
= md5_buffer
;
4979 else if (EQ (algorithm
, Qsha1
))
4981 digest_size
= SHA1_DIGEST_SIZE
;
4982 hash_func
= sha1_buffer
;
4984 else if (EQ (algorithm
, Qsha224
))
4986 digest_size
= SHA224_DIGEST_SIZE
;
4987 hash_func
= sha224_buffer
;
4989 else if (EQ (algorithm
, Qsha256
))
4991 digest_size
= SHA256_DIGEST_SIZE
;
4992 hash_func
= sha256_buffer
;
4994 else if (EQ (algorithm
, Qsha384
))
4996 digest_size
= SHA384_DIGEST_SIZE
;
4997 hash_func
= sha384_buffer
;
4999 else if (EQ (algorithm
, Qsha512
))
5001 digest_size
= SHA512_DIGEST_SIZE
;
5002 hash_func
= sha512_buffer
;
5005 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5007 /* allocate 2 x digest_size so that it can be re-used to hold the
5009 digest
= make_uninit_string (digest_size
* 2);
5011 hash_func (input
+ start_byte
,
5012 end_byte
- start_byte
,
5016 return make_digest_string (digest
, digest_size
);
5018 return make_unibyte_string (SSDATA (digest
), digest_size
);
5021 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5022 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5024 A message digest is a cryptographic checksum of a document, and the
5025 algorithm to calculate it is defined in RFC 1321.
5027 The two optional arguments START and END are character positions
5028 specifying for which part of OBJECT the message digest should be
5029 computed. If nil or omitted, the digest is computed for the whole
5032 The MD5 message digest is computed from the result of encoding the
5033 text in a coding system, not directly from the internal Emacs form of
5034 the text. The optional fourth argument CODING-SYSTEM specifies which
5035 coding system to encode the text with. It should be the same coding
5036 system that you used or will use when actually writing the text into a
5039 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5040 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5041 system would be chosen by default for writing this text into a file.
5043 If OBJECT is a string, the most preferred coding system (see the
5044 command `prefer-coding-system') is used.
5046 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5047 guesswork fails. Normally, an error is signaled in such case. */)
5048 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5050 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5053 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5054 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5055 ALGORITHM is a symbol specifying the hash to use:
5056 md5, sha1, sha224, sha256, sha384 or sha512.
5058 The two optional arguments START and END are positions specifying for
5059 which part of OBJECT to compute the hash. If nil or omitted, uses the
5062 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5064 If BINARY is non-nil, returns a string in binary form. */)
5065 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5067 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5070 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5071 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5072 This hash is performed on the raw internal format of the buffer,
5073 disregarding any coding systems. If nil, use the current buffer. */ )
5074 (Lisp_Object buffer_or_name
)
5078 struct sha1_ctx ctx
;
5080 if (NILP (buffer_or_name
))
5081 buffer
= Fcurrent_buffer ();
5083 buffer
= Fget_buffer (buffer_or_name
);
5085 nsberror (buffer_or_name
);
5087 b
= XBUFFER (buffer
);
5088 sha1_init_ctx (&ctx
);
5090 /* Process the first part of the buffer. */
5091 sha1_process_bytes (BUF_BEG_ADDR (b
),
5092 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5095 /* If the gap is before the end of the buffer, process the last half
5097 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5098 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5099 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5102 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5103 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5104 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5111 /* Hash table stuff. */
5112 DEFSYM (Qhash_table_p
, "hash-table-p");
5114 DEFSYM (Qeql
, "eql");
5115 DEFSYM (Qequal
, "equal");
5116 DEFSYM (QCtest
, ":test");
5117 DEFSYM (QCsize
, ":size");
5118 DEFSYM (QCpurecopy
, ":purecopy");
5119 DEFSYM (QCrehash_size
, ":rehash-size");
5120 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5121 DEFSYM (QCweakness
, ":weakness");
5122 DEFSYM (Qkey
, "key");
5123 DEFSYM (Qvalue
, "value");
5124 DEFSYM (Qhash_table_test
, "hash-table-test");
5125 DEFSYM (Qkey_or_value
, "key-or-value");
5126 DEFSYM (Qkey_and_value
, "key-and-value");
5128 defsubr (&Ssxhash_eq
);
5129 defsubr (&Ssxhash_eql
);
5130 defsubr (&Ssxhash_equal
);
5131 defsubr (&Smake_hash_table
);
5132 defsubr (&Scopy_hash_table
);
5133 defsubr (&Shash_table_count
);
5134 defsubr (&Shash_table_rehash_size
);
5135 defsubr (&Shash_table_rehash_threshold
);
5136 defsubr (&Shash_table_size
);
5137 defsubr (&Shash_table_test
);
5138 defsubr (&Shash_table_weakness
);
5139 defsubr (&Shash_table_p
);
5140 defsubr (&Sclrhash
);
5141 defsubr (&Sgethash
);
5142 defsubr (&Sputhash
);
5143 defsubr (&Sremhash
);
5144 defsubr (&Smaphash
);
5145 defsubr (&Sdefine_hash_table_test
);
5147 /* Crypto and hashing stuff. */
5148 DEFSYM (Qiv_auto
, "iv-auto");
5150 DEFSYM (Qmd5
, "md5");
5151 DEFSYM (Qsha1
, "sha1");
5152 DEFSYM (Qsha224
, "sha224");
5153 DEFSYM (Qsha256
, "sha256");
5154 DEFSYM (Qsha384
, "sha384");
5155 DEFSYM (Qsha512
, "sha512");
5157 /* Miscellaneous stuff. */
5159 DEFSYM (Qstring_lessp
, "string-lessp");
5160 DEFSYM (Qprovide
, "provide");
5161 DEFSYM (Qrequire
, "require");
5162 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5163 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5164 DEFSYM (Qwidget_type
, "widget-type");
5166 staticpro (&string_char_byte_cache_string
);
5167 string_char_byte_cache_string
= Qnil
;
5169 require_nesting_list
= Qnil
;
5170 staticpro (&require_nesting_list
);
5172 Fset (Qyes_or_no_p_history
, Qnil
);
5174 DEFVAR_LISP ("features", Vfeatures
,
5175 doc
: /* A list of symbols which are the features of the executing Emacs.
5176 Used by `featurep' and `require', and altered by `provide'. */);
5177 Vfeatures
= list1 (Qemacs
);
5178 DEFSYM (Qfeatures
, "features");
5179 /* Let people use lexically scoped vars named `features'. */
5180 Fmake_var_non_special (Qfeatures
);
5181 DEFSYM (Qsubfeatures
, "subfeatures");
5182 DEFSYM (Qfuncall
, "funcall");
5184 #ifdef HAVE_LANGINFO_CODESET
5185 DEFSYM (Qcodeset
, "codeset");
5186 DEFSYM (Qdays
, "days");
5187 DEFSYM (Qmonths
, "months");
5188 DEFSYM (Qpaper
, "paper");
5189 #endif /* HAVE_LANGINFO_CODESET */
5191 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5192 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5193 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5194 invoked by mouse clicks and mouse menu items.
5196 On some platforms, file selection dialogs are also enabled if this is
5200 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5201 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5202 This applies to commands from menus and tool bar buttons even when
5203 they are initiated from the keyboard. If `use-dialog-box' is nil,
5204 that disables the use of a file dialog, regardless of the value of
5206 use_file_dialog
= 1;
5208 defsubr (&Sidentity
);
5211 defsubr (&Ssafe_length
);
5212 defsubr (&Sstring_bytes
);
5213 defsubr (&Sstring_equal
);
5214 defsubr (&Scompare_strings
);
5215 defsubr (&Sstring_lessp
);
5216 defsubr (&Sstring_version_lessp
);
5217 defsubr (&Sstring_collate_lessp
);
5218 defsubr (&Sstring_collate_equalp
);
5221 defsubr (&Svconcat
);
5222 defsubr (&Scopy_sequence
);
5223 defsubr (&Sstring_make_multibyte
);
5224 defsubr (&Sstring_make_unibyte
);
5225 defsubr (&Sstring_as_multibyte
);
5226 defsubr (&Sstring_as_unibyte
);
5227 defsubr (&Sstring_to_multibyte
);
5228 defsubr (&Sstring_to_unibyte
);
5229 defsubr (&Scopy_alist
);
5230 defsubr (&Ssubstring
);
5231 defsubr (&Ssubstring_no_properties
);
5244 defsubr (&Snreverse
);
5245 defsubr (&Sreverse
);
5247 defsubr (&Splist_get
);
5249 defsubr (&Splist_put
);
5251 defsubr (&Slax_plist_get
);
5252 defsubr (&Slax_plist_put
);
5255 defsubr (&Sequal_including_properties
);
5256 defsubr (&Sfillarray
);
5257 defsubr (&Sclear_string
);
5262 defsubr (&Smapconcat
);
5263 defsubr (&Syes_or_no_p
);
5264 defsubr (&Sload_average
);
5265 defsubr (&Sfeaturep
);
5266 defsubr (&Srequire
);
5267 defsubr (&Sprovide
);
5268 defsubr (&Splist_member
);
5269 defsubr (&Swidget_put
);
5270 defsubr (&Swidget_get
);
5271 defsubr (&Swidget_apply
);
5272 defsubr (&Sbase64_encode_region
);
5273 defsubr (&Sbase64_decode_region
);
5274 defsubr (&Sbase64_encode_string
);
5275 defsubr (&Sbase64_decode_string
);
5277 defsubr (&Ssecure_hash_algorithms
);
5278 defsubr (&Ssecure_hash
);
5279 defsubr (&Sbuffer_hash
);
5280 defsubr (&Slocale_info
);