1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2016 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (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/>. */
24 #include <filevercmp.h>
30 #include "character.h"
32 #include "composite.h"
34 #include "intervals.h"
37 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
38 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
39 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
41 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
42 doc
: /* Return the argument unchanged. */
49 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
50 doc
: /* Return a pseudo-random number.
51 All integers representable in Lisp, i.e. between `most-negative-fixnum'
52 and `most-positive-fixnum', inclusive, are equally likely.
54 With positive integer LIMIT, return random number in interval [0,LIMIT).
55 With argument t, set the random number seed from the system's entropy
56 pool if available, otherwise from less-random volatile data such as the time.
57 With a string argument, set the seed based on the string's contents.
58 Other values of LIMIT are ignored.
60 See Info node `(elisp)Random Numbers' for more details. */)
67 else if (STRINGP (limit
))
68 seed_random (SSDATA (limit
), SBYTES (limit
));
71 if (INTEGERP (limit
) && 0 < XINT (limit
))
74 /* Return the remainder, except reject the rare case where
75 get_random returns a number so close to INTMASK that the
76 remainder isn't random. */
77 EMACS_INT remainder
= val
% XINT (limit
);
78 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
79 return make_number (remainder
);
82 return make_number (val
);
85 /* Heuristic on how many iterations of a tight loop can be safely done
86 before it's time to do a QUIT. This must be a power of 2. */
87 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
89 /* Random data-structure functions. */
92 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
94 CHECK_TYPE (NILP (x
), Qlistp
, y
);
97 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
98 doc
: /* Return the length of vector, list or string SEQUENCE.
99 A byte-code function object is also allowed.
100 If the string contains multibyte characters, this is not necessarily
101 the number of bytes in the string; it is the number of characters.
102 To get the number of bytes, use `string-bytes'. */)
103 (register Lisp_Object sequence
)
105 register Lisp_Object val
;
107 if (STRINGP (sequence
))
108 XSETFASTINT (val
, SCHARS (sequence
));
109 else if (VECTORP (sequence
))
110 XSETFASTINT (val
, ASIZE (sequence
));
111 else if (CHAR_TABLE_P (sequence
))
112 XSETFASTINT (val
, MAX_CHAR
);
113 else if (BOOL_VECTOR_P (sequence
))
114 XSETFASTINT (val
, bool_vector_size (sequence
));
115 else if (COMPILEDP (sequence
))
116 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
117 else if (CONSP (sequence
))
124 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
126 if (MOST_POSITIVE_FIXNUM
< i
)
127 error ("List too long");
130 sequence
= XCDR (sequence
);
132 while (CONSP (sequence
));
134 CHECK_LIST_END (sequence
, sequence
);
136 val
= make_number (i
);
138 else if (NILP (sequence
))
139 XSETFASTINT (val
, 0);
141 wrong_type_argument (Qsequencep
, sequence
);
146 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
147 doc
: /* Return the length of a list, but avoid error or infinite loop.
148 This function never gets an error. If LIST is not really a list,
149 it returns 0. If LIST is circular, it returns a finite value
150 which is at least the number of distinct elements. */)
153 Lisp_Object tail
, halftail
;
158 return make_number (0);
160 /* halftail is used to detect circular lists. */
161 for (tail
= halftail
= list
; ; )
166 if (EQ (tail
, halftail
))
169 if ((lolen
& 1) == 0)
171 halftail
= XCDR (halftail
);
172 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
176 hilen
+= UINTMAX_MAX
+ 1.0;
181 /* If the length does not fit into a fixnum, return a float.
182 On all known practical machines this returns an upper bound on
184 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
187 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
188 doc
: /* Return the number of bytes in STRING.
189 If STRING is multibyte, this may be greater than the length of STRING. */)
192 CHECK_STRING (string
);
193 return make_number (SBYTES (string
));
196 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
197 doc
: /* Return t if two strings have identical contents.
198 Case is significant, but text properties are ignored.
199 Symbols are also allowed; their print names are used instead. */)
200 (register Lisp_Object s1
, Lisp_Object s2
)
203 s1
= SYMBOL_NAME (s1
);
205 s2
= SYMBOL_NAME (s2
);
209 if (SCHARS (s1
) != SCHARS (s2
)
210 || SBYTES (s1
) != SBYTES (s2
)
211 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
216 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
217 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
218 The arguments START1, END1, START2, and END2, if non-nil, are
219 positions specifying which parts of STR1 or STR2 to compare. In
220 string STR1, compare the part between START1 (inclusive) and END1
221 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
222 the string; if END1 is nil, it defaults to the length of the string.
223 Likewise, in string STR2, compare the part between START2 and END2.
224 Like in `substring', negative values are counted from the end.
226 The strings are compared by the numeric values of their characters.
227 For instance, STR1 is "less than" STR2 if its first differing
228 character has a smaller numeric value. If IGNORE-CASE is non-nil,
229 characters are converted to upper-case before comparing them. Unibyte
230 strings are converted to multibyte for comparison.
232 The value is t if the strings (or specified portions) match.
233 If string STR1 is less, the value is a negative number N;
234 - 1 - N is the number of characters that match at the beginning.
235 If string STR1 is greater, the value is a positive number N;
236 N - 1 is the number of characters that match at the beginning. */)
237 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
238 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
240 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
245 /* For backward compatibility, silently bring too-large positive end
246 values into range. */
247 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
248 end1
= make_number (SCHARS (str1
));
249 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
250 end2
= make_number (SCHARS (str2
));
252 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
253 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
258 i1_byte
= string_char_to_byte (str1
, i1
);
259 i2_byte
= string_char_to_byte (str2
, i2
);
261 while (i1
< to1
&& i2
< to2
)
263 /* When we find a mismatch, we must compare the
264 characters, not just the bytes. */
267 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
268 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
273 if (! NILP (ignore_case
))
275 c1
= XINT (Fupcase (make_number (c1
)));
276 c2
= XINT (Fupcase (make_number (c2
)));
282 /* Note that I1 has already been incremented
283 past the character that we are comparing;
284 hence we don't add or subtract 1 here. */
286 return make_number (- i1
+ from1
);
288 return make_number (i1
- from1
);
292 return make_number (i1
- from1
+ 1);
294 return make_number (- i1
+ from1
- 1);
299 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
300 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
302 Symbols are also allowed; their print names are used instead. */)
303 (register Lisp_Object string1
, Lisp_Object string2
)
305 register ptrdiff_t end
;
306 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
308 if (SYMBOLP (string1
))
309 string1
= SYMBOL_NAME (string1
);
310 if (SYMBOLP (string2
))
311 string2
= SYMBOL_NAME (string2
);
312 CHECK_STRING (string1
);
313 CHECK_STRING (string2
);
315 i1
= i1_byte
= i2
= i2_byte
= 0;
317 end
= SCHARS (string1
);
318 if (end
> SCHARS (string2
))
319 end
= SCHARS (string2
);
323 /* When we find a mismatch, we must compare the
324 characters, not just the bytes. */
327 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
328 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
331 return c1
< c2
? Qt
: Qnil
;
333 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
336 DEFUN ("string-version-lessp", Fstring_version_lessp
,
337 Sstring_version_lessp
, 2, 2, 0,
338 doc
: /* Return non-nil if S1 is less than S2, as version strings.
340 This function compares version strings S1 and S2:
341 1) By prefix lexicographically.
342 2) Then by version (similarly to version comparison of Debian's dpkg).
343 Leading zeros in version numbers are ignored.
344 3) If both prefix and version are equal, compare as ordinary strings.
346 For example, \"foo2.png\" compares less than \"foo12.png\".
348 Symbols are also allowed; their print names are used instead. */)
349 (Lisp_Object string1
, Lisp_Object string2
)
351 if (SYMBOLP (string1
))
352 string1
= SYMBOL_NAME (string1
);
353 if (SYMBOLP (string2
))
354 string2
= SYMBOL_NAME (string2
);
355 CHECK_STRING (string1
);
356 CHECK_STRING (string2
);
358 char *p1
= SSDATA (string1
);
359 char *p2
= SSDATA (string2
);
360 char *lim1
= p1
+ SBYTES (string1
);
361 char *lim2
= p2
+ SBYTES (string2
);
364 while ((cmp
= filevercmp (p1
, p2
)) == 0)
366 /* If the strings are identical through their first null bytes,
367 skip past identical prefixes and try again. */
368 ptrdiff_t size
= strlen (p1
) + 1;
372 return lim2
< p2
? Qnil
: Qt
;
377 return cmp
< 0 ? Qt
: Qnil
;
380 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
381 doc
: /* Return t if first arg string is less than second in collation order.
382 Symbols are also allowed; their print names are used instead.
384 This function obeys the conventions for collation order in your
385 locale settings. For example, punctuation and whitespace characters
386 might be considered less significant for sorting:
388 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
389 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
391 The optional argument LOCALE, a string, overrides the setting of your
392 current locale identifier for collation. The value is system
393 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
394 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
396 If IGNORE-CASE is non-nil, characters are converted to lower-case
397 before comparing them.
399 To emulate Unicode-compliant collation on MS-Windows systems,
400 bind `w32-collate-ignore-punctuation' to a non-nil value, since
401 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
403 If your system does not support a locale environment, this function
404 behaves like `string-lessp'. */)
405 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
407 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
408 /* Check parameters. */
410 s1
= SYMBOL_NAME (s1
);
412 s2
= SYMBOL_NAME (s2
);
416 CHECK_STRING (locale
);
418 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
420 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
421 return Fstring_lessp (s1
, s2
);
422 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
425 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
426 doc
: /* Return t if two strings have identical contents.
427 Symbols are also allowed; their print names are used instead.
429 This function obeys the conventions for collation order in your locale
430 settings. For example, characters with different coding points but
431 the same meaning might be considered as equal, like different grave
432 accent Unicode characters:
434 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
437 The optional argument LOCALE, a string, overrides the setting of your
438 current locale identifier for collation. The value is system
439 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
440 while it would be \"enu_USA.1252\" on MS Windows systems.
442 If IGNORE-CASE is non-nil, characters are converted to lower-case
443 before comparing them.
445 To emulate Unicode-compliant collation on MS-Windows systems,
446 bind `w32-collate-ignore-punctuation' to a non-nil value, since
447 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
449 If your system does not support a locale environment, this function
450 behaves like `string-equal'.
452 Do NOT use this function to compare file names for equality, only
453 for sorting them. */)
454 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
456 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
457 /* Check parameters. */
459 s1
= SYMBOL_NAME (s1
);
461 s2
= SYMBOL_NAME (s2
);
465 CHECK_STRING (locale
);
467 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
469 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
470 return Fstring_equal (s1
, s2
);
471 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
474 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
475 enum Lisp_Type target_type
, bool last_special
);
479 concat2 (Lisp_Object s1
, Lisp_Object s2
)
481 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
486 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
488 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
491 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
492 doc
: /* Concatenate all the arguments and make the result a list.
493 The result is a list whose elements are the elements of all the arguments.
494 Each argument may be a list, vector or string.
495 The last argument is not copied, just used as the tail of the new list.
496 usage: (append &rest SEQUENCES) */)
497 (ptrdiff_t nargs
, Lisp_Object
*args
)
499 return concat (nargs
, args
, Lisp_Cons
, 1);
502 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
503 doc
: /* Concatenate all the arguments and make the result a string.
504 The result is a string whose elements are the elements of all the arguments.
505 Each argument may be a string or a list or vector of characters (integers).
506 usage: (concat &rest SEQUENCES) */)
507 (ptrdiff_t nargs
, Lisp_Object
*args
)
509 return concat (nargs
, args
, Lisp_String
, 0);
512 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
513 doc
: /* Concatenate all the arguments and make the result a vector.
514 The result is a vector whose elements are the elements of all the arguments.
515 Each argument may be a list, vector or string.
516 usage: (vconcat &rest SEQUENCES) */)
517 (ptrdiff_t nargs
, Lisp_Object
*args
)
519 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
523 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
524 doc
: /* Return a copy of a list, vector, string or char-table.
525 The elements of a list or vector are not copied; they are shared
526 with the original. */)
529 if (NILP (arg
)) return arg
;
531 if (CHAR_TABLE_P (arg
))
533 return copy_char_table (arg
);
536 if (BOOL_VECTOR_P (arg
))
538 EMACS_INT nbits
= bool_vector_size (arg
);
539 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
540 Lisp_Object val
= make_uninit_bool_vector (nbits
);
541 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
545 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
546 wrong_type_argument (Qsequencep
, arg
);
548 return concat (1, &arg
, XTYPE (arg
), 0);
551 /* This structure holds information of an argument of `concat' that is
552 a string and has text properties to be copied. */
555 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
556 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
557 ptrdiff_t to
; /* refer to VAL (the target string) */
561 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
562 enum Lisp_Type target_type
, bool last_special
)
568 ptrdiff_t toindex_byte
= 0;
569 EMACS_INT result_len
;
570 EMACS_INT result_len_byte
;
572 Lisp_Object last_tail
;
575 /* When we make a multibyte string, we can't copy text properties
576 while concatenating each string because the length of resulting
577 string can't be decided until we finish the whole concatenation.
578 So, we record strings that have text properties to be copied
579 here, and copy the text properties after the concatenation. */
580 struct textprop_rec
*textprops
= NULL
;
581 /* Number of elements in textprops. */
582 ptrdiff_t num_textprops
= 0;
587 /* In append, the last arg isn't treated like the others */
588 if (last_special
&& nargs
> 0)
591 last_tail
= args
[nargs
];
596 /* Check each argument. */
597 for (argnum
= 0; argnum
< nargs
; argnum
++)
600 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
601 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
602 wrong_type_argument (Qsequencep
, this);
605 /* Compute total length in chars of arguments in RESULT_LEN.
606 If desired output is a string, also compute length in bytes
607 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
608 whether the result should be a multibyte string. */
612 for (argnum
= 0; argnum
< nargs
; argnum
++)
616 len
= XFASTINT (Flength (this));
617 if (target_type
== Lisp_String
)
619 /* We must count the number of bytes needed in the string
620 as well as the number of characters. */
624 ptrdiff_t this_len_byte
;
626 if (VECTORP (this) || COMPILEDP (this))
627 for (i
= 0; i
< len
; i
++)
630 CHECK_CHARACTER (ch
);
632 this_len_byte
= CHAR_BYTES (c
);
633 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
635 result_len_byte
+= this_len_byte
;
636 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
639 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
640 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
641 else if (CONSP (this))
642 for (; CONSP (this); this = XCDR (this))
645 CHECK_CHARACTER (ch
);
647 this_len_byte
= CHAR_BYTES (c
);
648 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
650 result_len_byte
+= this_len_byte
;
651 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
654 else if (STRINGP (this))
656 if (STRING_MULTIBYTE (this))
659 this_len_byte
= SBYTES (this);
662 this_len_byte
= count_size_as_multibyte (SDATA (this),
664 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
666 result_len_byte
+= this_len_byte
;
671 if (MOST_POSITIVE_FIXNUM
< result_len
)
672 memory_full (SIZE_MAX
);
675 if (! some_multibyte
)
676 result_len_byte
= result_len
;
678 /* Create the output object. */
679 if (target_type
== Lisp_Cons
)
680 val
= Fmake_list (make_number (result_len
), Qnil
);
681 else if (target_type
== Lisp_Vectorlike
)
682 val
= Fmake_vector (make_number (result_len
), Qnil
);
683 else if (some_multibyte
)
684 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
686 val
= make_uninit_string (result_len
);
688 /* In `append', if all but last arg are nil, return last arg. */
689 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
692 /* Copy the contents of the args into the result. */
694 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
696 toindex
= 0, toindex_byte
= 0;
700 SAFE_NALLOCA (textprops
, 1, nargs
);
702 for (argnum
= 0; argnum
< nargs
; argnum
++)
705 ptrdiff_t thisleni
= 0;
706 register ptrdiff_t thisindex
= 0;
707 register ptrdiff_t thisindex_byte
= 0;
711 thislen
= Flength (this), thisleni
= XINT (thislen
);
713 /* Between strings of the same kind, copy fast. */
714 if (STRINGP (this) && STRINGP (val
)
715 && STRING_MULTIBYTE (this) == some_multibyte
)
717 ptrdiff_t thislen_byte
= SBYTES (this);
719 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
720 if (string_intervals (this))
722 textprops
[num_textprops
].argnum
= argnum
;
723 textprops
[num_textprops
].from
= 0;
724 textprops
[num_textprops
++].to
= toindex
;
726 toindex_byte
+= thislen_byte
;
729 /* Copy a single-byte string to a multibyte string. */
730 else if (STRINGP (this) && STRINGP (val
))
732 if (string_intervals (this))
734 textprops
[num_textprops
].argnum
= argnum
;
735 textprops
[num_textprops
].from
= 0;
736 textprops
[num_textprops
++].to
= toindex
;
738 toindex_byte
+= copy_text (SDATA (this),
739 SDATA (val
) + toindex_byte
,
740 SCHARS (this), 0, 1);
744 /* Copy element by element. */
747 register Lisp_Object elt
;
749 /* Fetch next element of `this' arg into `elt', or break if
750 `this' is exhausted. */
751 if (NILP (this)) break;
753 elt
= XCAR (this), this = XCDR (this);
754 else if (thisindex
>= thisleni
)
756 else if (STRINGP (this))
759 if (STRING_MULTIBYTE (this))
760 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
765 c
= SREF (this, thisindex
); thisindex
++;
766 if (some_multibyte
&& !ASCII_CHAR_P (c
))
767 c
= BYTE8_TO_CHAR (c
);
769 XSETFASTINT (elt
, c
);
771 else if (BOOL_VECTOR_P (this))
773 elt
= bool_vector_ref (this, thisindex
);
778 elt
= AREF (this, thisindex
);
782 /* Store this element into the result. */
789 else if (VECTORP (val
))
791 ASET (val
, toindex
, elt
);
797 CHECK_CHARACTER (elt
);
800 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
802 SSET (val
, toindex_byte
++, c
);
808 XSETCDR (prev
, last_tail
);
810 if (num_textprops
> 0)
813 ptrdiff_t last_to_end
= -1;
815 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
817 this = args
[textprops
[argnum
].argnum
];
818 props
= text_property_list (this,
820 make_number (SCHARS (this)),
822 /* If successive arguments have properties, be sure that the
823 value of `composition' property be the copy. */
824 if (last_to_end
== textprops
[argnum
].to
)
825 make_composition_value_copy (props
);
826 add_text_properties_from_list (val
, props
,
827 make_number (textprops
[argnum
].to
));
828 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
836 static Lisp_Object string_char_byte_cache_string
;
837 static ptrdiff_t string_char_byte_cache_charpos
;
838 static ptrdiff_t string_char_byte_cache_bytepos
;
841 clear_string_char_byte_cache (void)
843 string_char_byte_cache_string
= Qnil
;
846 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
849 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
852 ptrdiff_t best_below
, best_below_byte
;
853 ptrdiff_t best_above
, best_above_byte
;
855 best_below
= best_below_byte
= 0;
856 best_above
= SCHARS (string
);
857 best_above_byte
= SBYTES (string
);
858 if (best_above
== best_above_byte
)
861 if (EQ (string
, string_char_byte_cache_string
))
863 if (string_char_byte_cache_charpos
< char_index
)
865 best_below
= string_char_byte_cache_charpos
;
866 best_below_byte
= string_char_byte_cache_bytepos
;
870 best_above
= string_char_byte_cache_charpos
;
871 best_above_byte
= string_char_byte_cache_bytepos
;
875 if (char_index
- best_below
< best_above
- char_index
)
877 unsigned char *p
= SDATA (string
) + best_below_byte
;
879 while (best_below
< char_index
)
881 p
+= BYTES_BY_CHAR_HEAD (*p
);
884 i_byte
= p
- SDATA (string
);
888 unsigned char *p
= SDATA (string
) + best_above_byte
;
890 while (best_above
> char_index
)
893 while (!CHAR_HEAD_P (*p
)) p
--;
896 i_byte
= p
- SDATA (string
);
899 string_char_byte_cache_bytepos
= i_byte
;
900 string_char_byte_cache_charpos
= char_index
;
901 string_char_byte_cache_string
= string
;
906 /* Return the character index corresponding to BYTE_INDEX in STRING. */
909 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
912 ptrdiff_t best_below
, best_below_byte
;
913 ptrdiff_t best_above
, best_above_byte
;
915 best_below
= best_below_byte
= 0;
916 best_above
= SCHARS (string
);
917 best_above_byte
= SBYTES (string
);
918 if (best_above
== best_above_byte
)
921 if (EQ (string
, string_char_byte_cache_string
))
923 if (string_char_byte_cache_bytepos
< byte_index
)
925 best_below
= string_char_byte_cache_charpos
;
926 best_below_byte
= string_char_byte_cache_bytepos
;
930 best_above
= string_char_byte_cache_charpos
;
931 best_above_byte
= string_char_byte_cache_bytepos
;
935 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
937 unsigned char *p
= SDATA (string
) + best_below_byte
;
938 unsigned char *pend
= SDATA (string
) + byte_index
;
942 p
+= BYTES_BY_CHAR_HEAD (*p
);
946 i_byte
= p
- SDATA (string
);
950 unsigned char *p
= SDATA (string
) + best_above_byte
;
951 unsigned char *pbeg
= SDATA (string
) + byte_index
;
956 while (!CHAR_HEAD_P (*p
)) p
--;
960 i_byte
= p
- SDATA (string
);
963 string_char_byte_cache_bytepos
= i_byte
;
964 string_char_byte_cache_charpos
= i
;
965 string_char_byte_cache_string
= string
;
970 /* Convert STRING to a multibyte string. */
973 string_make_multibyte (Lisp_Object string
)
980 if (STRING_MULTIBYTE (string
))
983 nbytes
= count_size_as_multibyte (SDATA (string
),
985 /* If all the chars are ASCII, they won't need any more bytes
986 once converted. In that case, we can return STRING itself. */
987 if (nbytes
== SBYTES (string
))
990 buf
= SAFE_ALLOCA (nbytes
);
991 copy_text (SDATA (string
), buf
, SBYTES (string
),
994 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1001 /* Convert STRING (if unibyte) to a multibyte string without changing
1002 the number of characters. Characters 0200 trough 0237 are
1003 converted to eight-bit characters. */
1006 string_to_multibyte (Lisp_Object string
)
1013 if (STRING_MULTIBYTE (string
))
1016 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1017 /* If all the chars are ASCII, they won't need any more bytes once
1019 if (nbytes
== SBYTES (string
))
1020 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1022 buf
= SAFE_ALLOCA (nbytes
);
1023 memcpy (buf
, SDATA (string
), SBYTES (string
));
1024 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1026 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1033 /* Convert STRING to a single-byte string. */
1036 string_make_unibyte (Lisp_Object string
)
1043 if (! STRING_MULTIBYTE (string
))
1046 nchars
= SCHARS (string
);
1048 buf
= SAFE_ALLOCA (nchars
);
1049 copy_text (SDATA (string
), buf
, SBYTES (string
),
1052 ret
= make_unibyte_string ((char *) buf
, nchars
);
1058 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1060 doc
: /* Return the multibyte equivalent of STRING.
1061 If STRING is unibyte and contains non-ASCII characters, the function
1062 `unibyte-char-to-multibyte' is used to convert each unibyte character
1063 to a multibyte character. In this case, the returned string is a
1064 newly created string with no text properties. If STRING is multibyte
1065 or entirely ASCII, it is returned unchanged. In particular, when
1066 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1067 \(When the characters are all ASCII, Emacs primitives will treat the
1068 string the same way whether it is unibyte or multibyte.) */)
1069 (Lisp_Object string
)
1071 CHECK_STRING (string
);
1073 return string_make_multibyte (string
);
1076 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1078 doc
: /* Return the unibyte equivalent of STRING.
1079 Multibyte character codes are converted to unibyte according to
1080 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1081 If the lookup in the translation table fails, this function takes just
1082 the low 8 bits of each character. */)
1083 (Lisp_Object string
)
1085 CHECK_STRING (string
);
1087 return string_make_unibyte (string
);
1090 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1092 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1093 If STRING is unibyte, the result is STRING itself.
1094 Otherwise it is a newly created string, with no text properties.
1095 If STRING is multibyte and contains a character of charset
1096 `eight-bit', it is converted to the corresponding single byte. */)
1097 (Lisp_Object string
)
1099 CHECK_STRING (string
);
1101 if (STRING_MULTIBYTE (string
))
1103 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1104 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1106 string
= make_unibyte_string ((char *) str
, bytes
);
1112 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1114 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1115 If STRING is multibyte, the result is STRING itself.
1116 Otherwise it is a newly created string, with no text properties.
1118 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1119 part of a correct utf-8 sequence), it is converted to the corresponding
1120 multibyte character of charset `eight-bit'.
1121 See also `string-to-multibyte'.
1123 Beware, this often doesn't really do what you think it does.
1124 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1125 If you're not sure, whether to use `string-as-multibyte' or
1126 `string-to-multibyte', use `string-to-multibyte'. */)
1127 (Lisp_Object string
)
1129 CHECK_STRING (string
);
1131 if (! STRING_MULTIBYTE (string
))
1133 Lisp_Object new_string
;
1134 ptrdiff_t nchars
, nbytes
;
1136 parse_str_as_multibyte (SDATA (string
),
1139 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1140 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1141 if (nbytes
!= SBYTES (string
))
1142 str_as_multibyte (SDATA (new_string
), nbytes
,
1143 SBYTES (string
), NULL
);
1144 string
= new_string
;
1145 set_string_intervals (string
, NULL
);
1150 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1152 doc
: /* Return a multibyte string with the same individual chars as STRING.
1153 If STRING is multibyte, the result is STRING itself.
1154 Otherwise it is a newly created string, with no text properties.
1156 If STRING is unibyte and contains an 8-bit byte, it is converted to
1157 the corresponding multibyte character of charset `eight-bit'.
1159 This differs from `string-as-multibyte' by converting each byte of a correct
1160 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1161 correct sequence. */)
1162 (Lisp_Object string
)
1164 CHECK_STRING (string
);
1166 return string_to_multibyte (string
);
1169 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1171 doc
: /* Return a unibyte string with the same individual chars as STRING.
1172 If STRING is unibyte, the result is STRING itself.
1173 Otherwise it is a newly created string, with no text properties,
1174 where each `eight-bit' character is converted to the corresponding byte.
1175 If STRING contains a non-ASCII, non-`eight-bit' character,
1176 an error is signaled. */)
1177 (Lisp_Object string
)
1179 CHECK_STRING (string
);
1181 if (STRING_MULTIBYTE (string
))
1183 ptrdiff_t chars
= SCHARS (string
);
1184 unsigned char *str
= xmalloc (chars
);
1185 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1187 if (converted
< chars
)
1188 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1189 string
= make_unibyte_string ((char *) str
, chars
);
1196 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1197 doc
: /* Return a copy of ALIST.
1198 This is an alist which represents the same mapping from objects to objects,
1199 but does not share the alist structure with ALIST.
1200 The objects mapped (cars and cdrs of elements of the alist)
1201 are shared, however.
1202 Elements of ALIST that are not conses are also shared. */)
1205 register Lisp_Object tem
;
1210 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1211 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1213 register Lisp_Object car
;
1217 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1222 /* Check that ARRAY can have a valid subarray [FROM..TO),
1223 given that its size is SIZE.
1224 If FROM is nil, use 0; if TO is nil, use SIZE.
1225 Count negative values backwards from the end.
1226 Set *IFROM and *ITO to the two indexes used. */
1229 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1230 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1234 if (INTEGERP (from
))
1240 else if (NILP (from
))
1243 wrong_type_argument (Qintegerp
, from
);
1254 wrong_type_argument (Qintegerp
, to
);
1256 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1257 args_out_of_range_3 (array
, from
, to
);
1263 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1264 doc
: /* Return a new string whose contents are a substring of STRING.
1265 The returned string consists of the characters between index FROM
1266 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1267 zero-indexed: 0 means the first character of STRING. Negative values
1268 are counted from the end of STRING. If TO is nil, the substring runs
1269 to the end of STRING.
1271 The STRING argument may also be a vector. In that case, the return
1272 value is a new vector that contains the elements between index FROM
1273 \(inclusive) and index TO (exclusive) of that vector argument.
1275 With one argument, just copy STRING (with properties, if any). */)
1276 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1279 ptrdiff_t size
, ifrom
, ito
;
1281 size
= CHECK_VECTOR_OR_STRING (string
);
1282 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1284 if (STRINGP (string
))
1287 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1289 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1290 res
= make_specified_string (SSDATA (string
) + from_byte
,
1291 ito
- ifrom
, to_byte
- from_byte
,
1292 STRING_MULTIBYTE (string
));
1293 copy_text_properties (make_number (ifrom
), make_number (ito
),
1294 string
, make_number (0), res
, Qnil
);
1297 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1303 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1304 doc
: /* Return a substring of STRING, without text properties.
1305 It starts at index FROM and ends before TO.
1306 TO may be nil or omitted; then the substring runs to the end of STRING.
1307 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1308 If FROM or TO is negative, it counts from the end.
1310 With one argument, just copy STRING without its properties. */)
1311 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1313 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1315 CHECK_STRING (string
);
1317 size
= SCHARS (string
);
1318 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1320 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1322 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1323 return make_specified_string (SSDATA (string
) + from_byte
,
1324 to_char
- from_char
, to_byte
- from_byte
,
1325 STRING_MULTIBYTE (string
));
1328 /* Extract a substring of STRING, giving start and end positions
1329 both in characters and in bytes. */
1332 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1333 ptrdiff_t to
, ptrdiff_t to_byte
)
1336 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1338 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1339 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1341 if (STRINGP (string
))
1343 res
= make_specified_string (SSDATA (string
) + from_byte
,
1344 to
- from
, to_byte
- from_byte
,
1345 STRING_MULTIBYTE (string
));
1346 copy_text_properties (make_number (from
), make_number (to
),
1347 string
, make_number (0), res
, Qnil
);
1350 res
= Fvector (to
- from
, aref_addr (string
, from
));
1355 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1356 doc
: /* Take cdr N times on LIST, return the result. */)
1357 (Lisp_Object n
, Lisp_Object list
)
1362 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1365 CHECK_LIST_CONS (list
, list
);
1371 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1372 doc
: /* Return the Nth element of LIST.
1373 N counts from zero. If LIST is not that long, nil is returned. */)
1374 (Lisp_Object n
, Lisp_Object list
)
1376 return Fcar (Fnthcdr (n
, list
));
1379 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1380 doc
: /* Return element of SEQUENCE at index N. */)
1381 (register Lisp_Object sequence
, Lisp_Object n
)
1384 if (CONSP (sequence
) || NILP (sequence
))
1385 return Fcar (Fnthcdr (n
, sequence
));
1387 /* Faref signals a "not array" error, so check here. */
1388 CHECK_ARRAY (sequence
, Qsequencep
);
1389 return Faref (sequence
, n
);
1392 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1393 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1394 The value is actually the tail of LIST whose car is ELT. */)
1395 (register Lisp_Object elt
, Lisp_Object list
)
1397 register Lisp_Object tail
;
1398 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1400 register Lisp_Object tem
;
1401 CHECK_LIST_CONS (tail
, list
);
1403 if (! NILP (Fequal (elt
, tem
)))
1410 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1411 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1412 The value is actually the tail of LIST whose car is ELT. */)
1413 (register Lisp_Object elt
, Lisp_Object list
)
1417 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1421 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1425 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1436 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1437 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1438 The value is actually the tail of LIST whose car is ELT. */)
1439 (register Lisp_Object elt
, Lisp_Object list
)
1441 register Lisp_Object tail
;
1444 return Fmemq (elt
, list
);
1446 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1448 register Lisp_Object tem
;
1449 CHECK_LIST_CONS (tail
, list
);
1451 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1458 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1459 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1460 The value is actually the first element of LIST whose car is KEY.
1461 Elements of LIST that are not conses are ignored. */)
1462 (Lisp_Object key
, Lisp_Object list
)
1467 || (CONSP (XCAR (list
))
1468 && EQ (XCAR (XCAR (list
)), key
)))
1473 || (CONSP (XCAR (list
))
1474 && EQ (XCAR (XCAR (list
)), key
)))
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCAR (XCAR (list
)), key
)))
1490 /* Like Fassq but never report an error and do not allow quits.
1491 Use only on lists known never to be circular. */
1494 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1497 && (!CONSP (XCAR (list
))
1498 || !EQ (XCAR (XCAR (list
)), key
)))
1501 return CAR_SAFE (list
);
1504 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1505 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1506 The value is actually the first element of LIST whose car equals KEY. */)
1507 (Lisp_Object key
, Lisp_Object list
)
1514 || (CONSP (XCAR (list
))
1515 && (car
= XCAR (XCAR (list
)),
1516 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1521 || (CONSP (XCAR (list
))
1522 && (car
= XCAR (XCAR (list
)),
1523 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1528 || (CONSP (XCAR (list
))
1529 && (car
= XCAR (XCAR (list
)),
1530 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1540 /* Like Fassoc but never report an error and do not allow quits.
1541 Use only on lists known never to be circular. */
1544 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1547 && (!CONSP (XCAR (list
))
1548 || (!EQ (XCAR (XCAR (list
)), key
)
1549 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1552 return CONSP (list
) ? XCAR (list
) : Qnil
;
1555 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1556 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1557 The value is actually the first element of LIST whose cdr is KEY. */)
1558 (register Lisp_Object key
, Lisp_Object list
)
1563 || (CONSP (XCAR (list
))
1564 && EQ (XCDR (XCAR (list
)), key
)))
1569 || (CONSP (XCAR (list
))
1570 && EQ (XCDR (XCAR (list
)), key
)))
1575 || (CONSP (XCAR (list
))
1576 && EQ (XCDR (XCAR (list
)), key
)))
1586 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1587 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1588 The value is actually the first element of LIST whose cdr equals KEY. */)
1589 (Lisp_Object key
, Lisp_Object list
)
1596 || (CONSP (XCAR (list
))
1597 && (cdr
= XCDR (XCAR (list
)),
1598 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1603 || (CONSP (XCAR (list
))
1604 && (cdr
= XCDR (XCAR (list
)),
1605 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1610 || (CONSP (XCAR (list
))
1611 && (cdr
= XCDR (XCAR (list
)),
1612 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1622 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1623 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1624 More precisely, this function skips any members `eq' to ELT at the
1625 front of LIST, then removes members `eq' to ELT from the remaining
1626 sublist by modifying its list structure, then returns the resulting
1629 Write `(setq foo (delq element foo))' to be sure of correctly changing
1630 the value of a list `foo'. See also `remq', which does not modify the
1632 (register Lisp_Object elt
, Lisp_Object list
)
1634 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1637 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1639 Lisp_Object tem
= XCAR (tail
);
1645 Fsetcdr (prev
, XCDR (tail
));
1653 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1654 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1655 SEQ must be a sequence (i.e. a list, a vector, or a string).
1656 The return value is a sequence of the same type.
1658 If SEQ is a list, this behaves like `delq', except that it compares
1659 with `equal' instead of `eq'. In particular, it may remove elements
1660 by altering the list structure.
1662 If SEQ is not a list, deletion is never performed destructively;
1663 instead this function creates and returns a new vector or string.
1665 Write `(setq foo (delete element foo))' to be sure of correctly
1666 changing the value of a sequence `foo'. */)
1667 (Lisp_Object elt
, Lisp_Object seq
)
1673 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1674 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1677 if (n
!= ASIZE (seq
))
1679 struct Lisp_Vector
*p
= allocate_vector (n
);
1681 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1682 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1683 p
->contents
[n
++] = AREF (seq
, i
);
1685 XSETVECTOR (seq
, p
);
1688 else if (STRINGP (seq
))
1690 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1693 for (i
= nchars
= nbytes
= ibyte
= 0;
1695 ++i
, ibyte
+= cbytes
)
1697 if (STRING_MULTIBYTE (seq
))
1699 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1700 cbytes
= CHAR_BYTES (c
);
1708 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1715 if (nchars
!= SCHARS (seq
))
1719 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1720 if (!STRING_MULTIBYTE (seq
))
1721 STRING_SET_UNIBYTE (tem
);
1723 for (i
= nchars
= nbytes
= ibyte
= 0;
1725 ++i
, ibyte
+= cbytes
)
1727 if (STRING_MULTIBYTE (seq
))
1729 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1730 cbytes
= CHAR_BYTES (c
);
1738 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1740 unsigned char *from
= SDATA (seq
) + ibyte
;
1741 unsigned char *to
= SDATA (tem
) + nbytes
;
1747 for (n
= cbytes
; n
--; )
1757 Lisp_Object tail
, prev
;
1759 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1761 CHECK_LIST_CONS (tail
, seq
);
1763 if (!NILP (Fequal (elt
, XCAR (tail
))))
1768 Fsetcdr (prev
, XCDR (tail
));
1779 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1780 doc
: /* Reverse order of items in a list, vector or string SEQ.
1781 If SEQ is a list, it should be nil-terminated.
1782 This function may destructively modify SEQ to produce the value. */)
1787 else if (STRINGP (seq
))
1788 return Freverse (seq
);
1789 else if (CONSP (seq
))
1791 Lisp_Object prev
, tail
, next
;
1793 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1796 CHECK_LIST_CONS (tail
, tail
);
1798 Fsetcdr (tail
, prev
);
1803 else if (VECTORP (seq
))
1805 ptrdiff_t i
, size
= ASIZE (seq
);
1807 for (i
= 0; i
< size
/ 2; i
++)
1809 Lisp_Object tem
= AREF (seq
, i
);
1810 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1811 ASET (seq
, size
- i
- 1, tem
);
1814 else if (BOOL_VECTOR_P (seq
))
1816 ptrdiff_t i
, size
= bool_vector_size (seq
);
1818 for (i
= 0; i
< size
/ 2; i
++)
1820 bool tem
= bool_vector_bitref (seq
, i
);
1821 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1822 bool_vector_set (seq
, size
- i
- 1, tem
);
1826 wrong_type_argument (Qarrayp
, seq
);
1830 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1831 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1832 See also the function `nreverse', which is used more often. */)
1839 else if (CONSP (seq
))
1841 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1844 new = Fcons (XCAR (seq
), new);
1846 CHECK_LIST_END (seq
, seq
);
1848 else if (VECTORP (seq
))
1850 ptrdiff_t i
, size
= ASIZE (seq
);
1852 new = make_uninit_vector (size
);
1853 for (i
= 0; i
< size
; i
++)
1854 ASET (new, i
, AREF (seq
, size
- i
- 1));
1856 else if (BOOL_VECTOR_P (seq
))
1859 EMACS_INT nbits
= bool_vector_size (seq
);
1861 new = make_uninit_bool_vector (nbits
);
1862 for (i
= 0; i
< nbits
; i
++)
1863 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1865 else if (STRINGP (seq
))
1867 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1873 new = make_uninit_string (size
);
1874 for (i
= 0; i
< size
; i
++)
1875 SSET (new, i
, SREF (seq
, size
- i
- 1));
1879 unsigned char *p
, *q
;
1881 new = make_uninit_multibyte_string (size
, bytes
);
1882 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1883 while (q
> SDATA (new))
1887 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1889 CHAR_STRING (ch
, q
);
1894 wrong_type_argument (Qsequencep
, seq
);
1898 /* Sort LIST using PREDICATE, preserving original order of elements
1899 considered as equal. */
1902 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1904 Lisp_Object front
, back
;
1905 Lisp_Object len
, tem
;
1909 len
= Flength (list
);
1910 length
= XINT (len
);
1914 XSETINT (len
, (length
/ 2) - 1);
1915 tem
= Fnthcdr (len
, list
);
1917 Fsetcdr (tem
, Qnil
);
1919 front
= Fsort (front
, predicate
);
1920 back
= Fsort (back
, predicate
);
1921 return merge (front
, back
, predicate
);
1924 /* Using PRED to compare, return whether A and B are in order.
1925 Compare stably when A appeared before B in the input. */
1927 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1929 return NILP (call2 (pred
, b
, a
));
1932 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1933 into DEST. Argument arrays must be nonempty and must not overlap,
1934 except that B might be the last part of DEST. */
1936 merge_vectors (Lisp_Object pred
,
1937 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1938 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1939 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1941 eassume (0 < alen
&& 0 < blen
);
1942 Lisp_Object
const *alim
= a
+ alen
;
1943 Lisp_Object
const *blim
= b
+ blen
;
1947 if (inorder (pred
, a
[0], b
[0]))
1953 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1962 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1969 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1970 temporary storage. LEN must be at least 2. */
1972 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1973 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1974 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1977 ptrdiff_t halflen
= len
>> 1;
1978 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1979 if (1 < len
- halflen
)
1980 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1981 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1984 /* Using PRED to compare, sort from LEN-length SRC into DST.
1985 Len must be positive. */
1987 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1988 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1989 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1992 ptrdiff_t halflen
= len
>> 1;
1998 sort_vector_inplace (pred
, halflen
, src
, dest
);
1999 if (1 < len
- halflen
)
2000 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
2001 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
2005 /* Sort VECTOR in place using PREDICATE, preserving original order of
2006 elements considered as equal. */
2009 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
2011 ptrdiff_t len
= ASIZE (vector
);
2014 ptrdiff_t halflen
= len
>> 1;
2017 SAFE_ALLOCA_LISP (tmp
, halflen
);
2018 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
2019 tmp
[i
] = make_number (0);
2020 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2024 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2025 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2026 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2027 modified by side effects. PREDICATE is called with two elements of
2028 SEQ, and should return non-nil if the first element should sort before
2030 (Lisp_Object seq
, Lisp_Object predicate
)
2033 seq
= sort_list (seq
, predicate
);
2034 else if (VECTORP (seq
))
2035 sort_vector (seq
, predicate
);
2036 else if (!NILP (seq
))
2037 wrong_type_argument (Qsequencep
, seq
);
2042 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2044 Lisp_Object l1
= org_l1
;
2045 Lisp_Object l2
= org_l2
;
2046 Lisp_Object tail
= Qnil
;
2047 Lisp_Object value
= Qnil
;
2067 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2082 Fsetcdr (tail
, tem
);
2088 /* This does not check for quits. That is safe since it must terminate. */
2090 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2091 doc
: /* Extract a value from a property list.
2092 PLIST is a property list, which is a list of the form
2093 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2094 corresponding to the given PROP, or nil if PROP is not one of the
2095 properties on the list. This function never signals an error. */)
2096 (Lisp_Object plist
, Lisp_Object prop
)
2098 Lisp_Object tail
, halftail
;
2100 /* halftail is used to detect circular lists. */
2101 tail
= halftail
= plist
;
2102 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2104 if (EQ (prop
, XCAR (tail
)))
2105 return XCAR (XCDR (tail
));
2107 tail
= XCDR (XCDR (tail
));
2108 halftail
= XCDR (halftail
);
2109 if (EQ (tail
, halftail
))
2116 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2117 doc
: /* Return the value of SYMBOL's PROPNAME property.
2118 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2119 (Lisp_Object symbol
, Lisp_Object propname
)
2121 CHECK_SYMBOL (symbol
);
2122 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2125 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2126 doc
: /* Change value in PLIST of PROP to VAL.
2127 PLIST is a property list, which is a list of the form
2128 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2129 If PROP is already a property on the list, its value is set to VAL,
2130 otherwise the new PROP VAL pair is added. The new plist is returned;
2131 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2132 The PLIST is modified by side effects. */)
2133 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2135 register Lisp_Object tail
, prev
;
2136 Lisp_Object newcell
;
2138 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2139 tail
= XCDR (XCDR (tail
)))
2141 if (EQ (prop
, XCAR (tail
)))
2143 Fsetcar (XCDR (tail
), val
);
2150 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2154 Fsetcdr (XCDR (prev
), newcell
);
2158 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2159 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2160 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2161 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2163 CHECK_SYMBOL (symbol
);
2165 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2169 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2170 doc
: /* Extract a value from a property list, comparing with `equal'.
2171 PLIST is a property list, which is a list of the form
2172 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2173 corresponding to the given PROP, or nil if PROP is not
2174 one of the properties on the list. */)
2175 (Lisp_Object plist
, Lisp_Object prop
)
2180 CONSP (tail
) && CONSP (XCDR (tail
));
2181 tail
= XCDR (XCDR (tail
)))
2183 if (! NILP (Fequal (prop
, XCAR (tail
))))
2184 return XCAR (XCDR (tail
));
2189 CHECK_LIST_END (tail
, prop
);
2194 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2195 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2196 PLIST is a property list, which is a list of the form
2197 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2198 If PROP is already a property on the list, its value is set to VAL,
2199 otherwise the new PROP VAL pair is added. The new plist is returned;
2200 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2201 The PLIST is modified by side effects. */)
2202 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2204 register Lisp_Object tail
, prev
;
2205 Lisp_Object newcell
;
2207 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2208 tail
= XCDR (XCDR (tail
)))
2210 if (! NILP (Fequal (prop
, XCAR (tail
))))
2212 Fsetcar (XCDR (tail
), val
);
2219 newcell
= list2 (prop
, val
);
2223 Fsetcdr (XCDR (prev
), newcell
);
2227 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2228 doc
: /* Return t if the two args are the same Lisp object.
2229 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2230 (Lisp_Object obj1
, Lisp_Object obj2
)
2233 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2235 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2238 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2239 doc
: /* Return t if two Lisp objects have similar structure and contents.
2240 They must have the same data type.
2241 Conses are compared by comparing the cars and the cdrs.
2242 Vectors and strings are compared element by element.
2243 Numbers are compared by value, but integers cannot equal floats.
2244 (Use `=' if you want integers and floats to be able to be equal.)
2245 Symbols must match exactly. */)
2246 (register Lisp_Object o1
, Lisp_Object o2
)
2248 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2251 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2252 doc
: /* Return t if two Lisp objects have similar structure and contents.
2253 This is like `equal' except that it compares the text properties
2254 of strings. (`equal' ignores text properties.) */)
2255 (register Lisp_Object o1
, Lisp_Object o2
)
2257 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2260 /* DEPTH is current depth of recursion. Signal an error if it
2262 PROPS means compare string text properties too. */
2265 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2271 error ("Stack overflow in equal");
2273 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2276 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2278 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2280 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2282 { /* `o1' was seen already. */
2283 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2284 if (!NILP (Fmemq (o2
, o2s
)))
2287 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2290 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2300 if (XTYPE (o1
) != XTYPE (o2
))
2309 d1
= extract_float (o1
);
2310 d2
= extract_float (o2
);
2311 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2312 though they are not =. */
2313 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2317 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2321 /* FIXME: This inf-loops in a circular list! */
2325 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2329 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2330 depth
+ 1, props
, ht
)
2331 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2332 depth
+ 1, props
, ht
))
2334 o1
= XOVERLAY (o1
)->plist
;
2335 o2
= XOVERLAY (o2
)->plist
;
2340 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2341 && (XMARKER (o1
)->buffer
== 0
2342 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2346 case Lisp_Vectorlike
:
2349 ptrdiff_t size
= ASIZE (o1
);
2350 /* Pseudovectors have the type encoded in the size field, so this test
2351 actually checks that the objects have the same type as well as the
2353 if (ASIZE (o2
) != size
)
2355 /* Boolvectors are compared much like strings. */
2356 if (BOOL_VECTOR_P (o1
))
2358 EMACS_INT size
= bool_vector_size (o1
);
2359 if (size
!= bool_vector_size (o2
))
2361 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2362 bool_vector_bytes (size
)))
2366 if (WINDOW_CONFIGURATIONP (o1
))
2367 return compare_window_configurations (o1
, o2
, 0);
2369 /* Aside from them, only true vectors, char-tables, compiled
2370 functions, and fonts (font-spec, font-entity, font-object)
2371 are sensible to compare, so eliminate the others now. */
2372 if (size
& PSEUDOVECTOR_FLAG
)
2374 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2377 size
&= PSEUDOVECTOR_SIZE_MASK
;
2379 for (i
= 0; i
< size
; i
++)
2384 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2392 if (SCHARS (o1
) != SCHARS (o2
))
2394 if (SBYTES (o1
) != SBYTES (o2
))
2396 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2398 if (props
&& !compare_string_intervals (o1
, o2
))
2410 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2411 doc
: /* Store each element of ARRAY with ITEM.
2412 ARRAY is a vector, string, char-table, or bool-vector. */)
2413 (Lisp_Object array
, Lisp_Object item
)
2415 register ptrdiff_t size
, idx
;
2417 if (VECTORP (array
))
2418 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2419 ASET (array
, idx
, item
);
2420 else if (CHAR_TABLE_P (array
))
2424 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2425 set_char_table_contents (array
, i
, item
);
2426 set_char_table_defalt (array
, item
);
2428 else if (STRINGP (array
))
2430 register unsigned char *p
= SDATA (array
);
2432 CHECK_CHARACTER (item
);
2433 charval
= XFASTINT (item
);
2434 size
= SCHARS (array
);
2435 if (STRING_MULTIBYTE (array
))
2437 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2438 int len
= CHAR_STRING (charval
, str
);
2439 ptrdiff_t size_byte
= SBYTES (array
);
2442 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2443 error ("Attempt to change byte length of a string");
2444 for (idx
= 0; idx
< size_byte
; idx
++)
2445 *p
++ = str
[idx
% len
];
2448 for (idx
= 0; idx
< size
; idx
++)
2451 else if (BOOL_VECTOR_P (array
))
2452 return bool_vector_fill (array
, item
);
2454 wrong_type_argument (Qarrayp
, array
);
2458 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2460 doc
: /* Clear the contents of STRING.
2461 This makes STRING unibyte and may change its length. */)
2462 (Lisp_Object string
)
2465 CHECK_STRING (string
);
2466 len
= SBYTES (string
);
2467 memset (SDATA (string
), 0, len
);
2468 STRING_SET_CHARS (string
, len
);
2469 STRING_SET_UNIBYTE (string
);
2475 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2477 return CALLN (Fnconc
, s1
, s2
);
2480 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2481 doc
: /* Concatenate any number of lists by altering them.
2482 Only the last argument is not altered, and need not be a list.
2483 usage: (nconc &rest LISTS) */)
2484 (ptrdiff_t nargs
, Lisp_Object
*args
)
2487 register Lisp_Object tail
, tem
, val
;
2491 for (argnum
= 0; argnum
< nargs
; argnum
++)
2494 if (NILP (tem
)) continue;
2499 if (argnum
+ 1 == nargs
) break;
2501 CHECK_LIST_CONS (tem
, tem
);
2510 tem
= args
[argnum
+ 1];
2511 Fsetcdr (tail
, tem
);
2513 args
[argnum
+ 1] = tail
;
2519 /* This is the guts of all mapping functions.
2520 Apply FN to each element of SEQ, one by one,
2521 storing the results into elements of VALS, a C vector of Lisp_Objects.
2522 LENI is the length of VALS, which should also be the length of SEQ. */
2525 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2527 Lisp_Object tail
, dummy
;
2530 if (VECTORP (seq
) || COMPILEDP (seq
))
2532 for (i
= 0; i
< leni
; i
++)
2534 dummy
= call1 (fn
, AREF (seq
, i
));
2539 else if (BOOL_VECTOR_P (seq
))
2541 for (i
= 0; i
< leni
; i
++)
2543 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2548 else if (STRINGP (seq
))
2552 for (i
= 0, i_byte
= 0; i
< leni
;)
2555 ptrdiff_t i_before
= i
;
2557 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2558 XSETFASTINT (dummy
, c
);
2559 dummy
= call1 (fn
, dummy
);
2561 vals
[i_before
] = dummy
;
2564 else /* Must be a list, since Flength did not get an error */
2567 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2569 dummy
= call1 (fn
, XCAR (tail
));
2577 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2578 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2579 In between each pair of results, stick in SEPARATOR. Thus, " " as
2580 SEPARATOR results in spaces between the values returned by FUNCTION.
2581 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2582 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2592 len
= Flength (sequence
);
2593 if (CHAR_TABLE_P (sequence
))
2594 wrong_type_argument (Qlistp
, sequence
);
2596 nargs
= leni
+ leni
- 1;
2597 if (nargs
< 0) return empty_unibyte_string
;
2599 SAFE_ALLOCA_LISP (args
, nargs
);
2601 mapcar1 (leni
, args
, function
, sequence
);
2603 for (i
= leni
- 1; i
> 0; i
--)
2604 args
[i
+ i
] = args
[i
];
2606 for (i
= 1; i
< nargs
; i
+= 2)
2607 args
[i
] = separator
;
2609 ret
= Fconcat (nargs
, args
);
2615 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2616 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2617 The result is a list just as long as SEQUENCE.
2618 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2619 (Lisp_Object function
, Lisp_Object sequence
)
2621 register Lisp_Object len
;
2622 register EMACS_INT leni
;
2623 register Lisp_Object
*args
;
2627 len
= Flength (sequence
);
2628 if (CHAR_TABLE_P (sequence
))
2629 wrong_type_argument (Qlistp
, sequence
);
2630 leni
= XFASTINT (len
);
2632 SAFE_ALLOCA_LISP (args
, leni
);
2634 mapcar1 (leni
, args
, function
, sequence
);
2636 ret
= Flist (leni
, args
);
2642 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2643 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2644 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2645 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2646 (Lisp_Object function
, Lisp_Object sequence
)
2648 register EMACS_INT leni
;
2650 leni
= XFASTINT (Flength (sequence
));
2651 if (CHAR_TABLE_P (sequence
))
2652 wrong_type_argument (Qlistp
, sequence
);
2653 mapcar1 (leni
, 0, function
, sequence
);
2658 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2659 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2660 the results by altering them (using `nconc').
2661 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2662 (Lisp_Object function
, Lisp_Object sequence
)
2664 register EMACS_INT leni
;
2665 register Lisp_Object
*args
;
2669 if (CHAR_TABLE_P (sequence
))
2670 wrong_type_argument (Qlistp
, sequence
);
2672 leni
= XFASTINT (Flength (sequence
));
2673 SAFE_ALLOCA_LISP (args
, leni
);
2674 mapcar1 (leni
, args
, function
, sequence
);
2675 ret
= Fnconc (leni
, args
);
2682 /* This is how C code calls `yes-or-no-p' and allows the user
2686 do_yes_or_no_p (Lisp_Object prompt
)
2688 return call1 (intern ("yes-or-no-p"), prompt
);
2691 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2692 doc
: /* Ask user a yes-or-no question.
2693 Return t if answer is yes, and nil if the answer is no.
2694 PROMPT is the string to display to ask the question. It should end in
2695 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2697 The user must confirm the answer with RET, and can edit it until it
2700 If dialog boxes are supported, a dialog box will be used
2701 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2702 (Lisp_Object prompt
)
2706 CHECK_STRING (prompt
);
2708 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2709 && use_dialog_box
&& ! NILP (last_input_event
))
2711 Lisp_Object pane
, menu
, obj
;
2712 redisplay_preserve_echo_area (4);
2713 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2714 Fcons (build_string ("No"), Qnil
));
2715 menu
= Fcons (prompt
, pane
);
2716 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2720 AUTO_STRING (yes_or_no
, "(yes or no) ");
2721 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2725 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2726 Qyes_or_no_p_history
, Qnil
,
2728 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2730 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2735 message1 ("Please answer yes or no.");
2736 Fsleep_for (make_number (2), Qnil
);
2740 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2741 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2743 Each of the three load averages is multiplied by 100, then converted
2746 When USE-FLOATS is non-nil, floats will be used instead of integers.
2747 These floats are not multiplied by 100.
2749 If the 5-minute or 15-minute load averages are not available, return a
2750 shortened list, containing only those averages which are available.
2752 An error is thrown if the load average can't be obtained. In some
2753 cases making it work would require Emacs being installed setuid or
2754 setgid so that it can read kernel information, and that usually isn't
2756 (Lisp_Object use_floats
)
2759 int loads
= getloadavg (load_ave
, 3);
2760 Lisp_Object ret
= Qnil
;
2763 error ("load-average not implemented for this operating system");
2767 Lisp_Object load
= (NILP (use_floats
)
2768 ? make_number (100.0 * load_ave
[loads
])
2769 : make_float (load_ave
[loads
]));
2770 ret
= Fcons (load
, ret
);
2776 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2777 doc
: /* Return t if FEATURE is present in this Emacs.
2779 Use this to conditionalize execution of lisp code based on the
2780 presence or absence of Emacs or environment extensions.
2781 Use `provide' to declare that a feature is available. This function
2782 looks at the value of the variable `features'. The optional argument
2783 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2784 (Lisp_Object feature
, Lisp_Object subfeature
)
2786 register Lisp_Object tem
;
2787 CHECK_SYMBOL (feature
);
2788 tem
= Fmemq (feature
, Vfeatures
);
2789 if (!NILP (tem
) && !NILP (subfeature
))
2790 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2791 return (NILP (tem
)) ? Qnil
: Qt
;
2794 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2795 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2796 The optional argument SUBFEATURES should be a list of symbols listing
2797 particular subfeatures supported in this version of FEATURE. */)
2798 (Lisp_Object feature
, Lisp_Object subfeatures
)
2800 register Lisp_Object tem
;
2801 CHECK_SYMBOL (feature
);
2802 CHECK_LIST (subfeatures
);
2803 if (!NILP (Vautoload_queue
))
2804 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2806 tem
= Fmemq (feature
, Vfeatures
);
2808 Vfeatures
= Fcons (feature
, Vfeatures
);
2809 if (!NILP (subfeatures
))
2810 Fput (feature
, Qsubfeatures
, subfeatures
);
2811 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2813 /* Run any load-hooks for this file. */
2814 tem
= Fassq (feature
, Vafter_load_alist
);
2816 Fmapc (Qfuncall
, XCDR (tem
));
2821 /* `require' and its subroutines. */
2823 /* List of features currently being require'd, innermost first. */
2825 static Lisp_Object require_nesting_list
;
2828 require_unwind (Lisp_Object old_value
)
2830 require_nesting_list
= old_value
;
2833 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2834 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2835 If FEATURE is not a member of the list `features', then the feature is
2836 not loaded; so load the file FILENAME.
2838 If FILENAME is omitted, the printname of FEATURE is used as the file
2839 name, and `load' will try to load this name appended with the suffix
2840 `.elc', `.el', or the system-dependent suffix for dynamic module
2841 files, in that order. The name without appended suffix will not be
2842 used. See `get-load-suffixes' for the complete list of suffixes.
2844 The directories in `load-path' are searched when trying to find the
2847 If the optional third argument NOERROR is non-nil, then return nil if
2848 the file is not found instead of signaling an error. Normally the
2849 return value is FEATURE.
2851 The normal messages at start and end of loading FILENAME are
2853 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2856 bool from_file
= load_in_progress
;
2858 CHECK_SYMBOL (feature
);
2860 /* Record the presence of `require' in this file
2861 even if the feature specified is already loaded.
2862 But not more than once in any file,
2863 and not when we aren't loading or reading from a file. */
2865 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2866 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2871 tem
= Fcons (Qrequire
, feature
);
2872 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2873 LOADHIST_ATTACH (tem
);
2875 tem
= Fmemq (feature
, Vfeatures
);
2879 ptrdiff_t count
= SPECPDL_INDEX ();
2882 /* This is to make sure that loadup.el gives a clear picture
2883 of what files are preloaded and when. */
2884 if (! NILP (Vpurify_flag
))
2885 error ("(require %s) while preparing to dump",
2886 SDATA (SYMBOL_NAME (feature
)));
2888 /* A certain amount of recursive `require' is legitimate,
2889 but if we require the same feature recursively 3 times,
2891 tem
= require_nesting_list
;
2892 while (! NILP (tem
))
2894 if (! NILP (Fequal (feature
, XCAR (tem
))))
2899 error ("Recursive `require' for feature `%s'",
2900 SDATA (SYMBOL_NAME (feature
)));
2902 /* Update the list for any nested `require's that occur. */
2903 record_unwind_protect (require_unwind
, require_nesting_list
);
2904 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2906 /* Value saved here is to be restored into Vautoload_queue */
2907 record_unwind_protect (un_autoload
, Vautoload_queue
);
2908 Vautoload_queue
= Qt
;
2910 /* Load the file. */
2911 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2912 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2914 /* If load failed entirely, return nil. */
2916 return unbind_to (count
, Qnil
);
2918 tem
= Fmemq (feature
, Vfeatures
);
2920 error ("Required feature `%s' was not provided",
2921 SDATA (SYMBOL_NAME (feature
)));
2923 /* Once loading finishes, don't undo it. */
2924 Vautoload_queue
= Qt
;
2925 feature
= unbind_to (count
, feature
);
2931 /* Primitives for work of the "widget" library.
2932 In an ideal world, this section would not have been necessary.
2933 However, lisp function calls being as slow as they are, it turns
2934 out that some functions in the widget library (wid-edit.el) are the
2935 bottleneck of Widget operation. Here is their translation to C,
2936 for the sole reason of efficiency. */
2938 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2939 doc
: /* Return non-nil if PLIST has the property PROP.
2940 PLIST is a property list, which is a list of the form
2941 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2942 Unlike `plist-get', this allows you to distinguish between a missing
2943 property and a property with the value nil.
2944 The value is actually the tail of PLIST whose car is PROP. */)
2945 (Lisp_Object plist
, Lisp_Object prop
)
2947 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2949 plist
= XCDR (plist
);
2950 plist
= CDR (plist
);
2956 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2957 doc
: /* In WIDGET, set PROPERTY to VALUE.
2958 The value can later be retrieved with `widget-get'. */)
2959 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2961 CHECK_CONS (widget
);
2962 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2966 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2967 doc
: /* In WIDGET, get the value of PROPERTY.
2968 The value could either be specified when the widget was created, or
2969 later with `widget-put'. */)
2970 (Lisp_Object widget
, Lisp_Object property
)
2978 CHECK_CONS (widget
);
2979 tmp
= Fplist_member (XCDR (widget
), property
);
2985 tmp
= XCAR (widget
);
2988 widget
= Fget (tmp
, Qwidget_type
);
2992 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2993 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2994 ARGS are passed as extra arguments to the function.
2995 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2996 (ptrdiff_t nargs
, Lisp_Object
*args
)
2998 Lisp_Object widget
= args
[0];
2999 Lisp_Object property
= args
[1];
3000 Lisp_Object propval
= Fwidget_get (widget
, property
);
3001 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
3002 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
3006 #ifdef HAVE_LANGINFO_CODESET
3007 #include <langinfo.h>
3010 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3011 doc
: /* Access locale data ITEM for the current C locale, if available.
3012 ITEM should be one of the following:
3014 `codeset', returning the character set as a string (locale item CODESET);
3016 `days', returning a 7-element vector of day names (locale items DAY_n);
3018 `months', returning a 12-element vector of month names (locale items MON_n);
3020 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3021 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3023 If the system can't provide such information through a call to
3024 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3026 See also Info node `(libc)Locales'.
3028 The data read from the system are decoded using `locale-coding-system'. */)
3032 #ifdef HAVE_LANGINFO_CODESET
3033 if (EQ (item
, Qcodeset
))
3035 str
= nl_langinfo (CODESET
);
3036 return build_string (str
);
3039 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3041 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3042 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3044 synchronize_system_time_locale ();
3045 for (i
= 0; i
< 7; i
++)
3047 str
= nl_langinfo (days
[i
]);
3048 AUTO_STRING (val
, str
);
3049 /* Fixme: Is this coding system necessarily right, even if
3050 it is consistent with CODESET? If not, what to do? */
3051 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3058 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3060 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3061 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3062 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3064 synchronize_system_time_locale ();
3065 for (i
= 0; i
< 12; i
++)
3067 str
= nl_langinfo (months
[i
]);
3068 AUTO_STRING (val
, str
);
3069 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3075 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3076 but is in the locale files. This could be used by ps-print. */
3078 else if (EQ (item
, Qpaper
))
3079 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3080 #endif /* PAPER_WIDTH */
3081 #endif /* HAVE_LANGINFO_CODESET*/
3085 /* base64 encode/decode functions (RFC 2045).
3086 Based on code from GNU recode. */
3088 #define MIME_LINE_LENGTH 76
3090 #define IS_ASCII(Character) \
3092 #define IS_BASE64(Character) \
3093 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3094 #define IS_BASE64_IGNORABLE(Character) \
3095 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3096 || (Character) == '\f' || (Character) == '\r')
3098 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3099 character or return retval if there are no characters left to
3101 #define READ_QUADRUPLET_BYTE(retval) \
3106 if (nchars_return) \
3107 *nchars_return = nchars; \
3112 while (IS_BASE64_IGNORABLE (c))
3114 /* Table of characters coding the 64 values. */
3115 static const char base64_value_to_char
[64] =
3117 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3118 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3119 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3120 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3121 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3122 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3123 '8', '9', '+', '/' /* 60-63 */
3126 /* Table of base64 values for first 128 characters. */
3127 static const short base64_char_to_value
[128] =
3129 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3130 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3131 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3132 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3133 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3134 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3135 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3136 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3137 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3138 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3139 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3140 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3141 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3144 /* The following diagram shows the logical steps by which three octets
3145 get transformed into four base64 characters.
3147 .--------. .--------. .--------.
3148 |aaaaaabb| |bbbbcccc| |ccdddddd|
3149 `--------' `--------' `--------'
3151 .--------+--------+--------+--------.
3152 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3153 `--------+--------+--------+--------'
3155 .--------+--------+--------+--------.
3156 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3157 `--------+--------+--------+--------'
3159 The octets are divided into 6 bit chunks, which are then encoded into
3160 base64 characters. */
3163 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3164 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3167 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3169 doc
: /* Base64-encode the region between BEG and END.
3170 Return the length of the encoded text.
3171 Optional third argument NO-LINE-BREAK means do not break long lines
3172 into shorter lines. */)
3173 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3176 ptrdiff_t allength
, length
;
3177 ptrdiff_t ibeg
, iend
, encoded_length
;
3178 ptrdiff_t old_pos
= PT
;
3181 validate_region (&beg
, &end
);
3183 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3184 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3185 move_gap_both (XFASTINT (beg
), ibeg
);
3187 /* We need to allocate enough room for encoding the text.
3188 We need 33 1/3% more space, plus a newline every 76
3189 characters, and then we round up. */
3190 length
= iend
- ibeg
;
3191 allength
= length
+ length
/3 + 1;
3192 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3194 encoded
= SAFE_ALLOCA (allength
);
3195 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3196 encoded
, length
, NILP (no_line_break
),
3197 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3198 if (encoded_length
> allength
)
3201 if (encoded_length
< 0)
3203 /* The encoding wasn't possible. */
3205 error ("Multibyte character in data for base64 encoding");
3208 /* Now we have encoded the region, so we insert the new contents
3209 and delete the old. (Insert first in order to preserve markers.) */
3210 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3211 insert (encoded
, encoded_length
);
3213 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3215 /* If point was outside of the region, restore it exactly; else just
3216 move to the beginning of the region. */
3217 if (old_pos
>= XFASTINT (end
))
3218 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3219 else if (old_pos
> XFASTINT (beg
))
3220 old_pos
= XFASTINT (beg
);
3223 /* We return the length of the encoded text. */
3224 return make_number (encoded_length
);
3227 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3229 doc
: /* Base64-encode STRING and return the result.
3230 Optional second argument NO-LINE-BREAK means do not break long lines
3231 into shorter lines. */)
3232 (Lisp_Object string
, Lisp_Object no_line_break
)
3234 ptrdiff_t allength
, length
, encoded_length
;
3236 Lisp_Object encoded_string
;
3239 CHECK_STRING (string
);
3241 /* We need to allocate enough room for encoding the text.
3242 We need 33 1/3% more space, plus a newline every 76
3243 characters, and then we round up. */
3244 length
= SBYTES (string
);
3245 allength
= length
+ length
/3 + 1;
3246 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3248 /* We need to allocate enough room for decoding the text. */
3249 encoded
= SAFE_ALLOCA (allength
);
3251 encoded_length
= base64_encode_1 (SSDATA (string
),
3252 encoded
, length
, NILP (no_line_break
),
3253 STRING_MULTIBYTE (string
));
3254 if (encoded_length
> allength
)
3257 if (encoded_length
< 0)
3259 /* The encoding wasn't possible. */
3260 error ("Multibyte character in data for base64 encoding");
3263 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3266 return encoded_string
;
3270 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3271 bool line_break
, bool multibyte
)
3284 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3285 if (CHAR_BYTE8_P (c
))
3286 c
= CHAR_TO_BYTE8 (c
);
3294 /* Wrap line every 76 characters. */
3298 if (counter
< MIME_LINE_LENGTH
/ 4)
3307 /* Process first byte of a triplet. */
3309 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3310 value
= (0x03 & c
) << 4;
3312 /* Process second byte of a triplet. */
3316 *e
++ = base64_value_to_char
[value
];
3324 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3325 if (CHAR_BYTE8_P (c
))
3326 c
= CHAR_TO_BYTE8 (c
);
3334 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3335 value
= (0x0f & c
) << 2;
3337 /* Process third byte of a triplet. */
3341 *e
++ = base64_value_to_char
[value
];
3348 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3349 if (CHAR_BYTE8_P (c
))
3350 c
= CHAR_TO_BYTE8 (c
);
3358 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3359 *e
++ = base64_value_to_char
[0x3f & c
];
3366 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3368 doc
: /* Base64-decode the region between BEG and END.
3369 Return the length of the decoded text.
3370 If the region can't be decoded, signal an error and don't modify the buffer. */)
3371 (Lisp_Object beg
, Lisp_Object end
)
3373 ptrdiff_t ibeg
, iend
, length
, allength
;
3375 ptrdiff_t old_pos
= PT
;
3376 ptrdiff_t decoded_length
;
3377 ptrdiff_t inserted_chars
;
3378 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3381 validate_region (&beg
, &end
);
3383 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3384 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3386 length
= iend
- ibeg
;
3388 /* We need to allocate enough room for decoding the text. If we are
3389 working on a multibyte buffer, each decoded code may occupy at
3391 allength
= multibyte
? length
* 2 : length
;
3392 decoded
= SAFE_ALLOCA (allength
);
3394 move_gap_both (XFASTINT (beg
), ibeg
);
3395 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3397 multibyte
, &inserted_chars
);
3398 if (decoded_length
> allength
)
3401 if (decoded_length
< 0)
3403 /* The decoding wasn't possible. */
3404 error ("Invalid base64 data");
3407 /* Now we have decoded the region, so we insert the new contents
3408 and delete the old. (Insert first in order to preserve markers.) */
3409 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3410 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3413 /* Delete the original text. */
3414 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3415 iend
+ decoded_length
, 1);
3417 /* If point was outside of the region, restore it exactly; else just
3418 move to the beginning of the region. */
3419 if (old_pos
>= XFASTINT (end
))
3420 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3421 else if (old_pos
> XFASTINT (beg
))
3422 old_pos
= XFASTINT (beg
);
3423 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3425 return make_number (inserted_chars
);
3428 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3430 doc
: /* Base64-decode STRING and return the result. */)
3431 (Lisp_Object string
)
3434 ptrdiff_t length
, decoded_length
;
3435 Lisp_Object decoded_string
;
3438 CHECK_STRING (string
);
3440 length
= SBYTES (string
);
3441 /* We need to allocate enough room for decoding the text. */
3442 decoded
= SAFE_ALLOCA (length
);
3444 /* The decoded result should be unibyte. */
3445 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3447 if (decoded_length
> length
)
3449 else if (decoded_length
>= 0)
3450 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3452 decoded_string
= Qnil
;
3455 if (!STRINGP (decoded_string
))
3456 error ("Invalid base64 data");
3458 return decoded_string
;
3461 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3462 MULTIBYTE, the decoded result should be in multibyte
3463 form. If NCHARS_RETURN is not NULL, store the number of produced
3464 characters in *NCHARS_RETURN. */
3467 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3468 bool multibyte
, ptrdiff_t *nchars_return
)
3470 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3473 unsigned long value
;
3474 ptrdiff_t nchars
= 0;
3478 /* Process first byte of a quadruplet. */
3480 READ_QUADRUPLET_BYTE (e
-to
);
3484 value
= base64_char_to_value
[c
] << 18;
3486 /* Process second byte of a quadruplet. */
3488 READ_QUADRUPLET_BYTE (-1);
3492 value
|= base64_char_to_value
[c
] << 12;
3494 c
= (unsigned char) (value
>> 16);
3495 if (multibyte
&& c
>= 128)
3496 e
+= BYTE8_STRING (c
, e
);
3501 /* Process third byte of a quadruplet. */
3503 READ_QUADRUPLET_BYTE (-1);
3507 READ_QUADRUPLET_BYTE (-1);
3516 value
|= base64_char_to_value
[c
] << 6;
3518 c
= (unsigned char) (0xff & value
>> 8);
3519 if (multibyte
&& c
>= 128)
3520 e
+= BYTE8_STRING (c
, e
);
3525 /* Process fourth byte of a quadruplet. */
3527 READ_QUADRUPLET_BYTE (-1);
3534 value
|= base64_char_to_value
[c
];
3536 c
= (unsigned char) (0xff & value
);
3537 if (multibyte
&& c
>= 128)
3538 e
+= BYTE8_STRING (c
, e
);
3547 /***********************************************************************
3549 ***** Hash Tables *****
3551 ***********************************************************************/
3553 /* Implemented by gerd@gnu.org. This hash table implementation was
3554 inspired by CMUCL hash tables. */
3558 1. For small tables, association lists are probably faster than
3559 hash tables because they have lower overhead.
3561 For uses of hash tables where the O(1) behavior of table
3562 operations is not a requirement, it might therefore be a good idea
3563 not to hash. Instead, we could just do a linear search in the
3564 key_and_value vector of the hash table. This could be done
3565 if a `:linear-search t' argument is given to make-hash-table. */
3568 /* The list of all weak hash tables. Don't staticpro this one. */
3570 static struct Lisp_Hash_Table
*weak_hash_tables
;
3573 /***********************************************************************
3575 ***********************************************************************/
3578 CHECK_HASH_TABLE (Lisp_Object x
)
3580 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3584 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3586 h
->key_and_value
= key_and_value
;
3589 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3594 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3596 gc_aset (h
->next
, idx
, val
);
3599 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3604 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3606 gc_aset (h
->hash
, idx
, val
);
3609 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3614 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3616 gc_aset (h
->index
, idx
, val
);
3619 /* If OBJ is a Lisp hash table, return a pointer to its struct
3620 Lisp_Hash_Table. Otherwise, signal an error. */
3622 static struct Lisp_Hash_Table
*
3623 check_hash_table (Lisp_Object obj
)
3625 CHECK_HASH_TABLE (obj
);
3626 return XHASH_TABLE (obj
);
3630 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3631 number. A number is "almost" a prime number if it is not divisible
3632 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3635 next_almost_prime (EMACS_INT n
)
3637 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3638 for (n
|= 1; ; n
+= 2)
3639 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3644 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3645 which USED[I] is non-zero. If found at index I in ARGS, set
3646 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3647 0. This function is used to extract a keyword/argument pair from
3648 a DEFUN parameter list. */
3651 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3655 for (i
= 1; i
< nargs
; i
++)
3656 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3667 /* Return a Lisp vector which has the same contents as VEC but has
3668 at least INCR_MIN more entries, where INCR_MIN is positive.
3669 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3670 than NITEMS_MAX. Entries in the resulting
3671 vector that are not copied from VEC are set to nil. */
3674 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3676 struct Lisp_Vector
*v
;
3677 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3678 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3679 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3680 ? nitems_max
: C_language_max
);
3681 eassert (VECTORP (vec
));
3682 eassert (0 < incr_min
&& -1 <= nitems_max
);
3683 old_size
= ASIZE (vec
);
3684 incr_max
= n_max
- old_size
;
3685 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3686 if (incr_max
< incr
)
3687 memory_full (SIZE_MAX
);
3688 new_size
= old_size
+ incr
;
3689 v
= allocate_vector (new_size
);
3690 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3691 memclear (v
->contents
+ old_size
, incr
* word_size
);
3692 XSETVECTOR (vec
, v
);
3697 /***********************************************************************
3699 ***********************************************************************/
3701 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3702 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3703 KEY2 are the same. */
3706 cmpfn_eql (struct hash_table_test
*ht
,
3710 return (FLOATP (key1
)
3712 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3716 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3717 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3718 KEY2 are the same. */
3721 cmpfn_equal (struct hash_table_test
*ht
,
3725 return !NILP (Fequal (key1
, key2
));
3729 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3730 HASH2 in hash table H using H->user_cmp_function. Value is true
3731 if KEY1 and KEY2 are the same. */
3734 cmpfn_user_defined (struct hash_table_test
*ht
,
3738 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3741 /* Value is a hash code for KEY for use in hash table H which uses
3742 `eq' to compare keys. The hash code returned is guaranteed to fit
3743 in a Lisp integer. */
3746 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3748 return XHASH (key
) ^ XTYPE (key
);
3751 /* Value is a hash code for KEY for use in hash table H which uses
3752 `equal' to compare keys. The hash code returned is guaranteed to fit
3753 in a Lisp integer. */
3756 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3758 return sxhash (key
, 0);
3761 /* Value is a hash code for KEY for use in hash table H which uses
3762 `eql' to compare keys. The hash code returned is guaranteed to fit
3763 in a Lisp integer. */
3766 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3768 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3771 /* Value is a hash code for KEY for use in hash table H which uses as
3772 user-defined function to compare keys. The hash code returned is
3773 guaranteed to fit in a Lisp integer. */
3776 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3778 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3779 return hashfn_eq (ht
, hash
);
3782 struct hash_table_test
const
3783 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3784 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3785 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3786 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3787 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3788 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3790 /* Allocate basically initialized hash table. */
3792 static struct Lisp_Hash_Table
*
3793 allocate_hash_table (void)
3795 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3796 count
, PVEC_HASH_TABLE
);
3799 /* An upper bound on the size of a hash table index. It must fit in
3800 ptrdiff_t and be a valid Emacs fixnum. */
3801 #define INDEX_SIZE_BOUND \
3802 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3804 /* Create and initialize a new hash table.
3806 TEST specifies the test the hash table will use to compare keys.
3807 It must be either one of the predefined tests `eq', `eql' or
3808 `equal' or a symbol denoting a user-defined test named TEST with
3809 test and hash functions USER_TEST and USER_HASH.
3811 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3813 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3814 new size when it becomes full is computed by adding REHASH_SIZE to
3815 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3816 table's new size is computed by multiplying its old size with
3819 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3820 be resized when the ratio of (number of entries in the table) /
3821 (table size) is >= REHASH_THRESHOLD.
3823 WEAK specifies the weakness of the table. If non-nil, it must be
3824 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3827 make_hash_table (struct hash_table_test test
,
3828 Lisp_Object size
, Lisp_Object rehash_size
,
3829 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3831 struct Lisp_Hash_Table
*h
;
3833 EMACS_INT index_size
, sz
;
3837 /* Preconditions. */
3838 eassert (SYMBOLP (test
.name
));
3839 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3840 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3841 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3842 eassert (FLOATP (rehash_threshold
)
3843 && 0 < XFLOAT_DATA (rehash_threshold
)
3844 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3846 if (XFASTINT (size
) == 0)
3847 size
= make_number (1);
3849 sz
= XFASTINT (size
);
3850 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3851 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3852 ? next_almost_prime (index_float
)
3853 : INDEX_SIZE_BOUND
+ 1);
3854 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3855 error ("Hash table too large");
3857 /* Allocate a table and initialize it. */
3858 h
= allocate_hash_table ();
3860 /* Initialize hash table slots. */
3863 h
->rehash_threshold
= rehash_threshold
;
3864 h
->rehash_size
= rehash_size
;
3866 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3867 h
->hash
= Fmake_vector (size
, Qnil
);
3868 h
->next
= Fmake_vector (size
, Qnil
);
3869 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3871 /* Set up the free list. */
3872 for (i
= 0; i
< sz
- 1; ++i
)
3873 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3874 h
->next_free
= make_number (0);
3876 XSET_HASH_TABLE (table
, h
);
3877 eassert (HASH_TABLE_P (table
));
3878 eassert (XHASH_TABLE (table
) == h
);
3880 /* Maybe add this hash table to the list of all weak hash tables. */
3882 h
->next_weak
= NULL
;
3885 h
->next_weak
= weak_hash_tables
;
3886 weak_hash_tables
= h
;
3893 /* Return a copy of hash table H1. Keys and values are not copied,
3894 only the table itself is. */
3897 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3900 struct Lisp_Hash_Table
*h2
;
3902 h2
= allocate_hash_table ();
3904 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3905 h2
->hash
= Fcopy_sequence (h1
->hash
);
3906 h2
->next
= Fcopy_sequence (h1
->next
);
3907 h2
->index
= Fcopy_sequence (h1
->index
);
3908 XSET_HASH_TABLE (table
, h2
);
3910 /* Maybe add this hash table to the list of all weak hash tables. */
3911 if (!NILP (h2
->weak
))
3913 h2
->next_weak
= weak_hash_tables
;
3914 weak_hash_tables
= h2
;
3921 /* Resize hash table H if it's too full. If H cannot be resized
3922 because it's already too large, throw an error. */
3925 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3927 if (NILP (h
->next_free
))
3929 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3930 EMACS_INT new_size
, index_size
, nsize
;
3934 if (INTEGERP (h
->rehash_size
))
3935 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3938 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3939 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3941 new_size
= float_new_size
;
3942 if (new_size
<= old_size
)
3943 new_size
= old_size
+ 1;
3946 new_size
= INDEX_SIZE_BOUND
+ 1;
3948 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3949 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3950 ? next_almost_prime (index_float
)
3951 : INDEX_SIZE_BOUND
+ 1);
3952 nsize
= max (index_size
, 2 * new_size
);
3953 if (INDEX_SIZE_BOUND
< nsize
)
3954 error ("Hash table too large to resize");
3956 #ifdef ENABLE_CHECKING
3957 if (HASH_TABLE_P (Vpurify_flag
)
3958 && XHASH_TABLE (Vpurify_flag
) == h
)
3959 message ("Growing hash table to: %"pI
"d", new_size
);
3962 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3963 2 * (new_size
- old_size
), -1));
3964 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3965 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3966 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3968 /* Update the free list. Do it so that new entries are added at
3969 the end of the free list. This makes some operations like
3971 for (i
= old_size
; i
< new_size
- 1; ++i
)
3972 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3974 if (!NILP (h
->next_free
))
3976 Lisp_Object last
, next
;
3978 last
= h
->next_free
;
3979 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3983 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3986 XSETFASTINT (h
->next_free
, old_size
);
3989 for (i
= 0; i
< old_size
; ++i
)
3990 if (!NILP (HASH_HASH (h
, i
)))
3992 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3993 ptrdiff_t start_of_bucket
= hash_code
% 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
, make_number (i
));
4001 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4002 the hash code of KEY. Value is the index of the entry in H
4003 matching KEY, or -1 if not found. */
4006 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4008 EMACS_UINT hash_code
;
4009 ptrdiff_t start_of_bucket
;
4012 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4013 eassert ((hash_code
& ~INTMASK
) == 0);
4017 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4018 idx
= HASH_INDEX (h
, start_of_bucket
);
4022 ptrdiff_t i
= XFASTINT (idx
);
4023 if (EQ (key
, HASH_KEY (h
, i
))
4025 && hash_code
== XUINT (HASH_HASH (h
, i
))
4026 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4028 idx
= HASH_NEXT (h
, i
);
4031 return NILP (idx
) ? -1 : XFASTINT (idx
);
4035 /* Put an entry into hash table H that associates KEY with VALUE.
4036 HASH is a previously computed hash code of KEY.
4037 Value is the index of the entry in H matching KEY. */
4040 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4043 ptrdiff_t start_of_bucket
, i
;
4045 eassert ((hash
& ~INTMASK
) == 0);
4047 /* Increment count after resizing because resizing may fail. */
4048 maybe_resize_hash_table (h
);
4051 /* Store key/value in the key_and_value vector. */
4052 i
= XFASTINT (h
->next_free
);
4053 h
->next_free
= HASH_NEXT (h
, i
);
4054 set_hash_key_slot (h
, i
, key
);
4055 set_hash_value_slot (h
, i
, value
);
4057 /* Remember its hash code. */
4058 set_hash_hash_slot (h
, i
, make_number (hash
));
4060 /* Add new entry to its collision chain. */
4061 start_of_bucket
= hash
% ASIZE (h
->index
);
4062 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4063 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4068 /* Remove the entry matching KEY from hash table H, if there is one. */
4071 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4073 EMACS_UINT hash_code
;
4074 ptrdiff_t start_of_bucket
;
4075 Lisp_Object idx
, prev
;
4077 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4078 eassert ((hash_code
& ~INTMASK
) == 0);
4079 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4080 idx
= HASH_INDEX (h
, start_of_bucket
);
4085 ptrdiff_t i
= XFASTINT (idx
);
4087 if (EQ (key
, HASH_KEY (h
, i
))
4089 && hash_code
== XUINT (HASH_HASH (h
, i
))
4090 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4092 /* Take entry out of collision chain. */
4094 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4096 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4098 /* Clear slots in key_and_value and add the slots to
4100 set_hash_key_slot (h
, i
, Qnil
);
4101 set_hash_value_slot (h
, i
, Qnil
);
4102 set_hash_hash_slot (h
, i
, Qnil
);
4103 set_hash_next_slot (h
, i
, h
->next_free
);
4104 h
->next_free
= make_number (i
);
4106 eassert (h
->count
>= 0);
4112 idx
= HASH_NEXT (h
, i
);
4118 /* Clear hash table H. */
4121 hash_clear (struct Lisp_Hash_Table
*h
)
4125 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4127 for (i
= 0; i
< size
; ++i
)
4129 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4130 set_hash_key_slot (h
, i
, Qnil
);
4131 set_hash_value_slot (h
, i
, Qnil
);
4132 set_hash_hash_slot (h
, i
, Qnil
);
4135 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4136 ASET (h
->index
, i
, Qnil
);
4138 h
->next_free
= make_number (0);
4145 /************************************************************************
4147 ************************************************************************/
4149 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4150 entries from the table that don't survive the current GC.
4151 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4152 true if anything was marked. */
4155 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4157 ptrdiff_t n
= gc_asize (h
->index
);
4158 bool marked
= false;
4160 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4162 Lisp_Object idx
, next
, prev
;
4164 /* Follow collision chain, removing entries that
4165 don't survive this garbage collection. */
4167 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4169 ptrdiff_t i
= XFASTINT (idx
);
4170 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4171 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4174 if (EQ (h
->weak
, Qkey
))
4175 remove_p
= !key_known_to_survive_p
;
4176 else if (EQ (h
->weak
, Qvalue
))
4177 remove_p
= !value_known_to_survive_p
;
4178 else if (EQ (h
->weak
, Qkey_or_value
))
4179 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4180 else if (EQ (h
->weak
, Qkey_and_value
))
4181 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4185 next
= HASH_NEXT (h
, i
);
4187 if (remove_entries_p
)
4191 /* Take out of collision chain. */
4193 set_hash_index_slot (h
, bucket
, next
);
4195 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4197 /* Add to free list. */
4198 set_hash_next_slot (h
, i
, h
->next_free
);
4201 /* Clear key, value, and hash. */
4202 set_hash_key_slot (h
, i
, Qnil
);
4203 set_hash_value_slot (h
, i
, Qnil
);
4204 set_hash_hash_slot (h
, i
, Qnil
);
4217 /* Make sure key and value survive. */
4218 if (!key_known_to_survive_p
)
4220 mark_object (HASH_KEY (h
, i
));
4224 if (!value_known_to_survive_p
)
4226 mark_object (HASH_VALUE (h
, i
));
4237 /* Remove elements from weak hash tables that don't survive the
4238 current garbage collection. Remove weak tables that don't survive
4239 from Vweak_hash_tables. Called from gc_sweep. */
4241 NO_INLINE
/* For better stack traces */
4243 sweep_weak_hash_tables (void)
4245 struct Lisp_Hash_Table
*h
, *used
, *next
;
4248 /* Mark all keys and values that are in use. Keep on marking until
4249 there is no more change. This is necessary for cases like
4250 value-weak table A containing an entry X -> Y, where Y is used in a
4251 key-weak table B, Z -> Y. If B comes after A in the list of weak
4252 tables, X -> Y might be removed from A, although when looking at B
4253 one finds that it shouldn't. */
4257 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4259 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4260 marked
|= sweep_weak_table (h
, 0);
4265 /* Remove tables and entries that aren't used. */
4266 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4268 next
= h
->next_weak
;
4270 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4272 /* TABLE is marked as used. Sweep its contents. */
4274 sweep_weak_table (h
, 1);
4276 /* Add table to the list of used weak hash tables. */
4277 h
->next_weak
= used
;
4282 weak_hash_tables
= used
;
4287 /***********************************************************************
4288 Hash Code Computation
4289 ***********************************************************************/
4291 /* Maximum depth up to which to dive into Lisp structures. */
4293 #define SXHASH_MAX_DEPTH 3
4295 /* Maximum length up to which to take list and vector elements into
4298 #define SXHASH_MAX_LEN 7
4300 /* Return a hash for string PTR which has length LEN. The hash value
4301 can be any EMACS_UINT value. */
4304 hash_string (char const *ptr
, ptrdiff_t len
)
4306 char const *p
= ptr
;
4307 char const *end
= p
+ len
;
4309 EMACS_UINT hash
= 0;
4314 hash
= sxhash_combine (hash
, c
);
4320 /* Return a hash for string PTR which has length LEN. The hash
4321 code returned is guaranteed to fit in a Lisp integer. */
4324 sxhash_string (char const *ptr
, ptrdiff_t len
)
4326 EMACS_UINT hash
= hash_string (ptr
, len
);
4327 return SXHASH_REDUCE (hash
);
4330 /* Return a hash for the floating point value VAL. */
4333 sxhash_float (double val
)
4335 EMACS_UINT hash
= 0;
4337 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4338 + (sizeof val
% sizeof hash
!= 0))
4342 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4346 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4347 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4348 hash
= sxhash_combine (hash
, u
.word
[i
]);
4349 return SXHASH_REDUCE (hash
);
4352 /* Return a hash for list LIST. DEPTH is the current depth in the
4353 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4356 sxhash_list (Lisp_Object list
, int depth
)
4358 EMACS_UINT hash
= 0;
4361 if (depth
< SXHASH_MAX_DEPTH
)
4363 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4364 list
= XCDR (list
), ++i
)
4366 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4367 hash
= sxhash_combine (hash
, hash2
);
4372 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4373 hash
= sxhash_combine (hash
, hash2
);
4376 return SXHASH_REDUCE (hash
);
4380 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4381 the Lisp structure. */
4384 sxhash_vector (Lisp_Object vec
, int depth
)
4386 EMACS_UINT hash
= ASIZE (vec
);
4389 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4390 for (i
= 0; i
< n
; ++i
)
4392 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4393 hash
= sxhash_combine (hash
, hash2
);
4396 return SXHASH_REDUCE (hash
);
4399 /* Return a hash for bool-vector VECTOR. */
4402 sxhash_bool_vector (Lisp_Object vec
)
4404 EMACS_INT size
= bool_vector_size (vec
);
4405 EMACS_UINT hash
= size
;
4408 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4409 for (i
= 0; i
< n
; ++i
)
4410 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4412 return SXHASH_REDUCE (hash
);
4416 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4417 structure. Value is an unsigned integer clipped to INTMASK. */
4420 sxhash (Lisp_Object obj
, int depth
)
4424 if (depth
> SXHASH_MAX_DEPTH
)
4427 switch (XTYPE (obj
))
4439 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4442 /* This can be everything from a vector to an overlay. */
4443 case Lisp_Vectorlike
:
4445 /* According to the CL HyperSpec, two arrays are equal only if
4446 they are `eq', except for strings and bit-vectors. In
4447 Emacs, this works differently. We have to compare element
4449 hash
= sxhash_vector (obj
, depth
);
4450 else if (BOOL_VECTOR_P (obj
))
4451 hash
= sxhash_bool_vector (obj
);
4453 /* Others are `equal' if they are `eq', so let's take their
4459 hash
= sxhash_list (obj
, depth
);
4463 hash
= sxhash_float (XFLOAT_DATA (obj
));
4475 /***********************************************************************
4477 ***********************************************************************/
4479 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4480 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4481 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4484 return make_number (hashfn_eq (NULL
, obj
));
4487 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4488 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4489 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4492 return make_number (hashfn_eql (NULL
, obj
));
4495 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4496 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4497 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4500 return make_number (hashfn_equal (NULL
, obj
));
4503 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4504 doc
: /* Create and return a new hash table.
4506 Arguments are specified as keyword/argument pairs. The following
4507 arguments are defined:
4509 :test TEST -- TEST must be a symbol that specifies how to compare
4510 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4511 `equal'. User-supplied test and hash functions can be specified via
4512 `define-hash-table-test'.
4514 :size SIZE -- A hint as to how many elements will be put in the table.
4517 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4518 fills up. If REHASH-SIZE is an integer, increase the size by that
4519 amount. If it is a float, it must be > 1.0, and the new size is the
4520 old size multiplied by that factor. Default is 1.5.
4522 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4523 Resize the hash table when the ratio (number of entries / table size)
4524 is greater than or equal to THRESHOLD. Default is 0.8.
4526 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4527 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4528 returned is a weak table. Key/value pairs are removed from a weak
4529 hash table when there are no non-weak references pointing to their
4530 key, value, one of key or value, or both key and value, depending on
4531 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4534 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4535 (ptrdiff_t nargs
, Lisp_Object
*args
)
4537 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4538 struct hash_table_test testdesc
;
4542 /* The vector `used' is used to keep track of arguments that
4543 have been consumed. */
4544 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4545 memset (used
, 0, nargs
* sizeof *used
);
4547 /* See if there's a `:test TEST' among the arguments. */
4548 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4549 test
= i
? args
[i
] : Qeql
;
4551 testdesc
= hashtest_eq
;
4552 else if (EQ (test
, Qeql
))
4553 testdesc
= hashtest_eql
;
4554 else if (EQ (test
, Qequal
))
4555 testdesc
= hashtest_equal
;
4558 /* See if it is a user-defined test. */
4561 prop
= Fget (test
, Qhash_table_test
);
4562 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4563 signal_error ("Invalid hash table test", test
);
4564 testdesc
.name
= test
;
4565 testdesc
.user_cmp_function
= XCAR (prop
);
4566 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4567 testdesc
.hashfn
= hashfn_user_defined
;
4568 testdesc
.cmpfn
= cmpfn_user_defined
;
4571 /* See if there's a `:size SIZE' argument. */
4572 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4573 size
= i
? args
[i
] : Qnil
;
4575 size
= make_number (DEFAULT_HASH_SIZE
);
4576 else if (!INTEGERP (size
) || XINT (size
) < 0)
4577 signal_error ("Invalid hash table size", size
);
4579 /* Look for `:rehash-size SIZE'. */
4580 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4581 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4582 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4583 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4584 signal_error ("Invalid hash table rehash size", rehash_size
);
4586 /* Look for `:rehash-threshold THRESHOLD'. */
4587 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4588 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4589 if (! (FLOATP (rehash_threshold
)
4590 && 0 < XFLOAT_DATA (rehash_threshold
)
4591 && XFLOAT_DATA (rehash_threshold
) <= 1))
4592 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4594 /* Look for `:weakness WEAK'. */
4595 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4596 weak
= i
? args
[i
] : Qnil
;
4598 weak
= Qkey_and_value
;
4601 && !EQ (weak
, Qvalue
)
4602 && !EQ (weak
, Qkey_or_value
)
4603 && !EQ (weak
, Qkey_and_value
))
4604 signal_error ("Invalid hash table weakness", weak
);
4606 /* Now, all args should have been used up, or there's a problem. */
4607 for (i
= 0; i
< nargs
; ++i
)
4609 signal_error ("Invalid argument list", args
[i
]);
4612 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4616 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4617 doc
: /* Return a copy of hash table TABLE. */)
4620 return copy_hash_table (check_hash_table (table
));
4624 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4625 doc
: /* Return the number of elements in TABLE. */)
4628 return make_number (check_hash_table (table
)->count
);
4632 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4633 Shash_table_rehash_size
, 1, 1, 0,
4634 doc
: /* Return the current rehash size of TABLE. */)
4637 return check_hash_table (table
)->rehash_size
;
4641 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4642 Shash_table_rehash_threshold
, 1, 1, 0,
4643 doc
: /* Return the current rehash threshold of TABLE. */)
4646 return check_hash_table (table
)->rehash_threshold
;
4650 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4651 doc
: /* Return the size of TABLE.
4652 The size can be used as an argument to `make-hash-table' to create
4653 a hash table than can hold as many elements as TABLE holds
4654 without need for resizing. */)
4657 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4658 return make_number (HASH_TABLE_SIZE (h
));
4662 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4663 doc
: /* Return the test TABLE uses. */)
4666 return check_hash_table (table
)->test
.name
;
4670 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4672 doc
: /* Return the weakness of TABLE. */)
4675 return check_hash_table (table
)->weak
;
4679 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4680 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4683 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4687 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4688 doc
: /* Clear hash table TABLE and return it. */)
4691 hash_clear (check_hash_table (table
));
4692 /* Be compatible with XEmacs. */
4697 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4698 doc
: /* Look up KEY in TABLE and return its associated value.
4699 If KEY is not found, return DFLT which defaults to nil. */)
4700 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4702 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4703 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4704 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4708 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4709 doc
: /* Associate KEY with VALUE in hash table TABLE.
4710 If KEY is already present in table, replace its current value with
4711 VALUE. In any case, return VALUE. */)
4712 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4714 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4718 i
= hash_lookup (h
, key
, &hash
);
4720 set_hash_value_slot (h
, i
, value
);
4722 hash_put (h
, key
, value
, hash
);
4728 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4729 doc
: /* Remove KEY from TABLE. */)
4730 (Lisp_Object key
, Lisp_Object table
)
4732 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4733 hash_remove_from_table (h
, key
);
4738 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4739 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4740 FUNCTION is called with two arguments, KEY and VALUE.
4741 `maphash' always returns nil. */)
4742 (Lisp_Object function
, Lisp_Object table
)
4744 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4746 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4747 if (!NILP (HASH_HASH (h
, i
)))
4748 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4754 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4755 Sdefine_hash_table_test
, 3, 3, 0,
4756 doc
: /* Define a new hash table test with name NAME, a symbol.
4758 In hash tables created with NAME specified as test, use TEST to
4759 compare keys, and HASH for computing hash codes of keys.
4761 TEST must be a function taking two arguments and returning non-nil if
4762 both arguments are the same. HASH must be a function taking one
4763 argument and returning an object that is the hash code of the argument.
4764 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4765 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4766 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4768 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4773 /************************************************************************
4774 MD5, SHA-1, and SHA-2
4775 ************************************************************************/
4783 make_digest_string (Lisp_Object digest
, int digest_size
)
4785 unsigned char *p
= SDATA (digest
);
4787 for (int i
= digest_size
- 1; i
>= 0; i
--)
4789 static char const hexdigit
[16] = "0123456789abcdef";
4791 p
[2 * i
] = hexdigit
[p_i
>> 4];
4792 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4797 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4800 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4801 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4804 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4805 register EMACS_INT b
, e
;
4806 register struct buffer
*bp
;
4809 void *(*hash_func
) (const char *, size_t, void *);
4812 CHECK_SYMBOL (algorithm
);
4814 if (STRINGP (object
))
4816 if (NILP (coding_system
))
4818 /* Decide the coding-system to encode the data with. */
4820 if (STRING_MULTIBYTE (object
))
4821 /* use default, we can't guess correct value */
4822 coding_system
= preferred_coding_system ();
4824 coding_system
= Qraw_text
;
4827 if (NILP (Fcoding_system_p (coding_system
)))
4829 /* Invalid coding system. */
4831 if (!NILP (noerror
))
4832 coding_system
= Qraw_text
;
4834 xsignal1 (Qcoding_system_error
, coding_system
);
4837 if (STRING_MULTIBYTE (object
))
4838 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4840 size
= SCHARS (object
);
4841 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4843 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4844 end_byte
= (end_char
== size
4846 : string_char_to_byte (object
, end_char
));
4850 struct buffer
*prev
= current_buffer
;
4852 record_unwind_current_buffer ();
4854 CHECK_BUFFER (object
);
4856 bp
= XBUFFER (object
);
4857 set_buffer_internal (bp
);
4863 CHECK_NUMBER_COERCE_MARKER (start
);
4871 CHECK_NUMBER_COERCE_MARKER (end
);
4876 temp
= b
, b
= e
, e
= temp
;
4878 if (!(BEGV
<= b
&& e
<= ZV
))
4879 args_out_of_range (start
, end
);
4881 if (NILP (coding_system
))
4883 /* Decide the coding-system to encode the data with.
4884 See fileio.c:Fwrite-region */
4886 if (!NILP (Vcoding_system_for_write
))
4887 coding_system
= Vcoding_system_for_write
;
4890 bool force_raw_text
= 0;
4892 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4893 if (NILP (coding_system
)
4894 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4896 coding_system
= Qnil
;
4897 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4901 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4903 /* Check file-coding-system-alist. */
4904 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4905 Qwrite_region
, start
, end
,
4906 Fbuffer_file_name (object
));
4907 if (CONSP (val
) && !NILP (XCDR (val
)))
4908 coding_system
= XCDR (val
);
4911 if (NILP (coding_system
)
4912 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4914 /* If we still have not decided a coding system, use the
4915 default value of buffer-file-coding-system. */
4916 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4920 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4921 /* Confirm that VAL can surely encode the current region. */
4922 coding_system
= call4 (Vselect_safe_coding_system_function
,
4923 make_number (b
), make_number (e
),
4924 coding_system
, Qnil
);
4927 coding_system
= Qraw_text
;
4930 if (NILP (Fcoding_system_p (coding_system
)))
4932 /* Invalid coding system. */
4934 if (!NILP (noerror
))
4935 coding_system
= Qraw_text
;
4937 xsignal1 (Qcoding_system_error
, coding_system
);
4941 object
= make_buffer_string (b
, e
, 0);
4942 set_buffer_internal (prev
);
4943 /* Discard the unwind protect for recovering the current
4947 if (STRING_MULTIBYTE (object
))
4948 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4950 end_byte
= SBYTES (object
);
4953 if (EQ (algorithm
, Qmd5
))
4955 digest_size
= MD5_DIGEST_SIZE
;
4956 hash_func
= md5_buffer
;
4958 else if (EQ (algorithm
, Qsha1
))
4960 digest_size
= SHA1_DIGEST_SIZE
;
4961 hash_func
= sha1_buffer
;
4963 else if (EQ (algorithm
, Qsha224
))
4965 digest_size
= SHA224_DIGEST_SIZE
;
4966 hash_func
= sha224_buffer
;
4968 else if (EQ (algorithm
, Qsha256
))
4970 digest_size
= SHA256_DIGEST_SIZE
;
4971 hash_func
= sha256_buffer
;
4973 else if (EQ (algorithm
, Qsha384
))
4975 digest_size
= SHA384_DIGEST_SIZE
;
4976 hash_func
= sha384_buffer
;
4978 else if (EQ (algorithm
, Qsha512
))
4980 digest_size
= SHA512_DIGEST_SIZE
;
4981 hash_func
= sha512_buffer
;
4984 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4986 /* allocate 2 x digest_size so that it can be re-used to hold the
4988 digest
= make_uninit_string (digest_size
* 2);
4990 hash_func (SSDATA (object
) + start_byte
,
4991 end_byte
- start_byte
,
4995 return make_digest_string (digest
, digest_size
);
4997 return make_unibyte_string (SSDATA (digest
), digest_size
);
5000 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5001 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5003 A message digest is a cryptographic checksum of a document, and the
5004 algorithm to calculate it is defined in RFC 1321.
5006 The two optional arguments START and END are character positions
5007 specifying for which part of OBJECT the message digest should be
5008 computed. If nil or omitted, the digest is computed for the whole
5011 The MD5 message digest is computed from the result of encoding the
5012 text in a coding system, not directly from the internal Emacs form of
5013 the text. The optional fourth argument CODING-SYSTEM specifies which
5014 coding system to encode the text with. It should be the same coding
5015 system that you used or will use when actually writing the text into a
5018 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5019 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5020 system would be chosen by default for writing this text into a file.
5022 If OBJECT is a string, the most preferred coding system (see the
5023 command `prefer-coding-system') is used.
5025 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5026 guesswork fails. Normally, an error is signaled in such case. */)
5027 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5029 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5032 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5033 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5034 ALGORITHM is a symbol specifying the hash to use:
5035 md5, sha1, sha224, sha256, sha384 or sha512.
5037 The two optional arguments START and END are positions specifying for
5038 which part of OBJECT to compute the hash. If nil or omitted, uses the
5041 If BINARY is non-nil, returns a string in binary form. */)
5042 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5044 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5047 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5048 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5049 This hash is performed on the raw internal format of the buffer,
5050 disregarding any coding systems.
5051 If nil, use the current buffer." */ )
5052 (Lisp_Object buffer_or_name
)
5056 struct sha1_ctx ctx
;
5058 if (NILP (buffer_or_name
))
5059 buffer
= Fcurrent_buffer ();
5061 buffer
= Fget_buffer (buffer_or_name
);
5063 nsberror (buffer_or_name
);
5065 b
= XBUFFER (buffer
);
5066 sha1_init_ctx (&ctx
);
5068 /* Process the first part of the buffer. */
5069 sha1_process_bytes (BUF_BEG_ADDR (b
),
5070 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5073 /* If the gap is before the end of the buffer, process the last half
5075 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5076 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5077 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5080 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5081 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5082 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5089 DEFSYM (Qmd5
, "md5");
5090 DEFSYM (Qsha1
, "sha1");
5091 DEFSYM (Qsha224
, "sha224");
5092 DEFSYM (Qsha256
, "sha256");
5093 DEFSYM (Qsha384
, "sha384");
5094 DEFSYM (Qsha512
, "sha512");
5096 /* Hash table stuff. */
5097 DEFSYM (Qhash_table_p
, "hash-table-p");
5099 DEFSYM (Qeql
, "eql");
5100 DEFSYM (Qequal
, "equal");
5101 DEFSYM (QCtest
, ":test");
5102 DEFSYM (QCsize
, ":size");
5103 DEFSYM (QCrehash_size
, ":rehash-size");
5104 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5105 DEFSYM (QCweakness
, ":weakness");
5106 DEFSYM (Qkey
, "key");
5107 DEFSYM (Qvalue
, "value");
5108 DEFSYM (Qhash_table_test
, "hash-table-test");
5109 DEFSYM (Qkey_or_value
, "key-or-value");
5110 DEFSYM (Qkey_and_value
, "key-and-value");
5112 defsubr (&Ssxhash_eq
);
5113 defsubr (&Ssxhash_eql
);
5114 defsubr (&Ssxhash_equal
);
5115 defsubr (&Smake_hash_table
);
5116 defsubr (&Scopy_hash_table
);
5117 defsubr (&Shash_table_count
);
5118 defsubr (&Shash_table_rehash_size
);
5119 defsubr (&Shash_table_rehash_threshold
);
5120 defsubr (&Shash_table_size
);
5121 defsubr (&Shash_table_test
);
5122 defsubr (&Shash_table_weakness
);
5123 defsubr (&Shash_table_p
);
5124 defsubr (&Sclrhash
);
5125 defsubr (&Sgethash
);
5126 defsubr (&Sputhash
);
5127 defsubr (&Sremhash
);
5128 defsubr (&Smaphash
);
5129 defsubr (&Sdefine_hash_table_test
);
5131 DEFSYM (Qstring_lessp
, "string-lessp");
5132 DEFSYM (Qprovide
, "provide");
5133 DEFSYM (Qrequire
, "require");
5134 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5135 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5136 DEFSYM (Qwidget_type
, "widget-type");
5138 staticpro (&string_char_byte_cache_string
);
5139 string_char_byte_cache_string
= Qnil
;
5141 require_nesting_list
= Qnil
;
5142 staticpro (&require_nesting_list
);
5144 Fset (Qyes_or_no_p_history
, Qnil
);
5146 DEFVAR_LISP ("features", Vfeatures
,
5147 doc
: /* A list of symbols which are the features of the executing Emacs.
5148 Used by `featurep' and `require', and altered by `provide'. */);
5149 Vfeatures
= list1 (Qemacs
);
5150 DEFSYM (Qfeatures
, "features");
5151 /* Let people use lexically scoped vars named `features'. */
5152 Fmake_var_non_special (Qfeatures
);
5153 DEFSYM (Qsubfeatures
, "subfeatures");
5154 DEFSYM (Qfuncall
, "funcall");
5156 #ifdef HAVE_LANGINFO_CODESET
5157 DEFSYM (Qcodeset
, "codeset");
5158 DEFSYM (Qdays
, "days");
5159 DEFSYM (Qmonths
, "months");
5160 DEFSYM (Qpaper
, "paper");
5161 #endif /* HAVE_LANGINFO_CODESET */
5163 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5164 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5165 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5166 invoked by mouse clicks and mouse menu items.
5168 On some platforms, file selection dialogs are also enabled if this is
5172 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5173 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5174 This applies to commands from menus and tool bar buttons even when
5175 they are initiated from the keyboard. If `use-dialog-box' is nil,
5176 that disables the use of a file dialog, regardless of the value of
5178 use_file_dialog
= 1;
5180 defsubr (&Sidentity
);
5183 defsubr (&Ssafe_length
);
5184 defsubr (&Sstring_bytes
);
5185 defsubr (&Sstring_equal
);
5186 defsubr (&Scompare_strings
);
5187 defsubr (&Sstring_lessp
);
5188 defsubr (&Sstring_version_lessp
);
5189 defsubr (&Sstring_collate_lessp
);
5190 defsubr (&Sstring_collate_equalp
);
5193 defsubr (&Svconcat
);
5194 defsubr (&Scopy_sequence
);
5195 defsubr (&Sstring_make_multibyte
);
5196 defsubr (&Sstring_make_unibyte
);
5197 defsubr (&Sstring_as_multibyte
);
5198 defsubr (&Sstring_as_unibyte
);
5199 defsubr (&Sstring_to_multibyte
);
5200 defsubr (&Sstring_to_unibyte
);
5201 defsubr (&Scopy_alist
);
5202 defsubr (&Ssubstring
);
5203 defsubr (&Ssubstring_no_properties
);
5216 defsubr (&Snreverse
);
5217 defsubr (&Sreverse
);
5219 defsubr (&Splist_get
);
5221 defsubr (&Splist_put
);
5223 defsubr (&Slax_plist_get
);
5224 defsubr (&Slax_plist_put
);
5227 defsubr (&Sequal_including_properties
);
5228 defsubr (&Sfillarray
);
5229 defsubr (&Sclear_string
);
5234 defsubr (&Smapconcat
);
5235 defsubr (&Syes_or_no_p
);
5236 defsubr (&Sload_average
);
5237 defsubr (&Sfeaturep
);
5238 defsubr (&Srequire
);
5239 defsubr (&Sprovide
);
5240 defsubr (&Splist_member
);
5241 defsubr (&Swidget_put
);
5242 defsubr (&Swidget_get
);
5243 defsubr (&Swidget_apply
);
5244 defsubr (&Sbase64_encode_region
);
5245 defsubr (&Sbase64_decode_region
);
5246 defsubr (&Sbase64_encode_string
);
5247 defsubr (&Sbase64_decode_string
);
5249 defsubr (&Ssecure_hash
);
5250 defsubr (&Sbuffer_hash
);
5251 defsubr (&Slocale_info
);