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"
38 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
39 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
41 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
42 Lisp_Object
[], Lisp_Object
[]);
44 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
46 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
47 doc
: /* Return the argument unchanged. */
54 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
55 doc
: /* Return a pseudo-random number.
56 All integers representable in Lisp, i.e. between `most-negative-fixnum'
57 and `most-positive-fixnum', inclusive, are equally likely.
59 With positive integer LIMIT, return random number in interval [0,LIMIT).
60 With argument t, set the random number seed from the system's entropy
61 pool if available, otherwise from less-random volatile data such as the time.
62 With a string argument, set the seed based on the string's contents.
63 Other values of LIMIT are ignored.
65 See Info node `(elisp)Random Numbers' for more details. */)
72 else if (STRINGP (limit
))
73 seed_random (SSDATA (limit
), SBYTES (limit
));
76 if (INTEGERP (limit
) && 0 < XINT (limit
))
79 /* Return the remainder, except reject the rare case where
80 get_random returns a number so close to INTMASK that the
81 remainder isn't random. */
82 EMACS_INT remainder
= val
% XINT (limit
);
83 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
84 return make_number (remainder
);
87 return make_number (val
);
90 /* Heuristic on how many iterations of a tight loop can be safely done
91 before it's time to do a QUIT. This must be a power of 2. */
92 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
94 /* Random data-structure functions. */
97 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
99 CHECK_TYPE (NILP (x
), Qlistp
, y
);
102 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
103 doc
: /* Return the length of vector, list or string SEQUENCE.
104 A byte-code function object is also allowed.
105 If the string contains multibyte characters, this is not necessarily
106 the number of bytes in the string; it is the number of characters.
107 To get the number of bytes, use `string-bytes'. */)
108 (register Lisp_Object sequence
)
110 register Lisp_Object val
;
112 if (STRINGP (sequence
))
113 XSETFASTINT (val
, SCHARS (sequence
));
114 else if (VECTORP (sequence
))
115 XSETFASTINT (val
, ASIZE (sequence
));
116 else if (CHAR_TABLE_P (sequence
))
117 XSETFASTINT (val
, MAX_CHAR
);
118 else if (BOOL_VECTOR_P (sequence
))
119 XSETFASTINT (val
, bool_vector_size (sequence
));
120 else if (COMPILEDP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
122 else if (CONSP (sequence
))
129 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
131 if (MOST_POSITIVE_FIXNUM
< i
)
132 error ("List too long");
135 sequence
= XCDR (sequence
);
137 while (CONSP (sequence
));
139 CHECK_LIST_END (sequence
, sequence
);
141 val
= make_number (i
);
143 else if (NILP (sequence
))
144 XSETFASTINT (val
, 0);
146 wrong_type_argument (Qsequencep
, sequence
);
151 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
152 doc
: /* Return the length of a list, but avoid error or infinite loop.
153 This function never gets an error. If LIST is not really a list,
154 it returns 0. If LIST is circular, it returns a finite value
155 which is at least the number of distinct elements. */)
158 Lisp_Object tail
, halftail
;
163 return make_number (0);
165 /* halftail is used to detect circular lists. */
166 for (tail
= halftail
= list
; ; )
171 if (EQ (tail
, halftail
))
174 if ((lolen
& 1) == 0)
176 halftail
= XCDR (halftail
);
177 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
181 hilen
+= UINTMAX_MAX
+ 1.0;
186 /* If the length does not fit into a fixnum, return a float.
187 On all known practical machines this returns an upper bound on
189 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
192 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
193 doc
: /* Return the number of bytes in STRING.
194 If STRING is multibyte, this may be greater than the length of STRING. */)
197 CHECK_STRING (string
);
198 return make_number (SBYTES (string
));
201 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
202 doc
: /* Return t if two strings have identical contents.
203 Case is significant, but text properties are ignored.
204 Symbols are also allowed; their print names are used instead. */)
205 (register Lisp_Object s1
, Lisp_Object s2
)
208 s1
= SYMBOL_NAME (s1
);
210 s2
= SYMBOL_NAME (s2
);
214 if (SCHARS (s1
) != SCHARS (s2
)
215 || SBYTES (s1
) != SBYTES (s2
)
216 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
221 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
222 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
223 The arguments START1, END1, START2, and END2, if non-nil, are
224 positions specifying which parts of STR1 or STR2 to compare. In
225 string STR1, compare the part between START1 (inclusive) and END1
226 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
227 the string; if END1 is nil, it defaults to the length of the string.
228 Likewise, in string STR2, compare the part between START2 and END2.
229 Like in `substring', negative values are counted from the end.
231 The strings are compared by the numeric values of their characters.
232 For instance, STR1 is "less than" STR2 if its first differing
233 character has a smaller numeric value. If IGNORE-CASE is non-nil,
234 characters are converted to lower-case before comparing them. Unibyte
235 strings are converted to multibyte for comparison.
237 The value is t if the strings (or specified portions) match.
238 If string STR1 is less, the value is a negative number N;
239 - 1 - N is the number of characters that match at the beginning.
240 If string STR1 is greater, the value is a positive number N;
241 N - 1 is the number of characters that match at the beginning. */)
242 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
243 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
245 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
250 /* For backward compatibility, silently bring too-large positive end
251 values into range. */
252 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
253 end1
= make_number (SCHARS (str1
));
254 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
255 end2
= make_number (SCHARS (str2
));
257 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
258 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
263 i1_byte
= string_char_to_byte (str1
, i1
);
264 i2_byte
= string_char_to_byte (str2
, i2
);
266 while (i1
< to1
&& i2
< to2
)
268 /* When we find a mismatch, we must compare the
269 characters, not just the bytes. */
272 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
273 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
278 if (! NILP (ignore_case
))
280 c1
= XINT (Fupcase (make_number (c1
)));
281 c2
= XINT (Fupcase (make_number (c2
)));
287 /* Note that I1 has already been incremented
288 past the character that we are comparing;
289 hence we don't add or subtract 1 here. */
291 return make_number (- i1
+ from1
);
293 return make_number (i1
- from1
);
297 return make_number (i1
- from1
+ 1);
299 return make_number (- i1
+ from1
- 1);
304 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
305 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
307 Symbols are also allowed; their print names are used instead. */)
308 (register Lisp_Object string1
, Lisp_Object string2
)
310 register ptrdiff_t end
;
311 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
313 if (SYMBOLP (string1
))
314 string1
= SYMBOL_NAME (string1
);
315 if (SYMBOLP (string2
))
316 string2
= SYMBOL_NAME (string2
);
317 CHECK_STRING (string1
);
318 CHECK_STRING (string2
);
320 i1
= i1_byte
= i2
= i2_byte
= 0;
322 end
= SCHARS (string1
);
323 if (end
> SCHARS (string2
))
324 end
= SCHARS (string2
);
328 /* When we find a mismatch, we must compare the
329 characters, not just the bytes. */
332 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
333 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
336 return c1
< c2
? Qt
: Qnil
;
338 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
341 DEFUN ("string-version-lessp", Fstring_version_lessp
,
342 Sstring_version_lessp
, 2, 2, 0,
343 doc
: /* Return non-nil if S1 is less than S2, as version strings.
345 This function compares version strings S1 and S2:
346 1) By prefix lexicographically.
347 2) Then by version (similarly to version comparison of Debian's dpkg).
348 Leading zeros in version numbers are ignored.
349 3) If both prefix and version are equal, compare as ordinary strings.
351 For example, \"foo2.png\" compares less than \"foo12.png\".
353 Symbols are also allowed; their print names are used instead. */)
354 (Lisp_Object string1
, Lisp_Object string2
)
356 if (SYMBOLP (string1
))
357 string1
= SYMBOL_NAME (string1
);
358 if (SYMBOLP (string2
))
359 string2
= SYMBOL_NAME (string2
);
360 CHECK_STRING (string1
);
361 CHECK_STRING (string2
);
363 char *p1
= SSDATA (string1
);
364 char *p2
= SSDATA (string2
);
365 char *lim1
= p1
+ SBYTES (string1
);
366 char *lim2
= p2
+ SBYTES (string2
);
369 while ((cmp
= filevercmp (p1
, p2
)) == 0)
371 /* If the strings are identical through their first null bytes,
372 skip past identical prefixes and try again. */
373 ptrdiff_t size
= strlen (p1
) + 1;
377 return lim2
< p2
? Qnil
: Qt
;
382 return cmp
< 0 ? Qt
: Qnil
;
385 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
386 doc
: /* Return t if first arg string is less than second in collation order.
387 Symbols are also allowed; their print names are used instead.
389 This function obeys the conventions for collation order in your
390 locale settings. For example, punctuation and whitespace characters
391 might be considered less significant for sorting:
393 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
394 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
396 The optional argument LOCALE, a string, overrides the setting of your
397 current locale identifier for collation. The value is system
398 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
399 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
401 If IGNORE-CASE is non-nil, characters are converted to lower-case
402 before comparing them.
404 To emulate Unicode-compliant collation on MS-Windows systems,
405 bind `w32-collate-ignore-punctuation' to a non-nil value, since
406 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
408 If your system does not support a locale environment, this function
409 behaves like `string-lessp'. */)
410 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
412 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
413 /* Check parameters. */
415 s1
= SYMBOL_NAME (s1
);
417 s2
= SYMBOL_NAME (s2
);
421 CHECK_STRING (locale
);
423 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
425 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
426 return Fstring_lessp (s1
, s2
);
427 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
430 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
431 doc
: /* Return t if two strings have identical contents.
432 Symbols are also allowed; their print names are used instead.
434 This function obeys the conventions for collation order in your locale
435 settings. For example, characters with different coding points but
436 the same meaning might be considered as equal, like different grave
437 accent Unicode characters:
439 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
442 The optional argument LOCALE, a string, overrides the setting of your
443 current locale identifier for collation. The value is system
444 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
445 while it would be \"enu_USA.1252\" on MS Windows systems.
447 If IGNORE-CASE is non-nil, characters are converted to lower-case
448 before comparing them.
450 To emulate Unicode-compliant collation on MS-Windows systems,
451 bind `w32-collate-ignore-punctuation' to a non-nil value, since
452 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
454 If your system does not support a locale environment, this function
455 behaves like `string-equal'.
457 Do NOT use this function to compare file names for equality, only
458 for sorting them. */)
459 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
461 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
462 /* Check parameters. */
464 s1
= SYMBOL_NAME (s1
);
466 s2
= SYMBOL_NAME (s2
);
470 CHECK_STRING (locale
);
472 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
474 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
475 return Fstring_equal (s1
, s2
);
476 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
479 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
480 enum Lisp_Type target_type
, bool last_special
);
484 concat2 (Lisp_Object s1
, Lisp_Object s2
)
486 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
491 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
493 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
496 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
497 doc
: /* Concatenate all the arguments and make the result a list.
498 The result is a list whose elements are the elements of all the arguments.
499 Each argument may be a list, vector or string.
500 The last argument is not copied, just used as the tail of the new list.
501 usage: (append &rest SEQUENCES) */)
502 (ptrdiff_t nargs
, Lisp_Object
*args
)
504 return concat (nargs
, args
, Lisp_Cons
, 1);
507 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
508 doc
: /* Concatenate all the arguments and make the result a string.
509 The result is a string whose elements are the elements of all the arguments.
510 Each argument may be a string or a list or vector of characters (integers).
511 usage: (concat &rest SEQUENCES) */)
512 (ptrdiff_t nargs
, Lisp_Object
*args
)
514 return concat (nargs
, args
, Lisp_String
, 0);
517 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
518 doc
: /* Concatenate all the arguments and make the result a vector.
519 The result is a vector whose elements are the elements of all the arguments.
520 Each argument may be a list, vector or string.
521 usage: (vconcat &rest SEQUENCES) */)
522 (ptrdiff_t nargs
, Lisp_Object
*args
)
524 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
528 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
529 doc
: /* Return a copy of a list, vector, string or char-table.
530 The elements of a list or vector are not copied; they are shared
531 with the original. */)
534 if (NILP (arg
)) return arg
;
536 if (CHAR_TABLE_P (arg
))
538 return copy_char_table (arg
);
541 if (BOOL_VECTOR_P (arg
))
543 EMACS_INT nbits
= bool_vector_size (arg
);
544 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
545 Lisp_Object val
= make_uninit_bool_vector (nbits
);
546 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
550 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
551 wrong_type_argument (Qsequencep
, arg
);
553 return concat (1, &arg
, XTYPE (arg
), 0);
556 /* This structure holds information of an argument of `concat' that is
557 a string and has text properties to be copied. */
560 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
561 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
562 ptrdiff_t to
; /* refer to VAL (the target string) */
566 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
567 enum Lisp_Type target_type
, bool last_special
)
573 ptrdiff_t toindex_byte
= 0;
574 EMACS_INT result_len
;
575 EMACS_INT result_len_byte
;
577 Lisp_Object last_tail
;
580 /* When we make a multibyte string, we can't copy text properties
581 while concatenating each string because the length of resulting
582 string can't be decided until we finish the whole concatenation.
583 So, we record strings that have text properties to be copied
584 here, and copy the text properties after the concatenation. */
585 struct textprop_rec
*textprops
= NULL
;
586 /* Number of elements in textprops. */
587 ptrdiff_t num_textprops
= 0;
592 /* In append, the last arg isn't treated like the others */
593 if (last_special
&& nargs
> 0)
596 last_tail
= args
[nargs
];
601 /* Check each argument. */
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
605 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
606 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
607 wrong_type_argument (Qsequencep
, this);
610 /* Compute total length in chars of arguments in RESULT_LEN.
611 If desired output is a string, also compute length in bytes
612 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
613 whether the result should be a multibyte string. */
617 for (argnum
= 0; argnum
< nargs
; argnum
++)
621 len
= XFASTINT (Flength (this));
622 if (target_type
== Lisp_String
)
624 /* We must count the number of bytes needed in the string
625 as well as the number of characters. */
629 ptrdiff_t this_len_byte
;
631 if (VECTORP (this) || COMPILEDP (this))
632 for (i
= 0; i
< len
; i
++)
635 CHECK_CHARACTER (ch
);
637 this_len_byte
= CHAR_BYTES (c
);
638 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
640 result_len_byte
+= this_len_byte
;
641 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
644 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
645 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
646 else if (CONSP (this))
647 for (; CONSP (this); this = XCDR (this))
650 CHECK_CHARACTER (ch
);
652 this_len_byte
= CHAR_BYTES (c
);
653 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
655 result_len_byte
+= this_len_byte
;
656 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
659 else if (STRINGP (this))
661 if (STRING_MULTIBYTE (this))
664 this_len_byte
= SBYTES (this);
667 this_len_byte
= count_size_as_multibyte (SDATA (this),
669 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
671 result_len_byte
+= this_len_byte
;
676 if (MOST_POSITIVE_FIXNUM
< result_len
)
677 memory_full (SIZE_MAX
);
680 if (! some_multibyte
)
681 result_len_byte
= result_len
;
683 /* Create the output object. */
684 if (target_type
== Lisp_Cons
)
685 val
= Fmake_list (make_number (result_len
), Qnil
);
686 else if (target_type
== Lisp_Vectorlike
)
687 val
= Fmake_vector (make_number (result_len
), Qnil
);
688 else if (some_multibyte
)
689 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
691 val
= make_uninit_string (result_len
);
693 /* In `append', if all but last arg are nil, return last arg. */
694 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
697 /* Copy the contents of the args into the result. */
699 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
701 toindex
= 0, toindex_byte
= 0;
705 SAFE_NALLOCA (textprops
, 1, nargs
);
707 for (argnum
= 0; argnum
< nargs
; argnum
++)
710 ptrdiff_t thisleni
= 0;
711 register ptrdiff_t thisindex
= 0;
712 register ptrdiff_t thisindex_byte
= 0;
716 thislen
= Flength (this), thisleni
= XINT (thislen
);
718 /* Between strings of the same kind, copy fast. */
719 if (STRINGP (this) && STRINGP (val
)
720 && STRING_MULTIBYTE (this) == some_multibyte
)
722 ptrdiff_t thislen_byte
= SBYTES (this);
724 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
725 if (string_intervals (this))
727 textprops
[num_textprops
].argnum
= argnum
;
728 textprops
[num_textprops
].from
= 0;
729 textprops
[num_textprops
++].to
= toindex
;
731 toindex_byte
+= thislen_byte
;
734 /* Copy a single-byte string to a multibyte string. */
735 else if (STRINGP (this) && STRINGP (val
))
737 if (string_intervals (this))
739 textprops
[num_textprops
].argnum
= argnum
;
740 textprops
[num_textprops
].from
= 0;
741 textprops
[num_textprops
++].to
= toindex
;
743 toindex_byte
+= copy_text (SDATA (this),
744 SDATA (val
) + toindex_byte
,
745 SCHARS (this), 0, 1);
749 /* Copy element by element. */
752 register Lisp_Object elt
;
754 /* Fetch next element of `this' arg into `elt', or break if
755 `this' is exhausted. */
756 if (NILP (this)) break;
758 elt
= XCAR (this), this = XCDR (this);
759 else if (thisindex
>= thisleni
)
761 else if (STRINGP (this))
764 if (STRING_MULTIBYTE (this))
765 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
770 c
= SREF (this, thisindex
); thisindex
++;
771 if (some_multibyte
&& !ASCII_CHAR_P (c
))
772 c
= BYTE8_TO_CHAR (c
);
774 XSETFASTINT (elt
, c
);
776 else if (BOOL_VECTOR_P (this))
778 elt
= bool_vector_ref (this, thisindex
);
783 elt
= AREF (this, thisindex
);
787 /* Store this element into the result. */
794 else if (VECTORP (val
))
796 ASET (val
, toindex
, elt
);
802 CHECK_CHARACTER (elt
);
805 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
807 SSET (val
, toindex_byte
++, c
);
813 XSETCDR (prev
, last_tail
);
815 if (num_textprops
> 0)
818 ptrdiff_t last_to_end
= -1;
820 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
822 this = args
[textprops
[argnum
].argnum
];
823 props
= text_property_list (this,
825 make_number (SCHARS (this)),
827 /* If successive arguments have properties, be sure that the
828 value of `composition' property be the copy. */
829 if (last_to_end
== textprops
[argnum
].to
)
830 make_composition_value_copy (props
);
831 add_text_properties_from_list (val
, props
,
832 make_number (textprops
[argnum
].to
));
833 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
841 static Lisp_Object string_char_byte_cache_string
;
842 static ptrdiff_t string_char_byte_cache_charpos
;
843 static ptrdiff_t string_char_byte_cache_bytepos
;
846 clear_string_char_byte_cache (void)
848 string_char_byte_cache_string
= Qnil
;
851 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
854 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
857 ptrdiff_t best_below
, best_below_byte
;
858 ptrdiff_t best_above
, best_above_byte
;
860 best_below
= best_below_byte
= 0;
861 best_above
= SCHARS (string
);
862 best_above_byte
= SBYTES (string
);
863 if (best_above
== best_above_byte
)
866 if (EQ (string
, string_char_byte_cache_string
))
868 if (string_char_byte_cache_charpos
< char_index
)
870 best_below
= string_char_byte_cache_charpos
;
871 best_below_byte
= string_char_byte_cache_bytepos
;
875 best_above
= string_char_byte_cache_charpos
;
876 best_above_byte
= string_char_byte_cache_bytepos
;
880 if (char_index
- best_below
< best_above
- char_index
)
882 unsigned char *p
= SDATA (string
) + best_below_byte
;
884 while (best_below
< char_index
)
886 p
+= BYTES_BY_CHAR_HEAD (*p
);
889 i_byte
= p
- SDATA (string
);
893 unsigned char *p
= SDATA (string
) + best_above_byte
;
895 while (best_above
> char_index
)
898 while (!CHAR_HEAD_P (*p
)) p
--;
901 i_byte
= p
- SDATA (string
);
904 string_char_byte_cache_bytepos
= i_byte
;
905 string_char_byte_cache_charpos
= char_index
;
906 string_char_byte_cache_string
= string
;
911 /* Return the character index corresponding to BYTE_INDEX in STRING. */
914 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
917 ptrdiff_t best_below
, best_below_byte
;
918 ptrdiff_t best_above
, best_above_byte
;
920 best_below
= best_below_byte
= 0;
921 best_above
= SCHARS (string
);
922 best_above_byte
= SBYTES (string
);
923 if (best_above
== best_above_byte
)
926 if (EQ (string
, string_char_byte_cache_string
))
928 if (string_char_byte_cache_bytepos
< byte_index
)
930 best_below
= string_char_byte_cache_charpos
;
931 best_below_byte
= string_char_byte_cache_bytepos
;
935 best_above
= string_char_byte_cache_charpos
;
936 best_above_byte
= string_char_byte_cache_bytepos
;
940 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
942 unsigned char *p
= SDATA (string
) + best_below_byte
;
943 unsigned char *pend
= SDATA (string
) + byte_index
;
947 p
+= BYTES_BY_CHAR_HEAD (*p
);
951 i_byte
= p
- SDATA (string
);
955 unsigned char *p
= SDATA (string
) + best_above_byte
;
956 unsigned char *pbeg
= SDATA (string
) + byte_index
;
961 while (!CHAR_HEAD_P (*p
)) p
--;
965 i_byte
= p
- SDATA (string
);
968 string_char_byte_cache_bytepos
= i_byte
;
969 string_char_byte_cache_charpos
= i
;
970 string_char_byte_cache_string
= string
;
975 /* Convert STRING to a multibyte string. */
978 string_make_multibyte (Lisp_Object string
)
985 if (STRING_MULTIBYTE (string
))
988 nbytes
= count_size_as_multibyte (SDATA (string
),
990 /* If all the chars are ASCII, they won't need any more bytes
991 once converted. In that case, we can return STRING itself. */
992 if (nbytes
== SBYTES (string
))
995 buf
= SAFE_ALLOCA (nbytes
);
996 copy_text (SDATA (string
), buf
, SBYTES (string
),
999 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1006 /* Convert STRING (if unibyte) to a multibyte string without changing
1007 the number of characters. Characters 0200 trough 0237 are
1008 converted to eight-bit characters. */
1011 string_to_multibyte (Lisp_Object string
)
1018 if (STRING_MULTIBYTE (string
))
1021 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1022 /* If all the chars are ASCII, they won't need any more bytes once
1024 if (nbytes
== SBYTES (string
))
1025 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1027 buf
= SAFE_ALLOCA (nbytes
);
1028 memcpy (buf
, SDATA (string
), SBYTES (string
));
1029 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1031 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1038 /* Convert STRING to a single-byte string. */
1041 string_make_unibyte (Lisp_Object string
)
1048 if (! STRING_MULTIBYTE (string
))
1051 nchars
= SCHARS (string
);
1053 buf
= SAFE_ALLOCA (nchars
);
1054 copy_text (SDATA (string
), buf
, SBYTES (string
),
1057 ret
= make_unibyte_string ((char *) buf
, nchars
);
1063 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1065 doc
: /* Return the multibyte equivalent of STRING.
1066 If STRING is unibyte and contains non-ASCII characters, the function
1067 `unibyte-char-to-multibyte' is used to convert each unibyte character
1068 to a multibyte character. In this case, the returned string is a
1069 newly created string with no text properties. If STRING is multibyte
1070 or entirely ASCII, it is returned unchanged. In particular, when
1071 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1072 \(When the characters are all ASCII, Emacs primitives will treat the
1073 string the same way whether it is unibyte or multibyte.) */)
1074 (Lisp_Object string
)
1076 CHECK_STRING (string
);
1078 return string_make_multibyte (string
);
1081 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1083 doc
: /* Return the unibyte equivalent of STRING.
1084 Multibyte character codes are converted to unibyte according to
1085 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1086 If the lookup in the translation table fails, this function takes just
1087 the low 8 bits of each character. */)
1088 (Lisp_Object string
)
1090 CHECK_STRING (string
);
1092 return string_make_unibyte (string
);
1095 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1097 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1098 If STRING is unibyte, the result is STRING itself.
1099 Otherwise it is a newly created string, with no text properties.
1100 If STRING is multibyte and contains a character of charset
1101 `eight-bit', it is converted to the corresponding single byte. */)
1102 (Lisp_Object string
)
1104 CHECK_STRING (string
);
1106 if (STRING_MULTIBYTE (string
))
1108 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1109 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1111 string
= make_unibyte_string ((char *) str
, bytes
);
1117 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1119 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1120 If STRING is multibyte, the result is STRING itself.
1121 Otherwise it is a newly created string, with no text properties.
1123 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1124 part of a correct utf-8 sequence), it is converted to the corresponding
1125 multibyte character of charset `eight-bit'.
1126 See also `string-to-multibyte'.
1128 Beware, this often doesn't really do what you think it does.
1129 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1130 If you're not sure, whether to use `string-as-multibyte' or
1131 `string-to-multibyte', use `string-to-multibyte'. */)
1132 (Lisp_Object string
)
1134 CHECK_STRING (string
);
1136 if (! STRING_MULTIBYTE (string
))
1138 Lisp_Object new_string
;
1139 ptrdiff_t nchars
, nbytes
;
1141 parse_str_as_multibyte (SDATA (string
),
1144 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1145 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1146 if (nbytes
!= SBYTES (string
))
1147 str_as_multibyte (SDATA (new_string
), nbytes
,
1148 SBYTES (string
), NULL
);
1149 string
= new_string
;
1150 set_string_intervals (string
, NULL
);
1155 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1157 doc
: /* Return a multibyte string with the same individual chars as STRING.
1158 If STRING is multibyte, the result is STRING itself.
1159 Otherwise it is a newly created string, with no text properties.
1161 If STRING is unibyte and contains an 8-bit byte, it is converted to
1162 the corresponding multibyte character of charset `eight-bit'.
1164 This differs from `string-as-multibyte' by converting each byte of a correct
1165 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1166 correct sequence. */)
1167 (Lisp_Object string
)
1169 CHECK_STRING (string
);
1171 return string_to_multibyte (string
);
1174 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1176 doc
: /* Return a unibyte string with the same individual chars as STRING.
1177 If STRING is unibyte, the result is STRING itself.
1178 Otherwise it is a newly created string, with no text properties,
1179 where each `eight-bit' character is converted to the corresponding byte.
1180 If STRING contains a non-ASCII, non-`eight-bit' character,
1181 an error is signaled. */)
1182 (Lisp_Object string
)
1184 CHECK_STRING (string
);
1186 if (STRING_MULTIBYTE (string
))
1188 ptrdiff_t chars
= SCHARS (string
);
1189 unsigned char *str
= xmalloc (chars
);
1190 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1192 if (converted
< chars
)
1193 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1194 string
= make_unibyte_string ((char *) str
, chars
);
1201 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1202 doc
: /* Return a copy of ALIST.
1203 This is an alist which represents the same mapping from objects to objects,
1204 but does not share the alist structure with ALIST.
1205 The objects mapped (cars and cdrs of elements of the alist)
1206 are shared, however.
1207 Elements of ALIST that are not conses are also shared. */)
1210 register Lisp_Object tem
;
1215 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1216 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1218 register Lisp_Object car
;
1222 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1227 /* Check that ARRAY can have a valid subarray [FROM..TO),
1228 given that its size is SIZE.
1229 If FROM is nil, use 0; if TO is nil, use SIZE.
1230 Count negative values backwards from the end.
1231 Set *IFROM and *ITO to the two indexes used. */
1234 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1235 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1239 if (INTEGERP (from
))
1245 else if (NILP (from
))
1248 wrong_type_argument (Qintegerp
, from
);
1259 wrong_type_argument (Qintegerp
, to
);
1261 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1262 args_out_of_range_3 (array
, from
, to
);
1268 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1269 doc
: /* Return a new string whose contents are a substring of STRING.
1270 The returned string consists of the characters between index FROM
1271 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1272 zero-indexed: 0 means the first character of STRING. Negative values
1273 are counted from the end of STRING. If TO is nil, the substring runs
1274 to the end of STRING.
1276 The STRING argument may also be a vector. In that case, the return
1277 value is a new vector that contains the elements between index FROM
1278 \(inclusive) and index TO (exclusive) of that vector argument.
1280 With one argument, just copy STRING (with properties, if any). */)
1281 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1284 ptrdiff_t size
, ifrom
, ito
;
1286 size
= CHECK_VECTOR_OR_STRING (string
);
1287 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1289 if (STRINGP (string
))
1292 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1294 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1295 res
= make_specified_string (SSDATA (string
) + from_byte
,
1296 ito
- ifrom
, to_byte
- from_byte
,
1297 STRING_MULTIBYTE (string
));
1298 copy_text_properties (make_number (ifrom
), make_number (ito
),
1299 string
, make_number (0), res
, Qnil
);
1302 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1308 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1309 doc
: /* Return a substring of STRING, without text properties.
1310 It starts at index FROM and ends before TO.
1311 TO may be nil or omitted; then the substring runs to the end of STRING.
1312 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1313 If FROM or TO is negative, it counts from the end.
1315 With one argument, just copy STRING without its properties. */)
1316 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1318 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1320 CHECK_STRING (string
);
1322 size
= SCHARS (string
);
1323 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1325 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1327 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1328 return make_specified_string (SSDATA (string
) + from_byte
,
1329 to_char
- from_char
, to_byte
- from_byte
,
1330 STRING_MULTIBYTE (string
));
1333 /* Extract a substring of STRING, giving start and end positions
1334 both in characters and in bytes. */
1337 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1338 ptrdiff_t to
, ptrdiff_t to_byte
)
1341 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1343 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1344 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1346 if (STRINGP (string
))
1348 res
= make_specified_string (SSDATA (string
) + from_byte
,
1349 to
- from
, to_byte
- from_byte
,
1350 STRING_MULTIBYTE (string
));
1351 copy_text_properties (make_number (from
), make_number (to
),
1352 string
, make_number (0), res
, Qnil
);
1355 res
= Fvector (to
- from
, aref_addr (string
, from
));
1360 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1361 doc
: /* Take cdr N times on LIST, return the result. */)
1362 (Lisp_Object n
, Lisp_Object list
)
1367 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1370 CHECK_LIST_CONS (list
, list
);
1376 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1377 doc
: /* Return the Nth element of LIST.
1378 N counts from zero. If LIST is not that long, nil is returned. */)
1379 (Lisp_Object n
, Lisp_Object list
)
1381 return Fcar (Fnthcdr (n
, list
));
1384 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1385 doc
: /* Return element of SEQUENCE at index N. */)
1386 (register Lisp_Object sequence
, Lisp_Object n
)
1389 if (CONSP (sequence
) || NILP (sequence
))
1390 return Fcar (Fnthcdr (n
, sequence
));
1392 /* Faref signals a "not array" error, so check here. */
1393 CHECK_ARRAY (sequence
, Qsequencep
);
1394 return Faref (sequence
, n
);
1397 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1398 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1399 The value is actually the tail of LIST whose car is ELT. */)
1400 (register Lisp_Object elt
, Lisp_Object list
)
1402 register Lisp_Object tail
;
1403 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1405 register Lisp_Object tem
;
1406 CHECK_LIST_CONS (tail
, list
);
1408 if (! NILP (Fequal (elt
, tem
)))
1415 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1416 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1417 The value is actually the tail of LIST whose car is ELT. */)
1418 (register Lisp_Object elt
, Lisp_Object list
)
1422 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1426 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1430 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1441 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1442 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1443 The value is actually the tail of LIST whose car is ELT. */)
1444 (register Lisp_Object elt
, Lisp_Object list
)
1446 register Lisp_Object tail
;
1449 return Fmemq (elt
, list
);
1451 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1453 register Lisp_Object tem
;
1454 CHECK_LIST_CONS (tail
, list
);
1456 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1463 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1464 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1465 The value is actually the first element of LIST whose car is KEY.
1466 Elements of LIST that are not conses are ignored. */)
1467 (Lisp_Object key
, Lisp_Object list
)
1472 || (CONSP (XCAR (list
))
1473 && EQ (XCAR (XCAR (list
)), key
)))
1478 || (CONSP (XCAR (list
))
1479 && EQ (XCAR (XCAR (list
)), key
)))
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCAR (XCAR (list
)), key
)))
1495 /* Like Fassq but never report an error and do not allow quits.
1496 Use only on lists known never to be circular. */
1499 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1502 && (!CONSP (XCAR (list
))
1503 || !EQ (XCAR (XCAR (list
)), key
)))
1506 return CAR_SAFE (list
);
1509 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1510 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1511 The value is actually the first element of LIST whose car equals KEY. */)
1512 (Lisp_Object key
, Lisp_Object list
)
1519 || (CONSP (XCAR (list
))
1520 && (car
= XCAR (XCAR (list
)),
1521 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1526 || (CONSP (XCAR (list
))
1527 && (car
= XCAR (XCAR (list
)),
1528 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1533 || (CONSP (XCAR (list
))
1534 && (car
= XCAR (XCAR (list
)),
1535 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1545 /* Like Fassoc but never report an error and do not allow quits.
1546 Use only on lists known never to be circular. */
1549 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1552 && (!CONSP (XCAR (list
))
1553 || (!EQ (XCAR (XCAR (list
)), key
)
1554 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1557 return CONSP (list
) ? XCAR (list
) : Qnil
;
1560 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1561 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1562 The value is actually the first element of LIST whose cdr is KEY. */)
1563 (register Lisp_Object key
, Lisp_Object list
)
1568 || (CONSP (XCAR (list
))
1569 && EQ (XCDR (XCAR (list
)), key
)))
1574 || (CONSP (XCAR (list
))
1575 && EQ (XCDR (XCAR (list
)), key
)))
1580 || (CONSP (XCAR (list
))
1581 && EQ (XCDR (XCAR (list
)), key
)))
1591 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1592 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1593 The value is actually the first element of LIST whose cdr equals KEY. */)
1594 (Lisp_Object key
, Lisp_Object list
)
1601 || (CONSP (XCAR (list
))
1602 && (cdr
= XCDR (XCAR (list
)),
1603 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1608 || (CONSP (XCAR (list
))
1609 && (cdr
= XCDR (XCAR (list
)),
1610 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1615 || (CONSP (XCAR (list
))
1616 && (cdr
= XCDR (XCAR (list
)),
1617 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1627 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1628 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1629 More precisely, this function skips any members `eq' to ELT at the
1630 front of LIST, then removes members `eq' to ELT from the remaining
1631 sublist by modifying its list structure, then returns the resulting
1634 Write `(setq foo (delq element foo))' to be sure of correctly changing
1635 the value of a list `foo'. See also `remq', which does not modify the
1637 (register Lisp_Object elt
, Lisp_Object list
)
1639 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1642 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1644 Lisp_Object tem
= XCAR (tail
);
1650 Fsetcdr (prev
, XCDR (tail
));
1658 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1659 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1660 SEQ must be a sequence (i.e. a list, a vector, or a string).
1661 The return value is a sequence of the same type.
1663 If SEQ is a list, this behaves like `delq', except that it compares
1664 with `equal' instead of `eq'. In particular, it may remove elements
1665 by altering the list structure.
1667 If SEQ is not a list, deletion is never performed destructively;
1668 instead this function creates and returns a new vector or string.
1670 Write `(setq foo (delete element foo))' to be sure of correctly
1671 changing the value of a sequence `foo'. */)
1672 (Lisp_Object elt
, Lisp_Object seq
)
1678 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1679 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1682 if (n
!= ASIZE (seq
))
1684 struct Lisp_Vector
*p
= allocate_vector (n
);
1686 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1687 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1688 p
->contents
[n
++] = AREF (seq
, i
);
1690 XSETVECTOR (seq
, p
);
1693 else if (STRINGP (seq
))
1695 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1698 for (i
= nchars
= nbytes
= ibyte
= 0;
1700 ++i
, ibyte
+= cbytes
)
1702 if (STRING_MULTIBYTE (seq
))
1704 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1705 cbytes
= CHAR_BYTES (c
);
1713 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1720 if (nchars
!= SCHARS (seq
))
1724 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1725 if (!STRING_MULTIBYTE (seq
))
1726 STRING_SET_UNIBYTE (tem
);
1728 for (i
= nchars
= nbytes
= ibyte
= 0;
1730 ++i
, ibyte
+= cbytes
)
1732 if (STRING_MULTIBYTE (seq
))
1734 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1735 cbytes
= CHAR_BYTES (c
);
1743 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1745 unsigned char *from
= SDATA (seq
) + ibyte
;
1746 unsigned char *to
= SDATA (tem
) + nbytes
;
1752 for (n
= cbytes
; n
--; )
1762 Lisp_Object tail
, prev
;
1764 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1766 CHECK_LIST_CONS (tail
, seq
);
1768 if (!NILP (Fequal (elt
, XCAR (tail
))))
1773 Fsetcdr (prev
, XCDR (tail
));
1784 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1785 doc
: /* Reverse order of items in a list, vector or string SEQ.
1786 If SEQ is a list, it should be nil-terminated.
1787 This function may destructively modify SEQ to produce the value. */)
1792 else if (STRINGP (seq
))
1793 return Freverse (seq
);
1794 else if (CONSP (seq
))
1796 Lisp_Object prev
, tail
, next
;
1798 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1801 CHECK_LIST_CONS (tail
, tail
);
1803 Fsetcdr (tail
, prev
);
1808 else if (VECTORP (seq
))
1810 ptrdiff_t i
, size
= ASIZE (seq
);
1812 for (i
= 0; i
< size
/ 2; i
++)
1814 Lisp_Object tem
= AREF (seq
, i
);
1815 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1816 ASET (seq
, size
- i
- 1, tem
);
1819 else if (BOOL_VECTOR_P (seq
))
1821 ptrdiff_t i
, size
= bool_vector_size (seq
);
1823 for (i
= 0; i
< size
/ 2; i
++)
1825 bool tem
= bool_vector_bitref (seq
, i
);
1826 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1827 bool_vector_set (seq
, size
- i
- 1, tem
);
1831 wrong_type_argument (Qarrayp
, seq
);
1835 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1836 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1837 See also the function `nreverse', which is used more often. */)
1844 else if (CONSP (seq
))
1846 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1849 new = Fcons (XCAR (seq
), new);
1851 CHECK_LIST_END (seq
, seq
);
1853 else if (VECTORP (seq
))
1855 ptrdiff_t i
, size
= ASIZE (seq
);
1857 new = make_uninit_vector (size
);
1858 for (i
= 0; i
< size
; i
++)
1859 ASET (new, i
, AREF (seq
, size
- i
- 1));
1861 else if (BOOL_VECTOR_P (seq
))
1864 EMACS_INT nbits
= bool_vector_size (seq
);
1866 new = make_uninit_bool_vector (nbits
);
1867 for (i
= 0; i
< nbits
; i
++)
1868 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1870 else if (STRINGP (seq
))
1872 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1878 new = make_uninit_string (size
);
1879 for (i
= 0; i
< size
; i
++)
1880 SSET (new, i
, SREF (seq
, size
- i
- 1));
1884 unsigned char *p
, *q
;
1886 new = make_uninit_multibyte_string (size
, bytes
);
1887 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1888 while (q
> SDATA (new))
1892 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1894 CHAR_STRING (ch
, q
);
1899 wrong_type_argument (Qsequencep
, seq
);
1903 /* Sort LIST using PREDICATE, preserving original order of elements
1904 considered as equal. */
1907 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1909 Lisp_Object front
, back
;
1910 Lisp_Object len
, tem
;
1914 len
= Flength (list
);
1915 length
= XINT (len
);
1919 XSETINT (len
, (length
/ 2) - 1);
1920 tem
= Fnthcdr (len
, list
);
1922 Fsetcdr (tem
, Qnil
);
1924 front
= Fsort (front
, predicate
);
1925 back
= Fsort (back
, predicate
);
1926 return merge (front
, back
, predicate
);
1929 /* Using PRED to compare, return whether A and B are in order.
1930 Compare stably when A appeared before B in the input. */
1932 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1934 return NILP (call2 (pred
, b
, a
));
1937 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1938 into DEST. Argument arrays must be nonempty and must not overlap,
1939 except that B might be the last part of DEST. */
1941 merge_vectors (Lisp_Object pred
,
1942 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1943 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1944 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1946 eassume (0 < alen
&& 0 < blen
);
1947 Lisp_Object
const *alim
= a
+ alen
;
1948 Lisp_Object
const *blim
= b
+ blen
;
1952 if (inorder (pred
, a
[0], b
[0]))
1958 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1967 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1974 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1975 temporary storage. LEN must be at least 2. */
1977 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1978 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1979 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1982 ptrdiff_t halflen
= len
>> 1;
1983 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1984 if (1 < len
- halflen
)
1985 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1986 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1989 /* Using PRED to compare, sort from LEN-length SRC into DST.
1990 Len must be positive. */
1992 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1993 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1994 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1997 ptrdiff_t halflen
= len
>> 1;
2003 sort_vector_inplace (pred
, halflen
, src
, dest
);
2004 if (1 < len
- halflen
)
2005 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
2006 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
2010 /* Sort VECTOR in place using PREDICATE, preserving original order of
2011 elements considered as equal. */
2014 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
2016 ptrdiff_t len
= ASIZE (vector
);
2019 ptrdiff_t halflen
= len
>> 1;
2022 SAFE_ALLOCA_LISP (tmp
, halflen
);
2023 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
2024 tmp
[i
] = make_number (0);
2025 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2029 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2030 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2031 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2032 modified by side effects. PREDICATE is called with two elements of
2033 SEQ, and should return non-nil if the first element should sort before
2035 (Lisp_Object seq
, Lisp_Object predicate
)
2038 seq
= sort_list (seq
, predicate
);
2039 else if (VECTORP (seq
))
2040 sort_vector (seq
, predicate
);
2041 else if (!NILP (seq
))
2042 wrong_type_argument (Qsequencep
, seq
);
2047 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2049 Lisp_Object l1
= org_l1
;
2050 Lisp_Object l2
= org_l2
;
2051 Lisp_Object tail
= Qnil
;
2052 Lisp_Object value
= Qnil
;
2072 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2087 Fsetcdr (tail
, tem
);
2093 /* This does not check for quits. That is safe since it must terminate. */
2095 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2096 doc
: /* Extract a value from a property list.
2097 PLIST is a property list, which is a list of the form
2098 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2099 corresponding to the given PROP, or nil if PROP is not one of the
2100 properties on the list. This function never signals an error. */)
2101 (Lisp_Object plist
, Lisp_Object prop
)
2103 Lisp_Object tail
, halftail
;
2105 /* halftail is used to detect circular lists. */
2106 tail
= halftail
= plist
;
2107 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2109 if (EQ (prop
, XCAR (tail
)))
2110 return XCAR (XCDR (tail
));
2112 tail
= XCDR (XCDR (tail
));
2113 halftail
= XCDR (halftail
);
2114 if (EQ (tail
, halftail
))
2121 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2122 doc
: /* Return the value of SYMBOL's PROPNAME property.
2123 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2124 (Lisp_Object symbol
, Lisp_Object propname
)
2126 CHECK_SYMBOL (symbol
);
2127 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2130 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2131 doc
: /* Change value in PLIST of PROP to VAL.
2132 PLIST is a property list, which is a list of the form
2133 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2134 If PROP is already a property on the list, its value is set to VAL,
2135 otherwise the new PROP VAL pair is added. The new plist is returned;
2136 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2137 The PLIST is modified by side effects. */)
2138 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2140 register Lisp_Object tail
, prev
;
2141 Lisp_Object newcell
;
2143 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2144 tail
= XCDR (XCDR (tail
)))
2146 if (EQ (prop
, XCAR (tail
)))
2148 Fsetcar (XCDR (tail
), val
);
2155 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2159 Fsetcdr (XCDR (prev
), newcell
);
2163 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2164 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2165 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2166 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2168 CHECK_SYMBOL (symbol
);
2170 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2174 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2175 doc
: /* Extract a value from a property list, comparing with `equal'.
2176 PLIST is a property list, which is a list of the form
2177 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2178 corresponding to the given PROP, or nil if PROP is not
2179 one of the properties on the list. */)
2180 (Lisp_Object plist
, Lisp_Object prop
)
2185 CONSP (tail
) && CONSP (XCDR (tail
));
2186 tail
= XCDR (XCDR (tail
)))
2188 if (! NILP (Fequal (prop
, XCAR (tail
))))
2189 return XCAR (XCDR (tail
));
2194 CHECK_LIST_END (tail
, prop
);
2199 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2200 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2201 PLIST is a property list, which is a list of the form
2202 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2203 If PROP is already a property on the list, its value is set to VAL,
2204 otherwise the new PROP VAL pair is added. The new plist is returned;
2205 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2206 The PLIST is modified by side effects. */)
2207 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2209 register Lisp_Object tail
, prev
;
2210 Lisp_Object newcell
;
2212 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2213 tail
= XCDR (XCDR (tail
)))
2215 if (! NILP (Fequal (prop
, XCAR (tail
))))
2217 Fsetcar (XCDR (tail
), val
);
2224 newcell
= list2 (prop
, val
);
2228 Fsetcdr (XCDR (prev
), newcell
);
2232 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2233 doc
: /* Return t if the two args are the same Lisp object.
2234 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2235 (Lisp_Object obj1
, Lisp_Object obj2
)
2238 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2240 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2243 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2244 doc
: /* Return t if two Lisp objects have similar structure and contents.
2245 They must have the same data type.
2246 Conses are compared by comparing the cars and the cdrs.
2247 Vectors and strings are compared element by element.
2248 Numbers are compared by value, but integers cannot equal floats.
2249 (Use `=' if you want integers and floats to be able to be equal.)
2250 Symbols must match exactly. */)
2251 (register Lisp_Object o1
, Lisp_Object o2
)
2253 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2256 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2257 doc
: /* Return t if two Lisp objects have similar structure and contents.
2258 This is like `equal' except that it compares the text properties
2259 of strings. (`equal' ignores text properties.) */)
2260 (register Lisp_Object o1
, Lisp_Object o2
)
2262 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2265 /* DEPTH is current depth of recursion. Signal an error if it
2267 PROPS means compare string text properties too. */
2270 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2276 error ("Stack overflow in equal");
2278 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2281 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2283 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2285 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2287 { /* `o1' was seen already. */
2288 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2289 if (!NILP (Fmemq (o2
, o2s
)))
2292 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2295 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2305 if (XTYPE (o1
) != XTYPE (o2
))
2314 d1
= extract_float (o1
);
2315 d2
= extract_float (o2
);
2316 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2317 though they are not =. */
2318 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2322 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2326 /* FIXME: This inf-loops in a circular list! */
2330 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2334 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2335 depth
+ 1, props
, ht
)
2336 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2337 depth
+ 1, props
, ht
))
2339 o1
= XOVERLAY (o1
)->plist
;
2340 o2
= XOVERLAY (o2
)->plist
;
2345 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2346 && (XMARKER (o1
)->buffer
== 0
2347 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2351 case Lisp_Vectorlike
:
2354 ptrdiff_t size
= ASIZE (o1
);
2355 /* Pseudovectors have the type encoded in the size field, so this test
2356 actually checks that the objects have the same type as well as the
2358 if (ASIZE (o2
) != size
)
2360 /* Boolvectors are compared much like strings. */
2361 if (BOOL_VECTOR_P (o1
))
2363 EMACS_INT size
= bool_vector_size (o1
);
2364 if (size
!= bool_vector_size (o2
))
2366 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2367 bool_vector_bytes (size
)))
2371 if (WINDOW_CONFIGURATIONP (o1
))
2372 return compare_window_configurations (o1
, o2
, 0);
2374 /* Aside from them, only true vectors, char-tables, compiled
2375 functions, and fonts (font-spec, font-entity, font-object)
2376 are sensible to compare, so eliminate the others now. */
2377 if (size
& PSEUDOVECTOR_FLAG
)
2379 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2382 size
&= PSEUDOVECTOR_SIZE_MASK
;
2384 for (i
= 0; i
< size
; i
++)
2389 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2397 if (SCHARS (o1
) != SCHARS (o2
))
2399 if (SBYTES (o1
) != SBYTES (o2
))
2401 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2403 if (props
&& !compare_string_intervals (o1
, o2
))
2415 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2416 doc
: /* Store each element of ARRAY with ITEM.
2417 ARRAY is a vector, string, char-table, or bool-vector. */)
2418 (Lisp_Object array
, Lisp_Object item
)
2420 register ptrdiff_t size
, idx
;
2422 if (VECTORP (array
))
2423 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2424 ASET (array
, idx
, item
);
2425 else if (CHAR_TABLE_P (array
))
2429 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2430 set_char_table_contents (array
, i
, item
);
2431 set_char_table_defalt (array
, item
);
2433 else if (STRINGP (array
))
2435 register unsigned char *p
= SDATA (array
);
2437 CHECK_CHARACTER (item
);
2438 charval
= XFASTINT (item
);
2439 size
= SCHARS (array
);
2440 if (STRING_MULTIBYTE (array
))
2442 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2443 int len
= CHAR_STRING (charval
, str
);
2444 ptrdiff_t size_byte
= SBYTES (array
);
2447 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2448 error ("Attempt to change byte length of a string");
2449 for (idx
= 0; idx
< size_byte
; idx
++)
2450 *p
++ = str
[idx
% len
];
2453 for (idx
= 0; idx
< size
; idx
++)
2456 else if (BOOL_VECTOR_P (array
))
2457 return bool_vector_fill (array
, item
);
2459 wrong_type_argument (Qarrayp
, array
);
2463 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2465 doc
: /* Clear the contents of STRING.
2466 This makes STRING unibyte and may change its length. */)
2467 (Lisp_Object string
)
2470 CHECK_STRING (string
);
2471 len
= SBYTES (string
);
2472 memset (SDATA (string
), 0, len
);
2473 STRING_SET_CHARS (string
, len
);
2474 STRING_SET_UNIBYTE (string
);
2480 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2482 return CALLN (Fnconc
, s1
, s2
);
2485 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2486 doc
: /* Concatenate any number of lists by altering them.
2487 Only the last argument is not altered, and need not be a list.
2488 usage: (nconc &rest LISTS) */)
2489 (ptrdiff_t nargs
, Lisp_Object
*args
)
2492 register Lisp_Object tail
, tem
, val
;
2496 for (argnum
= 0; argnum
< nargs
; argnum
++)
2499 if (NILP (tem
)) continue;
2504 if (argnum
+ 1 == nargs
) break;
2506 CHECK_LIST_CONS (tem
, tem
);
2515 tem
= args
[argnum
+ 1];
2516 Fsetcdr (tail
, tem
);
2518 args
[argnum
+ 1] = tail
;
2524 /* This is the guts of all mapping functions.
2525 Apply FN to each element of SEQ, one by one,
2526 storing the results into elements of VALS, a C vector of Lisp_Objects.
2527 LENI is the length of VALS, which should also be the length of SEQ. */
2530 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2532 Lisp_Object tail
, dummy
;
2535 if (VECTORP (seq
) || COMPILEDP (seq
))
2537 for (i
= 0; i
< leni
; i
++)
2539 dummy
= call1 (fn
, AREF (seq
, i
));
2544 else if (BOOL_VECTOR_P (seq
))
2546 for (i
= 0; i
< leni
; i
++)
2548 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2553 else if (STRINGP (seq
))
2557 for (i
= 0, i_byte
= 0; i
< leni
;)
2560 ptrdiff_t i_before
= i
;
2562 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2563 XSETFASTINT (dummy
, c
);
2564 dummy
= call1 (fn
, dummy
);
2566 vals
[i_before
] = dummy
;
2569 else /* Must be a list, since Flength did not get an error */
2572 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2574 dummy
= call1 (fn
, XCAR (tail
));
2582 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2583 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2584 In between each pair of results, stick in SEPARATOR. Thus, " " as
2585 SEPARATOR results in spaces between the values returned by FUNCTION.
2586 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2587 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2597 len
= Flength (sequence
);
2598 if (CHAR_TABLE_P (sequence
))
2599 wrong_type_argument (Qlistp
, sequence
);
2601 nargs
= leni
+ leni
- 1;
2602 if (nargs
< 0) return empty_unibyte_string
;
2604 SAFE_ALLOCA_LISP (args
, nargs
);
2606 mapcar1 (leni
, args
, function
, sequence
);
2608 for (i
= leni
- 1; i
> 0; i
--)
2609 args
[i
+ i
] = args
[i
];
2611 for (i
= 1; i
< nargs
; i
+= 2)
2612 args
[i
] = separator
;
2614 ret
= Fconcat (nargs
, args
);
2620 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2621 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2622 The result is a list just as long as SEQUENCE.
2623 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2624 (Lisp_Object function
, Lisp_Object sequence
)
2626 register Lisp_Object len
;
2627 register EMACS_INT leni
;
2628 register Lisp_Object
*args
;
2632 len
= Flength (sequence
);
2633 if (CHAR_TABLE_P (sequence
))
2634 wrong_type_argument (Qlistp
, sequence
);
2635 leni
= XFASTINT (len
);
2637 SAFE_ALLOCA_LISP (args
, leni
);
2639 mapcar1 (leni
, args
, function
, sequence
);
2641 ret
= Flist (leni
, args
);
2647 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2648 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2649 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2650 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2651 (Lisp_Object function
, Lisp_Object sequence
)
2653 register EMACS_INT leni
;
2655 leni
= XFASTINT (Flength (sequence
));
2656 if (CHAR_TABLE_P (sequence
))
2657 wrong_type_argument (Qlistp
, sequence
);
2658 mapcar1 (leni
, 0, function
, sequence
);
2663 /* This is how C code calls `yes-or-no-p' and allows the user
2667 do_yes_or_no_p (Lisp_Object prompt
)
2669 return call1 (intern ("yes-or-no-p"), prompt
);
2672 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2673 doc
: /* Ask user a yes-or-no question.
2674 Return t if answer is yes, and nil if the answer is no.
2675 PROMPT is the string to display to ask the question. It should end in
2676 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2678 The user must confirm the answer with RET, and can edit it until it
2681 If dialog boxes are supported, a dialog box will be used
2682 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2683 (Lisp_Object prompt
)
2687 CHECK_STRING (prompt
);
2689 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2690 && use_dialog_box
&& ! NILP (last_input_event
))
2692 Lisp_Object pane
, menu
, obj
;
2693 redisplay_preserve_echo_area (4);
2694 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2695 Fcons (build_string ("No"), Qnil
));
2696 menu
= Fcons (prompt
, pane
);
2697 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2701 AUTO_STRING (yes_or_no
, "(yes or no) ");
2702 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2706 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2707 Qyes_or_no_p_history
, Qnil
,
2709 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2711 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2716 message1 ("Please answer yes or no.");
2717 Fsleep_for (make_number (2), Qnil
);
2721 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2722 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2724 Each of the three load averages is multiplied by 100, then converted
2727 When USE-FLOATS is non-nil, floats will be used instead of integers.
2728 These floats are not multiplied by 100.
2730 If the 5-minute or 15-minute load averages are not available, return a
2731 shortened list, containing only those averages which are available.
2733 An error is thrown if the load average can't be obtained. In some
2734 cases making it work would require Emacs being installed setuid or
2735 setgid so that it can read kernel information, and that usually isn't
2737 (Lisp_Object use_floats
)
2740 int loads
= getloadavg (load_ave
, 3);
2741 Lisp_Object ret
= Qnil
;
2744 error ("load-average not implemented for this operating system");
2748 Lisp_Object load
= (NILP (use_floats
)
2749 ? make_number (100.0 * load_ave
[loads
])
2750 : make_float (load_ave
[loads
]));
2751 ret
= Fcons (load
, ret
);
2757 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2758 doc
: /* Return t if FEATURE is present in this Emacs.
2760 Use this to conditionalize execution of lisp code based on the
2761 presence or absence of Emacs or environment extensions.
2762 Use `provide' to declare that a feature is available. This function
2763 looks at the value of the variable `features'. The optional argument
2764 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2765 (Lisp_Object feature
, Lisp_Object subfeature
)
2767 register Lisp_Object tem
;
2768 CHECK_SYMBOL (feature
);
2769 tem
= Fmemq (feature
, Vfeatures
);
2770 if (!NILP (tem
) && !NILP (subfeature
))
2771 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2772 return (NILP (tem
)) ? Qnil
: Qt
;
2775 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2776 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2777 The optional argument SUBFEATURES should be a list of symbols listing
2778 particular subfeatures supported in this version of FEATURE. */)
2779 (Lisp_Object feature
, Lisp_Object subfeatures
)
2781 register Lisp_Object tem
;
2782 CHECK_SYMBOL (feature
);
2783 CHECK_LIST (subfeatures
);
2784 if (!NILP (Vautoload_queue
))
2785 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2787 tem
= Fmemq (feature
, Vfeatures
);
2789 Vfeatures
= Fcons (feature
, Vfeatures
);
2790 if (!NILP (subfeatures
))
2791 Fput (feature
, Qsubfeatures
, subfeatures
);
2792 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2794 /* Run any load-hooks for this file. */
2795 tem
= Fassq (feature
, Vafter_load_alist
);
2797 Fmapc (Qfuncall
, XCDR (tem
));
2802 /* `require' and its subroutines. */
2804 /* List of features currently being require'd, innermost first. */
2806 static Lisp_Object require_nesting_list
;
2809 require_unwind (Lisp_Object old_value
)
2811 require_nesting_list
= old_value
;
2814 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2815 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2816 If FEATURE is not a member of the list `features', then the feature is
2817 not loaded; so load the file FILENAME.
2819 If FILENAME is omitted, the printname of FEATURE is used as the file
2820 name, and `load' will try to load this name appended with the suffix
2821 `.elc', `.el', or the system-dependent suffix for dynamic module
2822 files, in that order. The name without appended suffix will not be
2823 used. See `get-load-suffixes' for the complete list of suffixes.
2825 The directories in `load-path' are searched when trying to find the
2828 If the optional third argument NOERROR is non-nil, then return nil if
2829 the file is not found instead of signaling an error. Normally the
2830 return value is FEATURE.
2832 The normal messages at start and end of loading FILENAME are
2834 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2837 bool from_file
= load_in_progress
;
2839 CHECK_SYMBOL (feature
);
2841 /* Record the presence of `require' in this file
2842 even if the feature specified is already loaded.
2843 But not more than once in any file,
2844 and not when we aren't loading or reading from a file. */
2846 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2847 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2852 tem
= Fcons (Qrequire
, feature
);
2853 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2854 LOADHIST_ATTACH (tem
);
2856 tem
= Fmemq (feature
, Vfeatures
);
2860 ptrdiff_t count
= SPECPDL_INDEX ();
2863 /* This is to make sure that loadup.el gives a clear picture
2864 of what files are preloaded and when. */
2865 if (! NILP (Vpurify_flag
))
2866 error ("(require %s) while preparing to dump",
2867 SDATA (SYMBOL_NAME (feature
)));
2869 /* A certain amount of recursive `require' is legitimate,
2870 but if we require the same feature recursively 3 times,
2872 tem
= require_nesting_list
;
2873 while (! NILP (tem
))
2875 if (! NILP (Fequal (feature
, XCAR (tem
))))
2880 error ("Recursive `require' for feature `%s'",
2881 SDATA (SYMBOL_NAME (feature
)));
2883 /* Update the list for any nested `require's that occur. */
2884 record_unwind_protect (require_unwind
, require_nesting_list
);
2885 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2887 /* Value saved here is to be restored into Vautoload_queue */
2888 record_unwind_protect (un_autoload
, Vautoload_queue
);
2889 Vautoload_queue
= Qt
;
2891 /* Load the file. */
2892 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2893 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2895 /* If load failed entirely, return nil. */
2897 return unbind_to (count
, Qnil
);
2899 tem
= Fmemq (feature
, Vfeatures
);
2901 error ("Required feature `%s' was not provided",
2902 SDATA (SYMBOL_NAME (feature
)));
2904 /* Once loading finishes, don't undo it. */
2905 Vautoload_queue
= Qt
;
2906 feature
= unbind_to (count
, feature
);
2912 /* Primitives for work of the "widget" library.
2913 In an ideal world, this section would not have been necessary.
2914 However, lisp function calls being as slow as they are, it turns
2915 out that some functions in the widget library (wid-edit.el) are the
2916 bottleneck of Widget operation. Here is their translation to C,
2917 for the sole reason of efficiency. */
2919 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2920 doc
: /* Return non-nil if PLIST has the property PROP.
2921 PLIST is a property list, which is a list of the form
2922 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2923 Unlike `plist-get', this allows you to distinguish between a missing
2924 property and a property with the value nil.
2925 The value is actually the tail of PLIST whose car is PROP. */)
2926 (Lisp_Object plist
, Lisp_Object prop
)
2928 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2930 plist
= XCDR (plist
);
2931 plist
= CDR (plist
);
2937 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2938 doc
: /* In WIDGET, set PROPERTY to VALUE.
2939 The value can later be retrieved with `widget-get'. */)
2940 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2942 CHECK_CONS (widget
);
2943 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2947 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2948 doc
: /* In WIDGET, get the value of PROPERTY.
2949 The value could either be specified when the widget was created, or
2950 later with `widget-put'. */)
2951 (Lisp_Object widget
, Lisp_Object property
)
2959 CHECK_CONS (widget
);
2960 tmp
= Fplist_member (XCDR (widget
), property
);
2966 tmp
= XCAR (widget
);
2969 widget
= Fget (tmp
, Qwidget_type
);
2973 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2974 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2975 ARGS are passed as extra arguments to the function.
2976 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2977 (ptrdiff_t nargs
, Lisp_Object
*args
)
2979 Lisp_Object widget
= args
[0];
2980 Lisp_Object property
= args
[1];
2981 Lisp_Object propval
= Fwidget_get (widget
, property
);
2982 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2983 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2987 #ifdef HAVE_LANGINFO_CODESET
2988 #include <langinfo.h>
2991 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2992 doc
: /* Access locale data ITEM for the current C locale, if available.
2993 ITEM should be one of the following:
2995 `codeset', returning the character set as a string (locale item CODESET);
2997 `days', returning a 7-element vector of day names (locale items DAY_n);
2999 `months', returning a 12-element vector of month names (locale items MON_n);
3001 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3002 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3004 If the system can't provide such information through a call to
3005 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3007 See also Info node `(libc)Locales'.
3009 The data read from the system are decoded using `locale-coding-system'. */)
3013 #ifdef HAVE_LANGINFO_CODESET
3014 if (EQ (item
, Qcodeset
))
3016 str
= nl_langinfo (CODESET
);
3017 return build_string (str
);
3020 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3022 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3023 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3025 synchronize_system_time_locale ();
3026 for (i
= 0; i
< 7; i
++)
3028 str
= nl_langinfo (days
[i
]);
3029 AUTO_STRING (val
, str
);
3030 /* Fixme: Is this coding system necessarily right, even if
3031 it is consistent with CODESET? If not, what to do? */
3032 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3039 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3041 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3042 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3043 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3045 synchronize_system_time_locale ();
3046 for (i
= 0; i
< 12; i
++)
3048 str
= nl_langinfo (months
[i
]);
3049 AUTO_STRING (val
, str
);
3050 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3056 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3057 but is in the locale files. This could be used by ps-print. */
3059 else if (EQ (item
, Qpaper
))
3060 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3061 #endif /* PAPER_WIDTH */
3062 #endif /* HAVE_LANGINFO_CODESET*/
3066 /* base64 encode/decode functions (RFC 2045).
3067 Based on code from GNU recode. */
3069 #define MIME_LINE_LENGTH 76
3071 #define IS_ASCII(Character) \
3073 #define IS_BASE64(Character) \
3074 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3075 #define IS_BASE64_IGNORABLE(Character) \
3076 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3077 || (Character) == '\f' || (Character) == '\r')
3079 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3080 character or return retval if there are no characters left to
3082 #define READ_QUADRUPLET_BYTE(retval) \
3087 if (nchars_return) \
3088 *nchars_return = nchars; \
3093 while (IS_BASE64_IGNORABLE (c))
3095 /* Table of characters coding the 64 values. */
3096 static const char base64_value_to_char
[64] =
3098 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3099 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3100 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3101 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3102 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3103 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3104 '8', '9', '+', '/' /* 60-63 */
3107 /* Table of base64 values for first 128 characters. */
3108 static const short base64_char_to_value
[128] =
3110 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3111 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3112 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3113 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3114 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3115 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3116 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3117 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3118 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3119 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3120 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3121 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3122 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3125 /* The following diagram shows the logical steps by which three octets
3126 get transformed into four base64 characters.
3128 .--------. .--------. .--------.
3129 |aaaaaabb| |bbbbcccc| |ccdddddd|
3130 `--------' `--------' `--------'
3132 .--------+--------+--------+--------.
3133 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3134 `--------+--------+--------+--------'
3136 .--------+--------+--------+--------.
3137 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3138 `--------+--------+--------+--------'
3140 The octets are divided into 6 bit chunks, which are then encoded into
3141 base64 characters. */
3144 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3145 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3148 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3150 doc
: /* Base64-encode the region between BEG and END.
3151 Return the length of the encoded text.
3152 Optional third argument NO-LINE-BREAK means do not break long lines
3153 into shorter lines. */)
3154 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3157 ptrdiff_t allength
, length
;
3158 ptrdiff_t ibeg
, iend
, encoded_length
;
3159 ptrdiff_t old_pos
= PT
;
3162 validate_region (&beg
, &end
);
3164 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3165 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3166 move_gap_both (XFASTINT (beg
), ibeg
);
3168 /* We need to allocate enough room for encoding the text.
3169 We need 33 1/3% more space, plus a newline every 76
3170 characters, and then we round up. */
3171 length
= iend
- ibeg
;
3172 allength
= length
+ length
/3 + 1;
3173 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3175 encoded
= SAFE_ALLOCA (allength
);
3176 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3177 encoded
, length
, NILP (no_line_break
),
3178 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3179 if (encoded_length
> allength
)
3182 if (encoded_length
< 0)
3184 /* The encoding wasn't possible. */
3186 error ("Multibyte character in data for base64 encoding");
3189 /* Now we have encoded the region, so we insert the new contents
3190 and delete the old. (Insert first in order to preserve markers.) */
3191 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3192 insert (encoded
, encoded_length
);
3194 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3196 /* If point was outside of the region, restore it exactly; else just
3197 move to the beginning of the region. */
3198 if (old_pos
>= XFASTINT (end
))
3199 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3200 else if (old_pos
> XFASTINT (beg
))
3201 old_pos
= XFASTINT (beg
);
3204 /* We return the length of the encoded text. */
3205 return make_number (encoded_length
);
3208 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3210 doc
: /* Base64-encode STRING and return the result.
3211 Optional second argument NO-LINE-BREAK means do not break long lines
3212 into shorter lines. */)
3213 (Lisp_Object string
, Lisp_Object no_line_break
)
3215 ptrdiff_t allength
, length
, encoded_length
;
3217 Lisp_Object encoded_string
;
3220 CHECK_STRING (string
);
3222 /* We need to allocate enough room for encoding the text.
3223 We need 33 1/3% more space, plus a newline every 76
3224 characters, and then we round up. */
3225 length
= SBYTES (string
);
3226 allength
= length
+ length
/3 + 1;
3227 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3229 /* We need to allocate enough room for decoding the text. */
3230 encoded
= SAFE_ALLOCA (allength
);
3232 encoded_length
= base64_encode_1 (SSDATA (string
),
3233 encoded
, length
, NILP (no_line_break
),
3234 STRING_MULTIBYTE (string
));
3235 if (encoded_length
> allength
)
3238 if (encoded_length
< 0)
3240 /* The encoding wasn't possible. */
3241 error ("Multibyte character in data for base64 encoding");
3244 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3247 return encoded_string
;
3251 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3252 bool line_break
, bool multibyte
)
3265 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3266 if (CHAR_BYTE8_P (c
))
3267 c
= CHAR_TO_BYTE8 (c
);
3275 /* Wrap line every 76 characters. */
3279 if (counter
< MIME_LINE_LENGTH
/ 4)
3288 /* Process first byte of a triplet. */
3290 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3291 value
= (0x03 & c
) << 4;
3293 /* Process second byte of a triplet. */
3297 *e
++ = base64_value_to_char
[value
];
3305 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3306 if (CHAR_BYTE8_P (c
))
3307 c
= CHAR_TO_BYTE8 (c
);
3315 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3316 value
= (0x0f & c
) << 2;
3318 /* Process third byte of a triplet. */
3322 *e
++ = base64_value_to_char
[value
];
3329 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3330 if (CHAR_BYTE8_P (c
))
3331 c
= CHAR_TO_BYTE8 (c
);
3339 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3340 *e
++ = base64_value_to_char
[0x3f & c
];
3347 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3349 doc
: /* Base64-decode the region between BEG and END.
3350 Return the length of the decoded text.
3351 If the region can't be decoded, signal an error and don't modify the buffer. */)
3352 (Lisp_Object beg
, Lisp_Object end
)
3354 ptrdiff_t ibeg
, iend
, length
, allength
;
3356 ptrdiff_t old_pos
= PT
;
3357 ptrdiff_t decoded_length
;
3358 ptrdiff_t inserted_chars
;
3359 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3362 validate_region (&beg
, &end
);
3364 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3365 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3367 length
= iend
- ibeg
;
3369 /* We need to allocate enough room for decoding the text. If we are
3370 working on a multibyte buffer, each decoded code may occupy at
3372 allength
= multibyte
? length
* 2 : length
;
3373 decoded
= SAFE_ALLOCA (allength
);
3375 move_gap_both (XFASTINT (beg
), ibeg
);
3376 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3378 multibyte
, &inserted_chars
);
3379 if (decoded_length
> allength
)
3382 if (decoded_length
< 0)
3384 /* The decoding wasn't possible. */
3385 error ("Invalid base64 data");
3388 /* Now we have decoded the region, so we insert the new contents
3389 and delete the old. (Insert first in order to preserve markers.) */
3390 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3391 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3394 /* Delete the original text. */
3395 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3396 iend
+ decoded_length
, 1);
3398 /* If point was outside of the region, restore it exactly; else just
3399 move to the beginning of the region. */
3400 if (old_pos
>= XFASTINT (end
))
3401 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3402 else if (old_pos
> XFASTINT (beg
))
3403 old_pos
= XFASTINT (beg
);
3404 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3406 return make_number (inserted_chars
);
3409 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3411 doc
: /* Base64-decode STRING and return the result. */)
3412 (Lisp_Object string
)
3415 ptrdiff_t length
, decoded_length
;
3416 Lisp_Object decoded_string
;
3419 CHECK_STRING (string
);
3421 length
= SBYTES (string
);
3422 /* We need to allocate enough room for decoding the text. */
3423 decoded
= SAFE_ALLOCA (length
);
3425 /* The decoded result should be unibyte. */
3426 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3428 if (decoded_length
> length
)
3430 else if (decoded_length
>= 0)
3431 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3433 decoded_string
= Qnil
;
3436 if (!STRINGP (decoded_string
))
3437 error ("Invalid base64 data");
3439 return decoded_string
;
3442 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3443 MULTIBYTE, the decoded result should be in multibyte
3444 form. If NCHARS_RETURN is not NULL, store the number of produced
3445 characters in *NCHARS_RETURN. */
3448 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3449 bool multibyte
, ptrdiff_t *nchars_return
)
3451 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3454 unsigned long value
;
3455 ptrdiff_t nchars
= 0;
3459 /* Process first byte of a quadruplet. */
3461 READ_QUADRUPLET_BYTE (e
-to
);
3465 value
= base64_char_to_value
[c
] << 18;
3467 /* Process second byte of a quadruplet. */
3469 READ_QUADRUPLET_BYTE (-1);
3473 value
|= base64_char_to_value
[c
] << 12;
3475 c
= (unsigned char) (value
>> 16);
3476 if (multibyte
&& c
>= 128)
3477 e
+= BYTE8_STRING (c
, e
);
3482 /* Process third byte of a quadruplet. */
3484 READ_QUADRUPLET_BYTE (-1);
3488 READ_QUADRUPLET_BYTE (-1);
3497 value
|= base64_char_to_value
[c
] << 6;
3499 c
= (unsigned char) (0xff & value
>> 8);
3500 if (multibyte
&& c
>= 128)
3501 e
+= BYTE8_STRING (c
, e
);
3506 /* Process fourth byte of a quadruplet. */
3508 READ_QUADRUPLET_BYTE (-1);
3515 value
|= base64_char_to_value
[c
];
3517 c
= (unsigned char) (0xff & value
);
3518 if (multibyte
&& c
>= 128)
3519 e
+= BYTE8_STRING (c
, e
);
3528 /***********************************************************************
3530 ***** Hash Tables *****
3532 ***********************************************************************/
3534 /* Implemented by gerd@gnu.org. This hash table implementation was
3535 inspired by CMUCL hash tables. */
3539 1. For small tables, association lists are probably faster than
3540 hash tables because they have lower overhead.
3542 For uses of hash tables where the O(1) behavior of table
3543 operations is not a requirement, it might therefore be a good idea
3544 not to hash. Instead, we could just do a linear search in the
3545 key_and_value vector of the hash table. This could be done
3546 if a `:linear-search t' argument is given to make-hash-table. */
3549 /* The list of all weak hash tables. Don't staticpro this one. */
3551 static struct Lisp_Hash_Table
*weak_hash_tables
;
3554 /***********************************************************************
3556 ***********************************************************************/
3559 CHECK_HASH_TABLE (Lisp_Object x
)
3561 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3565 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3567 h
->key_and_value
= key_and_value
;
3570 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3575 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3577 gc_aset (h
->next
, idx
, val
);
3580 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3585 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3587 gc_aset (h
->hash
, idx
, val
);
3590 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3595 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3597 gc_aset (h
->index
, idx
, val
);
3600 /* If OBJ is a Lisp hash table, return a pointer to its struct
3601 Lisp_Hash_Table. Otherwise, signal an error. */
3603 static struct Lisp_Hash_Table
*
3604 check_hash_table (Lisp_Object obj
)
3606 CHECK_HASH_TABLE (obj
);
3607 return XHASH_TABLE (obj
);
3611 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3612 number. A number is "almost" a prime number if it is not divisible
3613 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3616 next_almost_prime (EMACS_INT n
)
3618 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3619 for (n
|= 1; ; n
+= 2)
3620 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3625 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3626 which USED[I] is non-zero. If found at index I in ARGS, set
3627 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3628 0. This function is used to extract a keyword/argument pair from
3629 a DEFUN parameter list. */
3632 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3636 for (i
= 1; i
< nargs
; i
++)
3637 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3648 /* Return a Lisp vector which has the same contents as VEC but has
3649 at least INCR_MIN more entries, where INCR_MIN is positive.
3650 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3651 than NITEMS_MAX. Entries in the resulting
3652 vector that are not copied from VEC are set to nil. */
3655 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3657 struct Lisp_Vector
*v
;
3658 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3659 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3660 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3661 ? nitems_max
: C_language_max
);
3662 eassert (VECTORP (vec
));
3663 eassert (0 < incr_min
&& -1 <= nitems_max
);
3664 old_size
= ASIZE (vec
);
3665 incr_max
= n_max
- old_size
;
3666 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3667 if (incr_max
< incr
)
3668 memory_full (SIZE_MAX
);
3669 new_size
= old_size
+ incr
;
3670 v
= allocate_vector (new_size
);
3671 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3672 memclear (v
->contents
+ old_size
, incr
* word_size
);
3673 XSETVECTOR (vec
, v
);
3678 /***********************************************************************
3680 ***********************************************************************/
3682 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3683 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3684 KEY2 are the same. */
3687 cmpfn_eql (struct hash_table_test
*ht
,
3691 return (FLOATP (key1
)
3693 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3697 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3698 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3699 KEY2 are the same. */
3702 cmpfn_equal (struct hash_table_test
*ht
,
3706 return !NILP (Fequal (key1
, key2
));
3710 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3711 HASH2 in hash table H using H->user_cmp_function. Value is true
3712 if KEY1 and KEY2 are the same. */
3715 cmpfn_user_defined (struct hash_table_test
*ht
,
3719 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3722 /* Value is a hash code for KEY for use in hash table H which uses
3723 `eq' to compare keys. The hash code returned is guaranteed to fit
3724 in a Lisp integer. */
3727 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3729 return XHASH (key
) ^ XTYPE (key
);
3732 /* Value is a hash code for KEY for use in hash table H which uses
3733 `equal' to compare keys. The hash code returned is guaranteed to fit
3734 in a Lisp integer. */
3737 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3739 return sxhash (key
, 0);
3742 /* Value is a hash code for KEY for use in hash table H which uses
3743 `eql' to compare keys. The hash code returned is guaranteed to fit
3744 in a Lisp integer. */
3747 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3749 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3752 /* Value is a hash code for KEY for use in hash table H which uses as
3753 user-defined function to compare keys. The hash code returned is
3754 guaranteed to fit in a Lisp integer. */
3757 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3759 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3760 return hashfn_eq (ht
, hash
);
3763 struct hash_table_test
const
3764 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3765 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3766 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3767 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3768 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3769 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3771 /* Allocate basically initialized hash table. */
3773 static struct Lisp_Hash_Table
*
3774 allocate_hash_table (void)
3776 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3777 count
, PVEC_HASH_TABLE
);
3780 /* An upper bound on the size of a hash table index. It must fit in
3781 ptrdiff_t and be a valid Emacs fixnum. */
3782 #define INDEX_SIZE_BOUND \
3783 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3785 /* Create and initialize a new hash table.
3787 TEST specifies the test the hash table will use to compare keys.
3788 It must be either one of the predefined tests `eq', `eql' or
3789 `equal' or a symbol denoting a user-defined test named TEST with
3790 test and hash functions USER_TEST and USER_HASH.
3792 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3794 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3795 new size when it becomes full is computed by adding REHASH_SIZE to
3796 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3797 table's new size is computed by multiplying its old size with
3800 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3801 be resized when the ratio of (number of entries in the table) /
3802 (table size) is >= REHASH_THRESHOLD.
3804 WEAK specifies the weakness of the table. If non-nil, it must be
3805 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3808 make_hash_table (struct hash_table_test test
,
3809 Lisp_Object size
, Lisp_Object rehash_size
,
3810 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3812 struct Lisp_Hash_Table
*h
;
3814 EMACS_INT index_size
, sz
;
3818 /* Preconditions. */
3819 eassert (SYMBOLP (test
.name
));
3820 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3821 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3822 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3823 eassert (FLOATP (rehash_threshold
)
3824 && 0 < XFLOAT_DATA (rehash_threshold
)
3825 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3827 if (XFASTINT (size
) == 0)
3828 size
= make_number (1);
3830 sz
= XFASTINT (size
);
3831 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3832 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3833 ? next_almost_prime (index_float
)
3834 : INDEX_SIZE_BOUND
+ 1);
3835 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3836 error ("Hash table too large");
3838 /* Allocate a table and initialize it. */
3839 h
= allocate_hash_table ();
3841 /* Initialize hash table slots. */
3844 h
->rehash_threshold
= rehash_threshold
;
3845 h
->rehash_size
= rehash_size
;
3847 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3848 h
->hash
= Fmake_vector (size
, Qnil
);
3849 h
->next
= Fmake_vector (size
, Qnil
);
3850 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3852 /* Set up the free list. */
3853 for (i
= 0; i
< sz
- 1; ++i
)
3854 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3855 h
->next_free
= make_number (0);
3857 XSET_HASH_TABLE (table
, h
);
3858 eassert (HASH_TABLE_P (table
));
3859 eassert (XHASH_TABLE (table
) == h
);
3861 /* Maybe add this hash table to the list of all weak hash tables. */
3863 h
->next_weak
= NULL
;
3866 h
->next_weak
= weak_hash_tables
;
3867 weak_hash_tables
= h
;
3874 /* Return a copy of hash table H1. Keys and values are not copied,
3875 only the table itself is. */
3878 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3881 struct Lisp_Hash_Table
*h2
;
3883 h2
= allocate_hash_table ();
3885 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3886 h2
->hash
= Fcopy_sequence (h1
->hash
);
3887 h2
->next
= Fcopy_sequence (h1
->next
);
3888 h2
->index
= Fcopy_sequence (h1
->index
);
3889 XSET_HASH_TABLE (table
, h2
);
3891 /* Maybe add this hash table to the list of all weak hash tables. */
3892 if (!NILP (h2
->weak
))
3894 h2
->next_weak
= weak_hash_tables
;
3895 weak_hash_tables
= h2
;
3902 /* Resize hash table H if it's too full. If H cannot be resized
3903 because it's already too large, throw an error. */
3906 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3908 if (NILP (h
->next_free
))
3910 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3911 EMACS_INT new_size
, index_size
, nsize
;
3915 if (INTEGERP (h
->rehash_size
))
3916 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3919 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3920 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3922 new_size
= float_new_size
;
3923 if (new_size
<= old_size
)
3924 new_size
= old_size
+ 1;
3927 new_size
= INDEX_SIZE_BOUND
+ 1;
3929 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3930 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3931 ? next_almost_prime (index_float
)
3932 : INDEX_SIZE_BOUND
+ 1);
3933 nsize
= max (index_size
, 2 * new_size
);
3934 if (INDEX_SIZE_BOUND
< nsize
)
3935 error ("Hash table too large to resize");
3937 #ifdef ENABLE_CHECKING
3938 if (HASH_TABLE_P (Vpurify_flag
)
3939 && XHASH_TABLE (Vpurify_flag
) == h
)
3940 message ("Growing hash table to: %"pI
"d", new_size
);
3943 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3944 2 * (new_size
- old_size
), -1));
3945 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3946 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3947 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3949 /* Update the free list. Do it so that new entries are added at
3950 the end of the free list. This makes some operations like
3952 for (i
= old_size
; i
< new_size
- 1; ++i
)
3953 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3955 if (!NILP (h
->next_free
))
3957 Lisp_Object last
, next
;
3959 last
= h
->next_free
;
3960 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3964 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3967 XSETFASTINT (h
->next_free
, old_size
);
3970 for (i
= 0; i
< old_size
; ++i
)
3971 if (!NILP (HASH_HASH (h
, i
)))
3973 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3974 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3975 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3976 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3982 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3983 the hash code of KEY. Value is the index of the entry in H
3984 matching KEY, or -1 if not found. */
3987 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3989 EMACS_UINT hash_code
;
3990 ptrdiff_t start_of_bucket
;
3993 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3994 eassert ((hash_code
& ~INTMASK
) == 0);
3998 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3999 idx
= HASH_INDEX (h
, start_of_bucket
);
4003 ptrdiff_t i
= XFASTINT (idx
);
4004 if (EQ (key
, HASH_KEY (h
, i
))
4006 && hash_code
== XUINT (HASH_HASH (h
, i
))
4007 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4009 idx
= HASH_NEXT (h
, i
);
4012 return NILP (idx
) ? -1 : XFASTINT (idx
);
4016 /* Put an entry into hash table H that associates KEY with VALUE.
4017 HASH is a previously computed hash code of KEY.
4018 Value is the index of the entry in H matching KEY. */
4021 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4024 ptrdiff_t start_of_bucket
, i
;
4026 eassert ((hash
& ~INTMASK
) == 0);
4028 /* Increment count after resizing because resizing may fail. */
4029 maybe_resize_hash_table (h
);
4032 /* Store key/value in the key_and_value vector. */
4033 i
= XFASTINT (h
->next_free
);
4034 h
->next_free
= HASH_NEXT (h
, i
);
4035 set_hash_key_slot (h
, i
, key
);
4036 set_hash_value_slot (h
, i
, value
);
4038 /* Remember its hash code. */
4039 set_hash_hash_slot (h
, i
, make_number (hash
));
4041 /* Add new entry to its collision chain. */
4042 start_of_bucket
= hash
% ASIZE (h
->index
);
4043 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4044 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4049 /* Remove the entry matching KEY from hash table H, if there is one. */
4052 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4054 EMACS_UINT hash_code
;
4055 ptrdiff_t start_of_bucket
;
4056 Lisp_Object idx
, prev
;
4058 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4059 eassert ((hash_code
& ~INTMASK
) == 0);
4060 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4061 idx
= HASH_INDEX (h
, start_of_bucket
);
4066 ptrdiff_t i
= XFASTINT (idx
);
4068 if (EQ (key
, HASH_KEY (h
, i
))
4070 && hash_code
== XUINT (HASH_HASH (h
, i
))
4071 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4073 /* Take entry out of collision chain. */
4075 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4077 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4079 /* Clear slots in key_and_value and add the slots to
4081 set_hash_key_slot (h
, i
, Qnil
);
4082 set_hash_value_slot (h
, i
, Qnil
);
4083 set_hash_hash_slot (h
, i
, Qnil
);
4084 set_hash_next_slot (h
, i
, h
->next_free
);
4085 h
->next_free
= make_number (i
);
4087 eassert (h
->count
>= 0);
4093 idx
= HASH_NEXT (h
, i
);
4099 /* Clear hash table H. */
4102 hash_clear (struct Lisp_Hash_Table
*h
)
4106 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4108 for (i
= 0; i
< size
; ++i
)
4110 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4111 set_hash_key_slot (h
, i
, Qnil
);
4112 set_hash_value_slot (h
, i
, Qnil
);
4113 set_hash_hash_slot (h
, i
, Qnil
);
4116 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4117 ASET (h
->index
, i
, Qnil
);
4119 h
->next_free
= make_number (0);
4126 /************************************************************************
4128 ************************************************************************/
4130 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4131 entries from the table that don't survive the current GC.
4132 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4133 true if anything was marked. */
4136 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4138 ptrdiff_t n
= gc_asize (h
->index
);
4139 bool marked
= false;
4141 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4143 Lisp_Object idx
, next
, prev
;
4145 /* Follow collision chain, removing entries that
4146 don't survive this garbage collection. */
4148 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4150 ptrdiff_t i
= XFASTINT (idx
);
4151 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4152 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4155 if (EQ (h
->weak
, Qkey
))
4156 remove_p
= !key_known_to_survive_p
;
4157 else if (EQ (h
->weak
, Qvalue
))
4158 remove_p
= !value_known_to_survive_p
;
4159 else if (EQ (h
->weak
, Qkey_or_value
))
4160 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4161 else if (EQ (h
->weak
, Qkey_and_value
))
4162 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4166 next
= HASH_NEXT (h
, i
);
4168 if (remove_entries_p
)
4172 /* Take out of collision chain. */
4174 set_hash_index_slot (h
, bucket
, next
);
4176 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4178 /* Add to free list. */
4179 set_hash_next_slot (h
, i
, h
->next_free
);
4182 /* Clear key, value, and hash. */
4183 set_hash_key_slot (h
, i
, Qnil
);
4184 set_hash_value_slot (h
, i
, Qnil
);
4185 set_hash_hash_slot (h
, i
, Qnil
);
4198 /* Make sure key and value survive. */
4199 if (!key_known_to_survive_p
)
4201 mark_object (HASH_KEY (h
, i
));
4205 if (!value_known_to_survive_p
)
4207 mark_object (HASH_VALUE (h
, i
));
4218 /* Remove elements from weak hash tables that don't survive the
4219 current garbage collection. Remove weak tables that don't survive
4220 from Vweak_hash_tables. Called from gc_sweep. */
4222 NO_INLINE
/* For better stack traces */
4224 sweep_weak_hash_tables (void)
4226 struct Lisp_Hash_Table
*h
, *used
, *next
;
4229 /* Mark all keys and values that are in use. Keep on marking until
4230 there is no more change. This is necessary for cases like
4231 value-weak table A containing an entry X -> Y, where Y is used in a
4232 key-weak table B, Z -> Y. If B comes after A in the list of weak
4233 tables, X -> Y might be removed from A, although when looking at B
4234 one finds that it shouldn't. */
4238 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4240 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4241 marked
|= sweep_weak_table (h
, 0);
4246 /* Remove tables and entries that aren't used. */
4247 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4249 next
= h
->next_weak
;
4251 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4253 /* TABLE is marked as used. Sweep its contents. */
4255 sweep_weak_table (h
, 1);
4257 /* Add table to the list of used weak hash tables. */
4258 h
->next_weak
= used
;
4263 weak_hash_tables
= used
;
4268 /***********************************************************************
4269 Hash Code Computation
4270 ***********************************************************************/
4272 /* Maximum depth up to which to dive into Lisp structures. */
4274 #define SXHASH_MAX_DEPTH 3
4276 /* Maximum length up to which to take list and vector elements into
4279 #define SXHASH_MAX_LEN 7
4281 /* Return a hash for string PTR which has length LEN. The hash value
4282 can be any EMACS_UINT value. */
4285 hash_string (char const *ptr
, ptrdiff_t len
)
4287 char const *p
= ptr
;
4288 char const *end
= p
+ len
;
4290 EMACS_UINT hash
= 0;
4295 hash
= sxhash_combine (hash
, c
);
4301 /* Return a hash for string PTR which has length LEN. The hash
4302 code returned is guaranteed to fit in a Lisp integer. */
4305 sxhash_string (char const *ptr
, ptrdiff_t len
)
4307 EMACS_UINT hash
= hash_string (ptr
, len
);
4308 return SXHASH_REDUCE (hash
);
4311 /* Return a hash for the floating point value VAL. */
4314 sxhash_float (double val
)
4316 EMACS_UINT hash
= 0;
4318 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4319 + (sizeof val
% sizeof hash
!= 0))
4323 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4327 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4328 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4329 hash
= sxhash_combine (hash
, u
.word
[i
]);
4330 return SXHASH_REDUCE (hash
);
4333 /* Return a hash for list LIST. DEPTH is the current depth in the
4334 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4337 sxhash_list (Lisp_Object list
, int depth
)
4339 EMACS_UINT hash
= 0;
4342 if (depth
< SXHASH_MAX_DEPTH
)
4344 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4345 list
= XCDR (list
), ++i
)
4347 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4348 hash
= sxhash_combine (hash
, hash2
);
4353 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4354 hash
= sxhash_combine (hash
, hash2
);
4357 return SXHASH_REDUCE (hash
);
4361 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4362 the Lisp structure. */
4365 sxhash_vector (Lisp_Object vec
, int depth
)
4367 EMACS_UINT hash
= ASIZE (vec
);
4370 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4371 for (i
= 0; i
< n
; ++i
)
4373 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4374 hash
= sxhash_combine (hash
, hash2
);
4377 return SXHASH_REDUCE (hash
);
4380 /* Return a hash for bool-vector VECTOR. */
4383 sxhash_bool_vector (Lisp_Object vec
)
4385 EMACS_INT size
= bool_vector_size (vec
);
4386 EMACS_UINT hash
= size
;
4389 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4390 for (i
= 0; i
< n
; ++i
)
4391 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4393 return SXHASH_REDUCE (hash
);
4397 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4398 structure. Value is an unsigned integer clipped to INTMASK. */
4401 sxhash (Lisp_Object obj
, int depth
)
4405 if (depth
> SXHASH_MAX_DEPTH
)
4408 switch (XTYPE (obj
))
4420 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4423 /* This can be everything from a vector to an overlay. */
4424 case Lisp_Vectorlike
:
4426 /* According to the CL HyperSpec, two arrays are equal only if
4427 they are `eq', except for strings and bit-vectors. In
4428 Emacs, this works differently. We have to compare element
4430 hash
= sxhash_vector (obj
, depth
);
4431 else if (BOOL_VECTOR_P (obj
))
4432 hash
= sxhash_bool_vector (obj
);
4434 /* Others are `equal' if they are `eq', so let's take their
4440 hash
= sxhash_list (obj
, depth
);
4444 hash
= sxhash_float (XFLOAT_DATA (obj
));
4456 /***********************************************************************
4458 ***********************************************************************/
4460 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4461 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4462 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4465 return make_number (hashfn_eq (NULL
, obj
));
4468 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4469 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4470 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4473 return make_number (hashfn_eql (NULL
, obj
));
4476 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4477 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4478 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4481 return make_number (hashfn_equal (NULL
, obj
));
4484 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4485 doc
: /* Create and return a new hash table.
4487 Arguments are specified as keyword/argument pairs. The following
4488 arguments are defined:
4490 :test TEST -- TEST must be a symbol that specifies how to compare
4491 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4492 `equal'. User-supplied test and hash functions can be specified via
4493 `define-hash-table-test'.
4495 :size SIZE -- A hint as to how many elements will be put in the table.
4498 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4499 fills up. If REHASH-SIZE is an integer, increase the size by that
4500 amount. If it is a float, it must be > 1.0, and the new size is the
4501 old size multiplied by that factor. Default is 1.5.
4503 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4504 Resize the hash table when the ratio (number of entries / table size)
4505 is greater than or equal to THRESHOLD. Default is 0.8.
4507 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4508 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4509 returned is a weak table. Key/value pairs are removed from a weak
4510 hash table when there are no non-weak references pointing to their
4511 key, value, one of key or value, or both key and value, depending on
4512 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4515 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4516 (ptrdiff_t nargs
, Lisp_Object
*args
)
4518 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4519 struct hash_table_test testdesc
;
4523 /* The vector `used' is used to keep track of arguments that
4524 have been consumed. */
4525 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4526 memset (used
, 0, nargs
* sizeof *used
);
4528 /* See if there's a `:test TEST' among the arguments. */
4529 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4530 test
= i
? args
[i
] : Qeql
;
4532 testdesc
= hashtest_eq
;
4533 else if (EQ (test
, Qeql
))
4534 testdesc
= hashtest_eql
;
4535 else if (EQ (test
, Qequal
))
4536 testdesc
= hashtest_equal
;
4539 /* See if it is a user-defined test. */
4542 prop
= Fget (test
, Qhash_table_test
);
4543 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4544 signal_error ("Invalid hash table test", test
);
4545 testdesc
.name
= test
;
4546 testdesc
.user_cmp_function
= XCAR (prop
);
4547 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4548 testdesc
.hashfn
= hashfn_user_defined
;
4549 testdesc
.cmpfn
= cmpfn_user_defined
;
4552 /* See if there's a `:size SIZE' argument. */
4553 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4554 size
= i
? args
[i
] : Qnil
;
4556 size
= make_number (DEFAULT_HASH_SIZE
);
4557 else if (!INTEGERP (size
) || XINT (size
) < 0)
4558 signal_error ("Invalid hash table size", size
);
4560 /* Look for `:rehash-size SIZE'. */
4561 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4562 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4563 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4564 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4565 signal_error ("Invalid hash table rehash size", rehash_size
);
4567 /* Look for `:rehash-threshold THRESHOLD'. */
4568 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4569 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4570 if (! (FLOATP (rehash_threshold
)
4571 && 0 < XFLOAT_DATA (rehash_threshold
)
4572 && XFLOAT_DATA (rehash_threshold
) <= 1))
4573 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4575 /* Look for `:weakness WEAK'. */
4576 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4577 weak
= i
? args
[i
] : Qnil
;
4579 weak
= Qkey_and_value
;
4582 && !EQ (weak
, Qvalue
)
4583 && !EQ (weak
, Qkey_or_value
)
4584 && !EQ (weak
, Qkey_and_value
))
4585 signal_error ("Invalid hash table weakness", weak
);
4587 /* Now, all args should have been used up, or there's a problem. */
4588 for (i
= 0; i
< nargs
; ++i
)
4590 signal_error ("Invalid argument list", args
[i
]);
4593 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4597 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4598 doc
: /* Return a copy of hash table TABLE. */)
4601 return copy_hash_table (check_hash_table (table
));
4605 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4606 doc
: /* Return the number of elements in TABLE. */)
4609 return make_number (check_hash_table (table
)->count
);
4613 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4614 Shash_table_rehash_size
, 1, 1, 0,
4615 doc
: /* Return the current rehash size of TABLE. */)
4618 return check_hash_table (table
)->rehash_size
;
4622 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4623 Shash_table_rehash_threshold
, 1, 1, 0,
4624 doc
: /* Return the current rehash threshold of TABLE. */)
4627 return check_hash_table (table
)->rehash_threshold
;
4631 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4632 doc
: /* Return the size of TABLE.
4633 The size can be used as an argument to `make-hash-table' to create
4634 a hash table than can hold as many elements as TABLE holds
4635 without need for resizing. */)
4638 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4639 return make_number (HASH_TABLE_SIZE (h
));
4643 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4644 doc
: /* Return the test TABLE uses. */)
4647 return check_hash_table (table
)->test
.name
;
4651 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4653 doc
: /* Return the weakness of TABLE. */)
4656 return check_hash_table (table
)->weak
;
4660 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4661 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4664 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4668 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4669 doc
: /* Clear hash table TABLE and return it. */)
4672 hash_clear (check_hash_table (table
));
4673 /* Be compatible with XEmacs. */
4678 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4679 doc
: /* Look up KEY in TABLE and return its associated value.
4680 If KEY is not found, return DFLT which defaults to nil. */)
4681 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4683 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4684 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4685 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4689 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4690 doc
: /* Associate KEY with VALUE in hash table TABLE.
4691 If KEY is already present in table, replace its current value with
4692 VALUE. In any case, return VALUE. */)
4693 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4695 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4699 i
= hash_lookup (h
, key
, &hash
);
4701 set_hash_value_slot (h
, i
, value
);
4703 hash_put (h
, key
, value
, hash
);
4709 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4710 doc
: /* Remove KEY from TABLE. */)
4711 (Lisp_Object key
, Lisp_Object table
)
4713 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4714 hash_remove_from_table (h
, key
);
4719 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4720 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4721 FUNCTION is called with two arguments, KEY and VALUE.
4722 `maphash' always returns nil. */)
4723 (Lisp_Object function
, Lisp_Object table
)
4725 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4727 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4728 if (!NILP (HASH_HASH (h
, i
)))
4729 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4735 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4736 Sdefine_hash_table_test
, 3, 3, 0,
4737 doc
: /* Define a new hash table test with name NAME, a symbol.
4739 In hash tables created with NAME specified as test, use TEST to
4740 compare keys, and HASH for computing hash codes of keys.
4742 TEST must be a function taking two arguments and returning non-nil if
4743 both arguments are the same. HASH must be a function taking one
4744 argument and returning an object that is the hash code of the argument.
4745 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4746 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4747 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4749 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4754 /************************************************************************
4755 MD5, SHA-1, and SHA-2
4756 ************************************************************************/
4764 make_digest_string (Lisp_Object digest
, int digest_size
)
4766 unsigned char *p
= SDATA (digest
);
4768 for (int i
= digest_size
- 1; i
>= 0; i
--)
4770 static char const hexdigit
[16] = "0123456789abcdef";
4772 p
[2 * i
] = hexdigit
[p_i
>> 4];
4773 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4778 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4781 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4782 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4785 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4786 register EMACS_INT b
, e
;
4787 register struct buffer
*bp
;
4790 void *(*hash_func
) (const char *, size_t, void *);
4793 CHECK_SYMBOL (algorithm
);
4795 if (STRINGP (object
))
4797 if (NILP (coding_system
))
4799 /* Decide the coding-system to encode the data with. */
4801 if (STRING_MULTIBYTE (object
))
4802 /* use default, we can't guess correct value */
4803 coding_system
= preferred_coding_system ();
4805 coding_system
= Qraw_text
;
4808 if (NILP (Fcoding_system_p (coding_system
)))
4810 /* Invalid coding system. */
4812 if (!NILP (noerror
))
4813 coding_system
= Qraw_text
;
4815 xsignal1 (Qcoding_system_error
, coding_system
);
4818 if (STRING_MULTIBYTE (object
))
4819 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4821 size
= SCHARS (object
);
4822 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4824 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4825 end_byte
= (end_char
== size
4827 : string_char_to_byte (object
, end_char
));
4831 struct buffer
*prev
= current_buffer
;
4833 record_unwind_current_buffer ();
4835 CHECK_BUFFER (object
);
4837 bp
= XBUFFER (object
);
4838 set_buffer_internal (bp
);
4844 CHECK_NUMBER_COERCE_MARKER (start
);
4852 CHECK_NUMBER_COERCE_MARKER (end
);
4857 temp
= b
, b
= e
, e
= temp
;
4859 if (!(BEGV
<= b
&& e
<= ZV
))
4860 args_out_of_range (start
, end
);
4862 if (NILP (coding_system
))
4864 /* Decide the coding-system to encode the data with.
4865 See fileio.c:Fwrite-region */
4867 if (!NILP (Vcoding_system_for_write
))
4868 coding_system
= Vcoding_system_for_write
;
4871 bool force_raw_text
= 0;
4873 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4874 if (NILP (coding_system
)
4875 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4877 coding_system
= Qnil
;
4878 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4882 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4884 /* Check file-coding-system-alist. */
4885 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4886 Qwrite_region
, start
, end
,
4887 Fbuffer_file_name (object
));
4888 if (CONSP (val
) && !NILP (XCDR (val
)))
4889 coding_system
= XCDR (val
);
4892 if (NILP (coding_system
)
4893 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4895 /* If we still have not decided a coding system, use the
4896 default value of buffer-file-coding-system. */
4897 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4901 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4902 /* Confirm that VAL can surely encode the current region. */
4903 coding_system
= call4 (Vselect_safe_coding_system_function
,
4904 make_number (b
), make_number (e
),
4905 coding_system
, Qnil
);
4908 coding_system
= Qraw_text
;
4911 if (NILP (Fcoding_system_p (coding_system
)))
4913 /* Invalid coding system. */
4915 if (!NILP (noerror
))
4916 coding_system
= Qraw_text
;
4918 xsignal1 (Qcoding_system_error
, coding_system
);
4922 object
= make_buffer_string (b
, e
, 0);
4923 set_buffer_internal (prev
);
4924 /* Discard the unwind protect for recovering the current
4928 if (STRING_MULTIBYTE (object
))
4929 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4931 end_byte
= SBYTES (object
);
4934 if (EQ (algorithm
, Qmd5
))
4936 digest_size
= MD5_DIGEST_SIZE
;
4937 hash_func
= md5_buffer
;
4939 else if (EQ (algorithm
, Qsha1
))
4941 digest_size
= SHA1_DIGEST_SIZE
;
4942 hash_func
= sha1_buffer
;
4944 else if (EQ (algorithm
, Qsha224
))
4946 digest_size
= SHA224_DIGEST_SIZE
;
4947 hash_func
= sha224_buffer
;
4949 else if (EQ (algorithm
, Qsha256
))
4951 digest_size
= SHA256_DIGEST_SIZE
;
4952 hash_func
= sha256_buffer
;
4954 else if (EQ (algorithm
, Qsha384
))
4956 digest_size
= SHA384_DIGEST_SIZE
;
4957 hash_func
= sha384_buffer
;
4959 else if (EQ (algorithm
, Qsha512
))
4961 digest_size
= SHA512_DIGEST_SIZE
;
4962 hash_func
= sha512_buffer
;
4965 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4967 /* allocate 2 x digest_size so that it can be re-used to hold the
4969 digest
= make_uninit_string (digest_size
* 2);
4971 hash_func (SSDATA (object
) + start_byte
,
4972 end_byte
- start_byte
,
4976 return make_digest_string (digest
, digest_size
);
4978 return make_unibyte_string (SSDATA (digest
), digest_size
);
4981 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4982 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4984 A message digest is a cryptographic checksum of a document, and the
4985 algorithm to calculate it is defined in RFC 1321.
4987 The two optional arguments START and END are character positions
4988 specifying for which part of OBJECT the message digest should be
4989 computed. If nil or omitted, the digest is computed for the whole
4992 The MD5 message digest is computed from the result of encoding the
4993 text in a coding system, not directly from the internal Emacs form of
4994 the text. The optional fourth argument CODING-SYSTEM specifies which
4995 coding system to encode the text with. It should be the same coding
4996 system that you used or will use when actually writing the text into a
4999 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5000 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5001 system would be chosen by default for writing this text into a file.
5003 If OBJECT is a string, the most preferred coding system (see the
5004 command `prefer-coding-system') is used.
5006 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5007 guesswork fails. Normally, an error is signaled in such case. */)
5008 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5010 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5013 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5014 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5015 ALGORITHM is a symbol specifying the hash to use:
5016 md5, sha1, sha224, sha256, sha384 or sha512.
5018 The two optional arguments START and END are positions specifying for
5019 which part of OBJECT to compute the hash. If nil or omitted, uses the
5022 If BINARY is non-nil, returns a string in binary form. */)
5023 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5025 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5028 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5029 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5030 This hash is performed on the raw internal format of the buffer,
5031 disregarding any coding systems.
5032 If nil, use the current buffer." */ )
5033 (Lisp_Object buffer_or_name
)
5037 struct sha1_ctx ctx
;
5039 if (NILP (buffer_or_name
))
5040 buffer
= Fcurrent_buffer ();
5042 buffer
= Fget_buffer (buffer_or_name
);
5044 nsberror (buffer_or_name
);
5046 b
= XBUFFER (buffer
);
5047 sha1_init_ctx (&ctx
);
5049 /* Process the first part of the buffer. */
5050 sha1_process_bytes (BUF_BEG_ADDR (b
),
5051 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5054 /* If the gap is before the end of the buffer, process the last half
5056 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5057 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5058 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5061 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5062 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5063 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5070 DEFSYM (Qmd5
, "md5");
5071 DEFSYM (Qsha1
, "sha1");
5072 DEFSYM (Qsha224
, "sha224");
5073 DEFSYM (Qsha256
, "sha256");
5074 DEFSYM (Qsha384
, "sha384");
5075 DEFSYM (Qsha512
, "sha512");
5077 /* Hash table stuff. */
5078 DEFSYM (Qhash_table_p
, "hash-table-p");
5080 DEFSYM (Qeql
, "eql");
5081 DEFSYM (Qequal
, "equal");
5082 DEFSYM (QCtest
, ":test");
5083 DEFSYM (QCsize
, ":size");
5084 DEFSYM (QCrehash_size
, ":rehash-size");
5085 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5086 DEFSYM (QCweakness
, ":weakness");
5087 DEFSYM (Qkey
, "key");
5088 DEFSYM (Qvalue
, "value");
5089 DEFSYM (Qhash_table_test
, "hash-table-test");
5090 DEFSYM (Qkey_or_value
, "key-or-value");
5091 DEFSYM (Qkey_and_value
, "key-and-value");
5093 defsubr (&Ssxhash_eq
);
5094 defsubr (&Ssxhash_eql
);
5095 defsubr (&Ssxhash_equal
);
5096 defsubr (&Smake_hash_table
);
5097 defsubr (&Scopy_hash_table
);
5098 defsubr (&Shash_table_count
);
5099 defsubr (&Shash_table_rehash_size
);
5100 defsubr (&Shash_table_rehash_threshold
);
5101 defsubr (&Shash_table_size
);
5102 defsubr (&Shash_table_test
);
5103 defsubr (&Shash_table_weakness
);
5104 defsubr (&Shash_table_p
);
5105 defsubr (&Sclrhash
);
5106 defsubr (&Sgethash
);
5107 defsubr (&Sputhash
);
5108 defsubr (&Sremhash
);
5109 defsubr (&Smaphash
);
5110 defsubr (&Sdefine_hash_table_test
);
5112 DEFSYM (Qstring_lessp
, "string-lessp");
5113 DEFSYM (Qprovide
, "provide");
5114 DEFSYM (Qrequire
, "require");
5115 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5116 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5117 DEFSYM (Qwidget_type
, "widget-type");
5119 staticpro (&string_char_byte_cache_string
);
5120 string_char_byte_cache_string
= Qnil
;
5122 require_nesting_list
= Qnil
;
5123 staticpro (&require_nesting_list
);
5125 Fset (Qyes_or_no_p_history
, Qnil
);
5127 DEFVAR_LISP ("features", Vfeatures
,
5128 doc
: /* A list of symbols which are the features of the executing Emacs.
5129 Used by `featurep' and `require', and altered by `provide'. */);
5130 Vfeatures
= list1 (Qemacs
);
5131 DEFSYM (Qsubfeatures
, "subfeatures");
5132 DEFSYM (Qfuncall
, "funcall");
5134 #ifdef HAVE_LANGINFO_CODESET
5135 DEFSYM (Qcodeset
, "codeset");
5136 DEFSYM (Qdays
, "days");
5137 DEFSYM (Qmonths
, "months");
5138 DEFSYM (Qpaper
, "paper");
5139 #endif /* HAVE_LANGINFO_CODESET */
5141 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5142 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5143 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5144 invoked by mouse clicks and mouse menu items.
5146 On some platforms, file selection dialogs are also enabled if this is
5150 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5151 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5152 This applies to commands from menus and tool bar buttons even when
5153 they are initiated from the keyboard. If `use-dialog-box' is nil,
5154 that disables the use of a file dialog, regardless of the value of
5156 use_file_dialog
= 1;
5158 defsubr (&Sidentity
);
5161 defsubr (&Ssafe_length
);
5162 defsubr (&Sstring_bytes
);
5163 defsubr (&Sstring_equal
);
5164 defsubr (&Scompare_strings
);
5165 defsubr (&Sstring_lessp
);
5166 defsubr (&Sstring_version_lessp
);
5167 defsubr (&Sstring_collate_lessp
);
5168 defsubr (&Sstring_collate_equalp
);
5171 defsubr (&Svconcat
);
5172 defsubr (&Scopy_sequence
);
5173 defsubr (&Sstring_make_multibyte
);
5174 defsubr (&Sstring_make_unibyte
);
5175 defsubr (&Sstring_as_multibyte
);
5176 defsubr (&Sstring_as_unibyte
);
5177 defsubr (&Sstring_to_multibyte
);
5178 defsubr (&Sstring_to_unibyte
);
5179 defsubr (&Scopy_alist
);
5180 defsubr (&Ssubstring
);
5181 defsubr (&Ssubstring_no_properties
);
5194 defsubr (&Snreverse
);
5195 defsubr (&Sreverse
);
5197 defsubr (&Splist_get
);
5199 defsubr (&Splist_put
);
5201 defsubr (&Slax_plist_get
);
5202 defsubr (&Slax_plist_put
);
5205 defsubr (&Sequal_including_properties
);
5206 defsubr (&Sfillarray
);
5207 defsubr (&Sclear_string
);
5211 defsubr (&Smapconcat
);
5212 defsubr (&Syes_or_no_p
);
5213 defsubr (&Sload_average
);
5214 defsubr (&Sfeaturep
);
5215 defsubr (&Srequire
);
5216 defsubr (&Sprovide
);
5217 defsubr (&Splist_member
);
5218 defsubr (&Swidget_put
);
5219 defsubr (&Swidget_get
);
5220 defsubr (&Swidget_apply
);
5221 defsubr (&Sbase64_encode_region
);
5222 defsubr (&Sbase64_decode_region
);
5223 defsubr (&Sbase64_encode_string
);
5224 defsubr (&Sbase64_decode_string
);
5226 defsubr (&Ssecure_hash
);
5227 defsubr (&Sbuffer_hash
);
5228 defsubr (&Slocale_info
);