1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2013 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 #include "character.h"
34 #include "intervals.h"
37 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
42 #endif /* HAVE_MENUS */
44 Lisp_Object Qstring_lessp
;
45 static Lisp_Object Qprovide
, Qrequire
;
46 static Lisp_Object Qyes_or_no_p_history
;
47 Lisp_Object Qcursor_in_echo_area
;
48 static Lisp_Object Qwidget_type
;
49 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
51 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
53 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool);
55 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
56 doc
: /* Return the argument unchanged. */)
62 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
63 doc
: /* Return a pseudo-random number.
64 All integers representable in Lisp, i.e. between `most-negative-fixnum'
65 and `most-positive-fixnum', inclusive, are equally likely.
67 With positive integer LIMIT, return random number in interval [0,LIMIT).
68 With argument t, set the random number seed from the current time and pid.
69 With a string argument, set the seed based on the string's contents.
70 Other values of LIMIT are ignored.
72 See Info node `(elisp)Random Numbers' for more details. */)
79 else if (STRINGP (limit
))
80 seed_random (SSDATA (limit
), SBYTES (limit
));
83 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
84 val
%= XFASTINT (limit
);
85 return make_number (val
);
88 /* Heuristic on how many iterations of a tight loop can be safely done
89 before it's time to do a QUIT. This must be a power of 2. */
90 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
92 /* Random data-structure functions. */
94 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
95 doc
: /* Return the length of vector, list or string SEQUENCE.
96 A byte-code function object is also allowed.
97 If the string contains multibyte characters, this is not necessarily
98 the number of bytes in the string; it is the number of characters.
99 To get the number of bytes, use `string-bytes'. */)
100 (register Lisp_Object sequence
)
102 register Lisp_Object val
;
104 if (STRINGP (sequence
))
105 XSETFASTINT (val
, SCHARS (sequence
));
106 else if (VECTORP (sequence
))
107 XSETFASTINT (val
, ASIZE (sequence
));
108 else if (CHAR_TABLE_P (sequence
))
109 XSETFASTINT (val
, MAX_CHAR
);
110 else if (BOOL_VECTOR_P (sequence
))
111 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
112 else if (COMPILEDP (sequence
))
113 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
114 else if (CONSP (sequence
))
121 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
123 if (MOST_POSITIVE_FIXNUM
< i
)
124 error ("List too long");
127 sequence
= XCDR (sequence
);
129 while (CONSP (sequence
));
131 CHECK_LIST_END (sequence
, sequence
);
133 val
= make_number (i
);
135 else if (NILP (sequence
))
136 XSETFASTINT (val
, 0);
138 wrong_type_argument (Qsequencep
, sequence
);
143 /* This does not check for quits. That is safe since it must terminate. */
145 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
146 doc
: /* Return the length of a list, but avoid error or infinite loop.
147 This function never gets an error. If LIST is not really a list,
148 it returns 0. If LIST is circular, it returns a finite value
149 which is at least the number of distinct elements. */)
152 Lisp_Object tail
, halftail
;
157 return make_number (0);
159 /* halftail is used to detect circular lists. */
160 for (tail
= halftail
= list
; ; )
165 if (EQ (tail
, halftail
))
168 if ((lolen
& 1) == 0)
170 halftail
= XCDR (halftail
);
171 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
175 hilen
+= UINTMAX_MAX
+ 1.0;
180 /* If the length does not fit into a fixnum, return a float.
181 On all known practical machines this returns an upper bound on
183 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
186 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
187 doc
: /* Return the number of bytes in STRING.
188 If STRING is multibyte, this may be greater than the length of STRING. */)
191 CHECK_STRING (string
);
192 return make_number (SBYTES (string
));
195 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
196 doc
: /* Return t if two strings have identical contents.
197 Case is significant, but text properties are ignored.
198 Symbols are also allowed; their print names are used instead. */)
199 (register Lisp_Object s1
, Lisp_Object s2
)
202 s1
= SYMBOL_NAME (s1
);
204 s2
= SYMBOL_NAME (s2
);
208 if (SCHARS (s1
) != SCHARS (s2
)
209 || SBYTES (s1
) != SBYTES (s2
)
210 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
215 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
216 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
217 The arguments START1, END1, START2, and END2, if non-nil, are
218 positions specifying which parts of STR1 or STR2 to compare. In
219 string STR1, compare the part between START1 (inclusive) and END1
220 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
221 the string; if END1 is nil, it defaults to the length of the string.
222 Likewise, in string STR2, compare the part between START2 and END2.
224 The strings are compared by the numeric values of their characters.
225 For instance, STR1 is "less than" STR2 if its first differing
226 character has a smaller numeric value. If IGNORE-CASE is non-nil,
227 characters are converted to lower-case before comparing them. Unibyte
228 strings are converted to multibyte for comparison.
230 The value is t if the strings (or specified portions) match.
231 If string STR1 is less, the value is a negative number N;
232 - 1 - N is the number of characters that match at the beginning.
233 If string STR1 is greater, the value is a positive number N;
234 N - 1 is the number of characters that match at the beginning. */)
235 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
237 register ptrdiff_t end1_char
, end2_char
;
238 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
243 start1
= make_number (0);
245 start2
= make_number (0);
246 CHECK_NATNUM (start1
);
247 CHECK_NATNUM (start2
);
253 end1_char
= SCHARS (str1
);
254 if (! NILP (end1
) && end1_char
> XINT (end1
))
255 end1_char
= XINT (end1
);
256 if (end1_char
< XINT (start1
))
257 args_out_of_range (str1
, start1
);
259 end2_char
= SCHARS (str2
);
260 if (! NILP (end2
) && end2_char
> XINT (end2
))
261 end2_char
= XINT (end2
);
262 if (end2_char
< XINT (start2
))
263 args_out_of_range (str2
, start2
);
268 i1_byte
= string_char_to_byte (str1
, i1
);
269 i2_byte
= string_char_to_byte (str2
, i2
);
271 while (i1
< end1_char
&& i2
< end2_char
)
273 /* When we find a mismatch, we must compare the
274 characters, not just the bytes. */
277 if (STRING_MULTIBYTE (str1
))
278 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
281 c1
= SREF (str1
, i1
++);
282 MAKE_CHAR_MULTIBYTE (c1
);
285 if (STRING_MULTIBYTE (str2
))
286 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
289 c2
= SREF (str2
, i2
++);
290 MAKE_CHAR_MULTIBYTE (c2
);
296 if (! NILP (ignore_case
))
300 tem
= Fupcase (make_number (c1
));
302 tem
= Fupcase (make_number (c2
));
309 /* Note that I1 has already been incremented
310 past the character that we are comparing;
311 hence we don't add or subtract 1 here. */
313 return make_number (- i1
+ XINT (start1
));
315 return make_number (i1
- XINT (start1
));
319 return make_number (i1
- XINT (start1
) + 1);
321 return make_number (- i1
+ XINT (start1
) - 1);
326 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
327 doc
: /* Return t if first arg string is less than second in lexicographic order.
329 Symbols are also allowed; their print names are used instead. */)
330 (register Lisp_Object s1
, Lisp_Object s2
)
332 register ptrdiff_t end
;
333 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
336 s1
= SYMBOL_NAME (s1
);
338 s2
= SYMBOL_NAME (s2
);
342 i1
= i1_byte
= i2
= i2_byte
= 0;
345 if (end
> SCHARS (s2
))
350 /* When we find a mismatch, we must compare the
351 characters, not just the bytes. */
354 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
355 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
358 return c1
< c2
? Qt
: Qnil
;
360 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
363 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
364 enum Lisp_Type target_type
, bool last_special
);
368 concat2 (Lisp_Object s1
, Lisp_Object s2
)
373 return concat (2, args
, Lisp_String
, 0);
378 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
384 return concat (3, args
, Lisp_String
, 0);
387 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
388 doc
: /* Concatenate all the arguments and make the result a list.
389 The result is a list whose elements are the elements of all the arguments.
390 Each argument may be a list, vector or string.
391 The last argument is not copied, just used as the tail of the new list.
392 usage: (append &rest SEQUENCES) */)
393 (ptrdiff_t nargs
, Lisp_Object
*args
)
395 return concat (nargs
, args
, Lisp_Cons
, 1);
398 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
399 doc
: /* Concatenate all the arguments and make the result a string.
400 The result is a string whose elements are the elements of all the arguments.
401 Each argument may be a string or a list or vector of characters (integers).
402 usage: (concat &rest SEQUENCES) */)
403 (ptrdiff_t nargs
, Lisp_Object
*args
)
405 return concat (nargs
, args
, Lisp_String
, 0);
408 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
409 doc
: /* Concatenate all the arguments and make the result a vector.
410 The result is a vector whose elements are the elements of all the arguments.
411 Each argument may be a list, vector or string.
412 usage: (vconcat &rest SEQUENCES) */)
413 (ptrdiff_t nargs
, Lisp_Object
*args
)
415 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
419 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
420 doc
: /* Return a copy of a list, vector, string or char-table.
421 The elements of a list or vector are not copied; they are shared
422 with the original. */)
425 if (NILP (arg
)) return arg
;
427 if (CHAR_TABLE_P (arg
))
429 return copy_char_table (arg
);
432 if (BOOL_VECTOR_P (arg
))
435 ptrdiff_t size_in_chars
436 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
437 / BOOL_VECTOR_BITS_PER_CHAR
);
439 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
440 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
445 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
446 wrong_type_argument (Qsequencep
, arg
);
448 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
451 /* This structure holds information of an argument of `concat' that is
452 a string and has text properties to be copied. */
455 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
456 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
457 ptrdiff_t to
; /* refer to VAL (the target string) */
461 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
462 enum Lisp_Type target_type
, bool last_special
)
468 ptrdiff_t toindex_byte
= 0;
469 EMACS_INT result_len
;
470 EMACS_INT result_len_byte
;
472 Lisp_Object last_tail
;
475 /* When we make a multibyte string, we can't copy text properties
476 while concatenating each string because the length of resulting
477 string can't be decided until we finish the whole concatenation.
478 So, we record strings that have text properties to be copied
479 here, and copy the text properties after the concatenation. */
480 struct textprop_rec
*textprops
= NULL
;
481 /* Number of elements in textprops. */
482 ptrdiff_t num_textprops
= 0;
487 /* In append, the last arg isn't treated like the others */
488 if (last_special
&& nargs
> 0)
491 last_tail
= args
[nargs
];
496 /* Check each argument. */
497 for (argnum
= 0; argnum
< nargs
; argnum
++)
500 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
501 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
502 wrong_type_argument (Qsequencep
, this);
505 /* Compute total length in chars of arguments in RESULT_LEN.
506 If desired output is a string, also compute length in bytes
507 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
508 whether the result should be a multibyte string. */
512 for (argnum
= 0; argnum
< nargs
; argnum
++)
516 len
= XFASTINT (Flength (this));
517 if (target_type
== Lisp_String
)
519 /* We must count the number of bytes needed in the string
520 as well as the number of characters. */
524 ptrdiff_t this_len_byte
;
526 if (VECTORP (this) || COMPILEDP (this))
527 for (i
= 0; i
< len
; i
++)
530 CHECK_CHARACTER (ch
);
532 this_len_byte
= CHAR_BYTES (c
);
533 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
535 result_len_byte
+= this_len_byte
;
536 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
539 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
540 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
541 else if (CONSP (this))
542 for (; CONSP (this); this = XCDR (this))
545 CHECK_CHARACTER (ch
);
547 this_len_byte
= CHAR_BYTES (c
);
548 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
550 result_len_byte
+= this_len_byte
;
551 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
554 else if (STRINGP (this))
556 if (STRING_MULTIBYTE (this))
559 this_len_byte
= SBYTES (this);
562 this_len_byte
= count_size_as_multibyte (SDATA (this),
564 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
566 result_len_byte
+= this_len_byte
;
571 if (MOST_POSITIVE_FIXNUM
< result_len
)
572 memory_full (SIZE_MAX
);
575 if (! some_multibyte
)
576 result_len_byte
= result_len
;
578 /* Create the output object. */
579 if (target_type
== Lisp_Cons
)
580 val
= Fmake_list (make_number (result_len
), Qnil
);
581 else if (target_type
== Lisp_Vectorlike
)
582 val
= Fmake_vector (make_number (result_len
), Qnil
);
583 else if (some_multibyte
)
584 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
586 val
= make_uninit_string (result_len
);
588 /* In `append', if all but last arg are nil, return last arg. */
589 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
592 /* Copy the contents of the args into the result. */
594 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
596 toindex
= 0, toindex_byte
= 0;
600 SAFE_NALLOCA (textprops
, 1, nargs
);
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
605 ptrdiff_t thisleni
= 0;
606 register ptrdiff_t thisindex
= 0;
607 register ptrdiff_t thisindex_byte
= 0;
611 thislen
= Flength (this), thisleni
= XINT (thislen
);
613 /* Between strings of the same kind, copy fast. */
614 if (STRINGP (this) && STRINGP (val
)
615 && STRING_MULTIBYTE (this) == some_multibyte
)
617 ptrdiff_t thislen_byte
= SBYTES (this);
619 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
620 if (string_intervals (this))
622 textprops
[num_textprops
].argnum
= argnum
;
623 textprops
[num_textprops
].from
= 0;
624 textprops
[num_textprops
++].to
= toindex
;
626 toindex_byte
+= thislen_byte
;
629 /* Copy a single-byte string to a multibyte string. */
630 else if (STRINGP (this) && STRINGP (val
))
632 if (string_intervals (this))
634 textprops
[num_textprops
].argnum
= argnum
;
635 textprops
[num_textprops
].from
= 0;
636 textprops
[num_textprops
++].to
= toindex
;
638 toindex_byte
+= copy_text (SDATA (this),
639 SDATA (val
) + toindex_byte
,
640 SCHARS (this), 0, 1);
644 /* Copy element by element. */
647 register Lisp_Object elt
;
649 /* Fetch next element of `this' arg into `elt', or break if
650 `this' is exhausted. */
651 if (NILP (this)) break;
653 elt
= XCAR (this), this = XCDR (this);
654 else if (thisindex
>= thisleni
)
656 else if (STRINGP (this))
659 if (STRING_MULTIBYTE (this))
660 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
665 c
= SREF (this, thisindex
); thisindex
++;
666 if (some_multibyte
&& !ASCII_CHAR_P (c
))
667 c
= BYTE8_TO_CHAR (c
);
669 XSETFASTINT (elt
, c
);
671 else if (BOOL_VECTOR_P (this))
674 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
675 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
683 elt
= AREF (this, thisindex
);
687 /* Store this element into the result. */
694 else if (VECTORP (val
))
696 ASET (val
, toindex
, elt
);
702 CHECK_CHARACTER (elt
);
705 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
707 SSET (val
, toindex_byte
++, c
);
713 XSETCDR (prev
, last_tail
);
715 if (num_textprops
> 0)
718 ptrdiff_t last_to_end
= -1;
720 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
722 this = args
[textprops
[argnum
].argnum
];
723 props
= text_property_list (this,
725 make_number (SCHARS (this)),
727 /* If successive arguments have properties, be sure that the
728 value of `composition' property be the copy. */
729 if (last_to_end
== textprops
[argnum
].to
)
730 make_composition_value_copy (props
);
731 add_text_properties_from_list (val
, props
,
732 make_number (textprops
[argnum
].to
));
733 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
741 static Lisp_Object string_char_byte_cache_string
;
742 static ptrdiff_t string_char_byte_cache_charpos
;
743 static ptrdiff_t string_char_byte_cache_bytepos
;
746 clear_string_char_byte_cache (void)
748 string_char_byte_cache_string
= Qnil
;
751 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
754 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
757 ptrdiff_t best_below
, best_below_byte
;
758 ptrdiff_t best_above
, best_above_byte
;
760 best_below
= best_below_byte
= 0;
761 best_above
= SCHARS (string
);
762 best_above_byte
= SBYTES (string
);
763 if (best_above
== best_above_byte
)
766 if (EQ (string
, string_char_byte_cache_string
))
768 if (string_char_byte_cache_charpos
< char_index
)
770 best_below
= string_char_byte_cache_charpos
;
771 best_below_byte
= string_char_byte_cache_bytepos
;
775 best_above
= string_char_byte_cache_charpos
;
776 best_above_byte
= string_char_byte_cache_bytepos
;
780 if (char_index
- best_below
< best_above
- char_index
)
782 unsigned char *p
= SDATA (string
) + best_below_byte
;
784 while (best_below
< char_index
)
786 p
+= BYTES_BY_CHAR_HEAD (*p
);
789 i_byte
= p
- SDATA (string
);
793 unsigned char *p
= SDATA (string
) + best_above_byte
;
795 while (best_above
> char_index
)
798 while (!CHAR_HEAD_P (*p
)) p
--;
801 i_byte
= p
- SDATA (string
);
804 string_char_byte_cache_bytepos
= i_byte
;
805 string_char_byte_cache_charpos
= char_index
;
806 string_char_byte_cache_string
= string
;
811 /* Return the character index corresponding to BYTE_INDEX in STRING. */
814 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
817 ptrdiff_t best_below
, best_below_byte
;
818 ptrdiff_t best_above
, best_above_byte
;
820 best_below
= best_below_byte
= 0;
821 best_above
= SCHARS (string
);
822 best_above_byte
= SBYTES (string
);
823 if (best_above
== best_above_byte
)
826 if (EQ (string
, string_char_byte_cache_string
))
828 if (string_char_byte_cache_bytepos
< byte_index
)
830 best_below
= string_char_byte_cache_charpos
;
831 best_below_byte
= string_char_byte_cache_bytepos
;
835 best_above
= string_char_byte_cache_charpos
;
836 best_above_byte
= string_char_byte_cache_bytepos
;
840 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
842 unsigned char *p
= SDATA (string
) + best_below_byte
;
843 unsigned char *pend
= SDATA (string
) + byte_index
;
847 p
+= BYTES_BY_CHAR_HEAD (*p
);
851 i_byte
= p
- SDATA (string
);
855 unsigned char *p
= SDATA (string
) + best_above_byte
;
856 unsigned char *pbeg
= SDATA (string
) + byte_index
;
861 while (!CHAR_HEAD_P (*p
)) p
--;
865 i_byte
= p
- SDATA (string
);
868 string_char_byte_cache_bytepos
= i_byte
;
869 string_char_byte_cache_charpos
= i
;
870 string_char_byte_cache_string
= string
;
875 /* Convert STRING to a multibyte string. */
878 string_make_multibyte (Lisp_Object string
)
885 if (STRING_MULTIBYTE (string
))
888 nbytes
= count_size_as_multibyte (SDATA (string
),
890 /* If all the chars are ASCII, they won't need any more bytes
891 once converted. In that case, we can return STRING itself. */
892 if (nbytes
== SBYTES (string
))
895 buf
= SAFE_ALLOCA (nbytes
);
896 copy_text (SDATA (string
), buf
, SBYTES (string
),
899 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
906 /* Convert STRING (if unibyte) to a multibyte string without changing
907 the number of characters. Characters 0200 trough 0237 are
908 converted to eight-bit characters. */
911 string_to_multibyte (Lisp_Object string
)
918 if (STRING_MULTIBYTE (string
))
921 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
922 /* If all the chars are ASCII, they won't need any more bytes once
924 if (nbytes
== SBYTES (string
))
925 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
927 buf
= SAFE_ALLOCA (nbytes
);
928 memcpy (buf
, SDATA (string
), SBYTES (string
));
929 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
931 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
938 /* Convert STRING to a single-byte string. */
941 string_make_unibyte (Lisp_Object string
)
948 if (! STRING_MULTIBYTE (string
))
951 nchars
= SCHARS (string
);
953 buf
= SAFE_ALLOCA (nchars
);
954 copy_text (SDATA (string
), buf
, SBYTES (string
),
957 ret
= make_unibyte_string ((char *) buf
, nchars
);
963 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
965 doc
: /* Return the multibyte equivalent of STRING.
966 If STRING is unibyte and contains non-ASCII characters, the function
967 `unibyte-char-to-multibyte' is used to convert each unibyte character
968 to a multibyte character. In this case, the returned string is a
969 newly created string with no text properties. If STRING is multibyte
970 or entirely ASCII, it is returned unchanged. In particular, when
971 STRING is unibyte and entirely ASCII, the returned string is unibyte.
972 \(When the characters are all ASCII, Emacs primitives will treat the
973 string the same way whether it is unibyte or multibyte.) */)
976 CHECK_STRING (string
);
978 return string_make_multibyte (string
);
981 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
983 doc
: /* Return the unibyte equivalent of STRING.
984 Multibyte character codes are converted to unibyte according to
985 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
986 If the lookup in the translation table fails, this function takes just
987 the low 8 bits of each character. */)
990 CHECK_STRING (string
);
992 return string_make_unibyte (string
);
995 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
997 doc
: /* Return a unibyte string with the same individual bytes as STRING.
998 If STRING is unibyte, the result is STRING itself.
999 Otherwise it is a newly created string, with no text properties.
1000 If STRING is multibyte and contains a character of charset
1001 `eight-bit', it is converted to the corresponding single byte. */)
1002 (Lisp_Object string
)
1004 CHECK_STRING (string
);
1006 if (STRING_MULTIBYTE (string
))
1008 ptrdiff_t bytes
= SBYTES (string
);
1009 unsigned char *str
= xmalloc (bytes
);
1011 memcpy (str
, SDATA (string
), bytes
);
1012 bytes
= str_as_unibyte (str
, bytes
);
1013 string
= make_unibyte_string ((char *) str
, bytes
);
1019 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1021 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1022 If STRING is multibyte, the result is STRING itself.
1023 Otherwise it is a newly created string, with no text properties.
1025 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1026 part of a correct utf-8 sequence), it is converted to the corresponding
1027 multibyte character of charset `eight-bit'.
1028 See also `string-to-multibyte'.
1030 Beware, this often doesn't really do what you think it does.
1031 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1032 If you're not sure, whether to use `string-as-multibyte' or
1033 `string-to-multibyte', use `string-to-multibyte'. */)
1034 (Lisp_Object string
)
1036 CHECK_STRING (string
);
1038 if (! STRING_MULTIBYTE (string
))
1040 Lisp_Object new_string
;
1041 ptrdiff_t nchars
, nbytes
;
1043 parse_str_as_multibyte (SDATA (string
),
1046 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1047 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1048 if (nbytes
!= SBYTES (string
))
1049 str_as_multibyte (SDATA (new_string
), nbytes
,
1050 SBYTES (string
), NULL
);
1051 string
= new_string
;
1052 set_string_intervals (string
, NULL
);
1057 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1059 doc
: /* Return a multibyte string with the same individual chars as STRING.
1060 If STRING is multibyte, the result is STRING itself.
1061 Otherwise it is a newly created string, with no text properties.
1063 If STRING is unibyte and contains an 8-bit byte, it is converted to
1064 the corresponding multibyte character of charset `eight-bit'.
1066 This differs from `string-as-multibyte' by converting each byte of a correct
1067 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1068 correct sequence. */)
1069 (Lisp_Object string
)
1071 CHECK_STRING (string
);
1073 return string_to_multibyte (string
);
1076 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1078 doc
: /* Return a unibyte string with the same individual chars as STRING.
1079 If STRING is unibyte, the result is STRING itself.
1080 Otherwise it is a newly created string, with no text properties,
1081 where each `eight-bit' character is converted to the corresponding byte.
1082 If STRING contains a non-ASCII, non-`eight-bit' character,
1083 an error is signaled. */)
1084 (Lisp_Object string
)
1086 CHECK_STRING (string
);
1088 if (STRING_MULTIBYTE (string
))
1090 ptrdiff_t chars
= SCHARS (string
);
1091 unsigned char *str
= xmalloc (chars
);
1092 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1094 if (converted
< chars
)
1095 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1096 string
= make_unibyte_string ((char *) str
, chars
);
1103 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1104 doc
: /* Return a copy of ALIST.
1105 This is an alist which represents the same mapping from objects to objects,
1106 but does not share the alist structure with ALIST.
1107 The objects mapped (cars and cdrs of elements of the alist)
1108 are shared, however.
1109 Elements of ALIST that are not conses are also shared. */)
1112 register Lisp_Object tem
;
1117 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1118 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1120 register Lisp_Object car
;
1124 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1129 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1130 doc
: /* Return a new string whose contents are a substring of STRING.
1131 The returned string consists of the characters between index FROM
1132 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1133 zero-indexed: 0 means the first character of STRING. Negative values
1134 are counted from the end of STRING. If TO is nil, the substring runs
1135 to the end of STRING.
1137 The STRING argument may also be a vector. In that case, the return
1138 value is a new vector that contains the elements between index FROM
1139 \(inclusive) and index TO (exclusive) of that vector argument. */)
1140 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1144 EMACS_INT from_char
, to_char
;
1146 CHECK_VECTOR_OR_STRING (string
);
1147 CHECK_NUMBER (from
);
1149 if (STRINGP (string
))
1150 size
= SCHARS (string
);
1152 size
= ASIZE (string
);
1160 to_char
= XINT (to
);
1165 from_char
= XINT (from
);
1168 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1169 args_out_of_range_3 (string
, make_number (from_char
),
1170 make_number (to_char
));
1172 if (STRINGP (string
))
1175 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1176 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1177 res
= make_specified_string (SSDATA (string
) + from_byte
,
1178 to_char
- from_char
, to_byte
- from_byte
,
1179 STRING_MULTIBYTE (string
));
1180 copy_text_properties (make_number (from_char
), make_number (to_char
),
1181 string
, make_number (0), res
, Qnil
);
1184 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1190 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1191 doc
: /* Return a substring of STRING, without text properties.
1192 It starts at index FROM and ends before TO.
1193 TO may be nil or omitted; then the substring runs to the end of STRING.
1194 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1195 If FROM or TO is negative, it counts from the end.
1197 With one argument, just copy STRING without its properties. */)
1198 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1201 EMACS_INT from_char
, to_char
;
1202 ptrdiff_t from_byte
, to_byte
;
1204 CHECK_STRING (string
);
1206 size
= SCHARS (string
);
1212 CHECK_NUMBER (from
);
1213 from_char
= XINT (from
);
1223 to_char
= XINT (to
);
1228 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1229 args_out_of_range_3 (string
, make_number (from_char
),
1230 make_number (to_char
));
1232 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1234 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1235 return make_specified_string (SSDATA (string
) + from_byte
,
1236 to_char
- from_char
, to_byte
- from_byte
,
1237 STRING_MULTIBYTE (string
));
1240 /* Extract a substring of STRING, giving start and end positions
1241 both in characters and in bytes. */
1244 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1245 ptrdiff_t to
, ptrdiff_t to_byte
)
1250 CHECK_VECTOR_OR_STRING (string
);
1252 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1254 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1255 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1257 if (STRINGP (string
))
1259 res
= make_specified_string (SSDATA (string
) + from_byte
,
1260 to
- from
, to_byte
- from_byte
,
1261 STRING_MULTIBYTE (string
));
1262 copy_text_properties (make_number (from
), make_number (to
),
1263 string
, make_number (0), res
, Qnil
);
1266 res
= Fvector (to
- from
, aref_addr (string
, from
));
1271 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1272 doc
: /* Take cdr N times on LIST, return the result. */)
1273 (Lisp_Object n
, Lisp_Object list
)
1278 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1281 CHECK_LIST_CONS (list
, list
);
1287 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1288 doc
: /* Return the Nth element of LIST.
1289 N counts from zero. If LIST is not that long, nil is returned. */)
1290 (Lisp_Object n
, Lisp_Object list
)
1292 return Fcar (Fnthcdr (n
, list
));
1295 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1296 doc
: /* Return element of SEQUENCE at index N. */)
1297 (register Lisp_Object sequence
, Lisp_Object n
)
1300 if (CONSP (sequence
) || NILP (sequence
))
1301 return Fcar (Fnthcdr (n
, sequence
));
1303 /* Faref signals a "not array" error, so check here. */
1304 CHECK_ARRAY (sequence
, Qsequencep
);
1305 return Faref (sequence
, n
);
1308 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1309 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1310 The value is actually the tail of LIST whose car is ELT. */)
1311 (register Lisp_Object elt
, Lisp_Object list
)
1313 register Lisp_Object tail
;
1314 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1316 register Lisp_Object tem
;
1317 CHECK_LIST_CONS (tail
, list
);
1319 if (! NILP (Fequal (elt
, tem
)))
1326 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1327 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1328 The value is actually the tail of LIST whose car is ELT. */)
1329 (register Lisp_Object elt
, Lisp_Object list
)
1333 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1337 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1341 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1352 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1353 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1354 The value is actually the tail of LIST whose car is ELT. */)
1355 (register Lisp_Object elt
, Lisp_Object list
)
1357 register Lisp_Object tail
;
1360 return Fmemq (elt
, list
);
1362 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1364 register Lisp_Object tem
;
1365 CHECK_LIST_CONS (tail
, list
);
1367 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1374 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1375 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1376 The value is actually the first element of LIST whose car is KEY.
1377 Elements of LIST that are not conses are ignored. */)
1378 (Lisp_Object key
, Lisp_Object list
)
1383 || (CONSP (XCAR (list
))
1384 && EQ (XCAR (XCAR (list
)), key
)))
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1395 || (CONSP (XCAR (list
))
1396 && EQ (XCAR (XCAR (list
)), key
)))
1406 /* Like Fassq but never report an error and do not allow quits.
1407 Use only on lists known never to be circular. */
1410 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1413 && (!CONSP (XCAR (list
))
1414 || !EQ (XCAR (XCAR (list
)), key
)))
1417 return CAR_SAFE (list
);
1420 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1421 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1422 The value is actually the first element of LIST whose car equals KEY. */)
1423 (Lisp_Object key
, Lisp_Object list
)
1430 || (CONSP (XCAR (list
))
1431 && (car
= XCAR (XCAR (list
)),
1432 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1437 || (CONSP (XCAR (list
))
1438 && (car
= XCAR (XCAR (list
)),
1439 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1444 || (CONSP (XCAR (list
))
1445 && (car
= XCAR (XCAR (list
)),
1446 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1456 /* Like Fassoc but never report an error and do not allow quits.
1457 Use only on lists known never to be circular. */
1460 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1463 && (!CONSP (XCAR (list
))
1464 || (!EQ (XCAR (XCAR (list
)), key
)
1465 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1468 return CONSP (list
) ? XCAR (list
) : Qnil
;
1471 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1472 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1473 The value is actually the first element of LIST whose cdr is KEY. */)
1474 (register Lisp_Object key
, Lisp_Object list
)
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCDR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCDR (XCAR (list
)), key
)))
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCDR (XCAR (list
)), key
)))
1502 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1503 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1504 The value is actually the first element of LIST whose cdr equals KEY. */)
1505 (Lisp_Object key
, Lisp_Object list
)
1512 || (CONSP (XCAR (list
))
1513 && (cdr
= XCDR (XCAR (list
)),
1514 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1519 || (CONSP (XCAR (list
))
1520 && (cdr
= XCDR (XCAR (list
)),
1521 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1526 || (CONSP (XCAR (list
))
1527 && (cdr
= XCDR (XCAR (list
)),
1528 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1538 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1539 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1540 More precisely, this function skips any members `eq' to ELT at the
1541 front of LIST, then removes members `eq' to ELT from the remaining
1542 sublist by modifying its list structure, then returns the resulting
1545 Write `(setq foo (delq element foo))' to be sure of correctly changing
1546 the value of a list `foo'. */)
1547 (register Lisp_Object elt
, Lisp_Object list
)
1549 register Lisp_Object tail
, prev
;
1550 register Lisp_Object tem
;
1554 while (!NILP (tail
))
1556 CHECK_LIST_CONS (tail
, list
);
1563 Fsetcdr (prev
, XCDR (tail
));
1573 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1574 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1575 SEQ must be a sequence (i.e. a list, a vector, or a string).
1576 The return value is a sequence of the same type.
1578 If SEQ is a list, this behaves like `delq', except that it compares
1579 with `equal' instead of `eq'. In particular, it may remove elements
1580 by altering the list structure.
1582 If SEQ is not a list, deletion is never performed destructively;
1583 instead this function creates and returns a new vector or string.
1585 Write `(setq foo (delete element foo))' to be sure of correctly
1586 changing the value of a sequence `foo'. */)
1587 (Lisp_Object elt
, Lisp_Object seq
)
1593 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1594 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1597 if (n
!= ASIZE (seq
))
1599 struct Lisp_Vector
*p
= allocate_vector (n
);
1601 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1602 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1603 p
->contents
[n
++] = AREF (seq
, i
);
1605 XSETVECTOR (seq
, p
);
1608 else if (STRINGP (seq
))
1610 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1613 for (i
= nchars
= nbytes
= ibyte
= 0;
1615 ++i
, ibyte
+= cbytes
)
1617 if (STRING_MULTIBYTE (seq
))
1619 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1620 cbytes
= CHAR_BYTES (c
);
1628 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1635 if (nchars
!= SCHARS (seq
))
1639 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1640 if (!STRING_MULTIBYTE (seq
))
1641 STRING_SET_UNIBYTE (tem
);
1643 for (i
= nchars
= nbytes
= ibyte
= 0;
1645 ++i
, ibyte
+= cbytes
)
1647 if (STRING_MULTIBYTE (seq
))
1649 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1650 cbytes
= CHAR_BYTES (c
);
1658 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1660 unsigned char *from
= SDATA (seq
) + ibyte
;
1661 unsigned char *to
= SDATA (tem
) + nbytes
;
1667 for (n
= cbytes
; n
--; )
1677 Lisp_Object tail
, prev
;
1679 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1681 CHECK_LIST_CONS (tail
, seq
);
1683 if (!NILP (Fequal (elt
, XCAR (tail
))))
1688 Fsetcdr (prev
, XCDR (tail
));
1699 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1700 doc
: /* Reverse LIST by modifying cdr pointers.
1701 Return the reversed list. Expects a properly nil-terminated list. */)
1704 register Lisp_Object prev
, tail
, next
;
1706 if (NILP (list
)) return list
;
1709 while (!NILP (tail
))
1712 CHECK_LIST_CONS (tail
, tail
);
1714 Fsetcdr (tail
, prev
);
1721 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1722 doc
: /* Reverse LIST, copying. Return the reversed list.
1723 See also the function `nreverse', which is used more often. */)
1728 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1731 new = Fcons (XCAR (list
), new);
1733 CHECK_LIST_END (list
, list
);
1737 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1739 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1740 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1741 Returns the sorted list. LIST is modified by side effects.
1742 PREDICATE is called with two elements of LIST, and should return non-nil
1743 if the first element should sort before the second. */)
1744 (Lisp_Object list
, Lisp_Object predicate
)
1746 Lisp_Object front
, back
;
1747 register Lisp_Object len
, tem
;
1748 struct gcpro gcpro1
, gcpro2
;
1752 len
= Flength (list
);
1753 length
= XINT (len
);
1757 XSETINT (len
, (length
/ 2) - 1);
1758 tem
= Fnthcdr (len
, list
);
1760 Fsetcdr (tem
, Qnil
);
1762 GCPRO2 (front
, back
);
1763 front
= Fsort (front
, predicate
);
1764 back
= Fsort (back
, predicate
);
1766 return merge (front
, back
, predicate
);
1770 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1773 register Lisp_Object tail
;
1775 register Lisp_Object l1
, l2
;
1776 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1783 /* It is sufficient to protect org_l1 and org_l2.
1784 When l1 and l2 are updated, we copy the new values
1785 back into the org_ vars. */
1786 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1806 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1822 Fsetcdr (tail
, tem
);
1828 /* This does not check for quits. That is safe since it must terminate. */
1830 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1831 doc
: /* Extract a value from a property list.
1832 PLIST is a property list, which is a list of the form
1833 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1834 corresponding to the given PROP, or nil if PROP is not one of the
1835 properties on the list. This function never signals an error. */)
1836 (Lisp_Object plist
, Lisp_Object prop
)
1838 Lisp_Object tail
, halftail
;
1840 /* halftail is used to detect circular lists. */
1841 tail
= halftail
= plist
;
1842 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1844 if (EQ (prop
, XCAR (tail
)))
1845 return XCAR (XCDR (tail
));
1847 tail
= XCDR (XCDR (tail
));
1848 halftail
= XCDR (halftail
);
1849 if (EQ (tail
, halftail
))
1856 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1857 doc
: /* Return the value of SYMBOL's PROPNAME property.
1858 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1859 (Lisp_Object symbol
, Lisp_Object propname
)
1861 CHECK_SYMBOL (symbol
);
1862 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1865 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1866 doc
: /* Change value in PLIST of PROP to VAL.
1867 PLIST is a property list, which is a list of the form
1868 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1869 If PROP is already a property on the list, its value is set to VAL,
1870 otherwise the new PROP VAL pair is added. The new plist is returned;
1871 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1872 The PLIST is modified by side effects. */)
1873 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1875 register Lisp_Object tail
, prev
;
1876 Lisp_Object newcell
;
1878 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1879 tail
= XCDR (XCDR (tail
)))
1881 if (EQ (prop
, XCAR (tail
)))
1883 Fsetcar (XCDR (tail
), val
);
1890 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1894 Fsetcdr (XCDR (prev
), newcell
);
1898 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1899 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1900 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1901 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1903 CHECK_SYMBOL (symbol
);
1905 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1909 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1910 doc
: /* Extract a value from a property list, comparing with `equal'.
1911 PLIST is a property list, which is a list of the form
1912 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1913 corresponding to the given PROP, or nil if PROP is not
1914 one of the properties on the list. */)
1915 (Lisp_Object plist
, Lisp_Object prop
)
1920 CONSP (tail
) && CONSP (XCDR (tail
));
1921 tail
= XCDR (XCDR (tail
)))
1923 if (! NILP (Fequal (prop
, XCAR (tail
))))
1924 return XCAR (XCDR (tail
));
1929 CHECK_LIST_END (tail
, prop
);
1934 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1935 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1936 PLIST is a property list, which is a list of the form
1937 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1938 If PROP is already a property on the list, its value is set to VAL,
1939 otherwise the new PROP VAL pair is added. The new plist is returned;
1940 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1941 The PLIST is modified by side effects. */)
1942 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1944 register Lisp_Object tail
, prev
;
1945 Lisp_Object newcell
;
1947 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1948 tail
= XCDR (XCDR (tail
)))
1950 if (! NILP (Fequal (prop
, XCAR (tail
))))
1952 Fsetcar (XCDR (tail
), val
);
1959 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1963 Fsetcdr (XCDR (prev
), newcell
);
1967 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1968 doc
: /* Return t if the two args are the same Lisp object.
1969 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1970 (Lisp_Object obj1
, Lisp_Object obj2
)
1973 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1975 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1978 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1979 doc
: /* Return t if two Lisp objects have similar structure and contents.
1980 They must have the same data type.
1981 Conses are compared by comparing the cars and the cdrs.
1982 Vectors and strings are compared element by element.
1983 Numbers are compared by value, but integers cannot equal floats.
1984 (Use `=' if you want integers and floats to be able to be equal.)
1985 Symbols must match exactly. */)
1986 (register Lisp_Object o1
, Lisp_Object o2
)
1988 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1991 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1992 doc
: /* Return t if two Lisp objects have similar structure and contents.
1993 This is like `equal' except that it compares the text properties
1994 of strings. (`equal' ignores text properties.) */)
1995 (register Lisp_Object o1
, Lisp_Object o2
)
1997 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2000 /* DEPTH is current depth of recursion. Signal an error if it
2002 PROPS means compare string text properties too. */
2005 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
)
2008 error ("Stack overflow in equal");
2014 if (XTYPE (o1
) != XTYPE (o2
))
2023 d1
= extract_float (o1
);
2024 d2
= extract_float (o2
);
2025 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2026 though they are not =. */
2027 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2031 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2038 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2042 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2044 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2047 o1
= XOVERLAY (o1
)->plist
;
2048 o2
= XOVERLAY (o2
)->plist
;
2053 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2054 && (XMARKER (o1
)->buffer
== 0
2055 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2059 case Lisp_Vectorlike
:
2062 ptrdiff_t size
= ASIZE (o1
);
2063 /* Pseudovectors have the type encoded in the size field, so this test
2064 actually checks that the objects have the same type as well as the
2066 if (ASIZE (o2
) != size
)
2068 /* Boolvectors are compared much like strings. */
2069 if (BOOL_VECTOR_P (o1
))
2071 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2073 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2074 ((XBOOL_VECTOR (o1
)->size
2075 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2076 / BOOL_VECTOR_BITS_PER_CHAR
)))
2080 if (WINDOW_CONFIGURATIONP (o1
))
2081 return compare_window_configurations (o1
, o2
, 0);
2083 /* Aside from them, only true vectors, char-tables, compiled
2084 functions, and fonts (font-spec, font-entity, font-object)
2085 are sensible to compare, so eliminate the others now. */
2086 if (size
& PSEUDOVECTOR_FLAG
)
2088 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2091 size
&= PSEUDOVECTOR_SIZE_MASK
;
2093 for (i
= 0; i
< size
; i
++)
2098 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2106 if (SCHARS (o1
) != SCHARS (o2
))
2108 if (SBYTES (o1
) != SBYTES (o2
))
2110 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2112 if (props
&& !compare_string_intervals (o1
, o2
))
2124 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2125 doc
: /* Store each element of ARRAY with ITEM.
2126 ARRAY is a vector, string, char-table, or bool-vector. */)
2127 (Lisp_Object array
, Lisp_Object item
)
2129 register ptrdiff_t size
, idx
;
2131 if (VECTORP (array
))
2132 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2133 ASET (array
, idx
, item
);
2134 else if (CHAR_TABLE_P (array
))
2138 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2139 set_char_table_contents (array
, i
, item
);
2140 set_char_table_defalt (array
, item
);
2142 else if (STRINGP (array
))
2144 register unsigned char *p
= SDATA (array
);
2146 CHECK_CHARACTER (item
);
2147 charval
= XFASTINT (item
);
2148 size
= SCHARS (array
);
2149 if (STRING_MULTIBYTE (array
))
2151 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2152 int len
= CHAR_STRING (charval
, str
);
2153 ptrdiff_t size_byte
= SBYTES (array
);
2155 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2156 || SCHARS (array
) * len
!= size_byte
)
2157 error ("Attempt to change byte length of a string");
2158 for (idx
= 0; idx
< size_byte
; idx
++)
2159 *p
++ = str
[idx
% len
];
2162 for (idx
= 0; idx
< size
; idx
++)
2165 else if (BOOL_VECTOR_P (array
))
2167 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2169 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2170 / BOOL_VECTOR_BITS_PER_CHAR
);
2174 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2176 /* Clear any extraneous bits in the last byte. */
2177 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2181 wrong_type_argument (Qarrayp
, array
);
2185 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2187 doc
: /* Clear the contents of STRING.
2188 This makes STRING unibyte and may change its length. */)
2189 (Lisp_Object string
)
2192 CHECK_STRING (string
);
2193 len
= SBYTES (string
);
2194 memset (SDATA (string
), 0, len
);
2195 STRING_SET_CHARS (string
, len
);
2196 STRING_SET_UNIBYTE (string
);
2202 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2204 Lisp_Object args
[2];
2207 return Fnconc (2, args
);
2210 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2211 doc
: /* Concatenate any number of lists by altering them.
2212 Only the last argument is not altered, and need not be a list.
2213 usage: (nconc &rest LISTS) */)
2214 (ptrdiff_t nargs
, Lisp_Object
*args
)
2217 register Lisp_Object tail
, tem
, val
;
2221 for (argnum
= 0; argnum
< nargs
; argnum
++)
2224 if (NILP (tem
)) continue;
2229 if (argnum
+ 1 == nargs
) break;
2231 CHECK_LIST_CONS (tem
, tem
);
2240 tem
= args
[argnum
+ 1];
2241 Fsetcdr (tail
, tem
);
2243 args
[argnum
+ 1] = tail
;
2249 /* This is the guts of all mapping functions.
2250 Apply FN to each element of SEQ, one by one,
2251 storing the results into elements of VALS, a C vector of Lisp_Objects.
2252 LENI is the length of VALS, which should also be the length of SEQ. */
2255 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2257 register Lisp_Object tail
;
2259 register EMACS_INT i
;
2260 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2264 /* Don't let vals contain any garbage when GC happens. */
2265 for (i
= 0; i
< leni
; i
++)
2268 GCPRO3 (dummy
, fn
, seq
);
2270 gcpro1
.nvars
= leni
;
2274 /* We need not explicitly protect `tail' because it is used only on lists, and
2275 1) lists are not relocated and 2) the list is marked via `seq' so will not
2278 if (VECTORP (seq
) || COMPILEDP (seq
))
2280 for (i
= 0; i
< leni
; i
++)
2282 dummy
= call1 (fn
, AREF (seq
, i
));
2287 else if (BOOL_VECTOR_P (seq
))
2289 for (i
= 0; i
< leni
; i
++)
2292 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2293 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2294 dummy
= call1 (fn
, dummy
);
2299 else if (STRINGP (seq
))
2303 for (i
= 0, i_byte
= 0; i
< leni
;)
2306 ptrdiff_t i_before
= i
;
2308 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2309 XSETFASTINT (dummy
, c
);
2310 dummy
= call1 (fn
, dummy
);
2312 vals
[i_before
] = dummy
;
2315 else /* Must be a list, since Flength did not get an error */
2318 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2320 dummy
= call1 (fn
, XCAR (tail
));
2330 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2331 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2332 In between each pair of results, stick in SEPARATOR. Thus, " " as
2333 SEPARATOR results in spaces between the values returned by FUNCTION.
2334 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2335 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2338 register EMACS_INT leni
;
2341 register Lisp_Object
*args
;
2342 struct gcpro gcpro1
;
2346 len
= Flength (sequence
);
2347 if (CHAR_TABLE_P (sequence
))
2348 wrong_type_argument (Qlistp
, sequence
);
2350 nargs
= leni
+ leni
- 1;
2351 if (nargs
< 0) return empty_unibyte_string
;
2353 SAFE_ALLOCA_LISP (args
, nargs
);
2356 mapcar1 (leni
, args
, function
, sequence
);
2359 for (i
= leni
- 1; i
> 0; i
--)
2360 args
[i
+ i
] = args
[i
];
2362 for (i
= 1; i
< nargs
; i
+= 2)
2363 args
[i
] = separator
;
2365 ret
= Fconcat (nargs
, args
);
2371 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2372 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2373 The result is a list just as long as SEQUENCE.
2374 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2375 (Lisp_Object function
, Lisp_Object sequence
)
2377 register Lisp_Object len
;
2378 register EMACS_INT leni
;
2379 register Lisp_Object
*args
;
2383 len
= Flength (sequence
);
2384 if (CHAR_TABLE_P (sequence
))
2385 wrong_type_argument (Qlistp
, sequence
);
2386 leni
= XFASTINT (len
);
2388 SAFE_ALLOCA_LISP (args
, leni
);
2390 mapcar1 (leni
, args
, function
, sequence
);
2392 ret
= Flist (leni
, args
);
2398 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2399 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2400 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2401 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2402 (Lisp_Object function
, Lisp_Object sequence
)
2404 register EMACS_INT leni
;
2406 leni
= XFASTINT (Flength (sequence
));
2407 if (CHAR_TABLE_P (sequence
))
2408 wrong_type_argument (Qlistp
, sequence
);
2409 mapcar1 (leni
, 0, function
, sequence
);
2414 /* This is how C code calls `yes-or-no-p' and allows the user
2417 Anything that calls this function must protect from GC! */
2420 do_yes_or_no_p (Lisp_Object prompt
)
2422 return call1 (intern ("yes-or-no-p"), prompt
);
2425 /* Anything that calls this function must protect from GC! */
2427 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2428 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2429 PROMPT is the string to display to ask the question. It should end in
2430 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2432 The user must confirm the answer with RET, and can edit it until it
2435 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2436 is nil, and `use-dialog-box' is non-nil. */)
2437 (Lisp_Object prompt
)
2439 register Lisp_Object ans
;
2440 Lisp_Object args
[2];
2441 struct gcpro gcpro1
;
2443 CHECK_STRING (prompt
);
2446 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2447 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2451 Lisp_Object pane
, menu
, obj
;
2452 redisplay_preserve_echo_area (4);
2453 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2454 Fcons (Fcons (build_string ("No"), Qnil
),
2457 menu
= Fcons (prompt
, pane
);
2458 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2462 #endif /* HAVE_MENUS */
2465 args
[1] = build_string ("(yes or no) ");
2466 prompt
= Fconcat (2, args
);
2472 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2473 Qyes_or_no_p_history
, Qnil
,
2475 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2480 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2488 message ("Please answer yes or no.");
2489 Fsleep_for (make_number (2), Qnil
);
2493 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2494 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2496 Each of the three load averages is multiplied by 100, then converted
2499 When USE-FLOATS is non-nil, floats will be used instead of integers.
2500 These floats are not multiplied by 100.
2502 If the 5-minute or 15-minute load averages are not available, return a
2503 shortened list, containing only those averages which are available.
2505 An error is thrown if the load average can't be obtained. In some
2506 cases making it work would require Emacs being installed setuid or
2507 setgid so that it can read kernel information, and that usually isn't
2509 (Lisp_Object use_floats
)
2512 int loads
= getloadavg (load_ave
, 3);
2513 Lisp_Object ret
= Qnil
;
2516 error ("load-average not implemented for this operating system");
2520 Lisp_Object load
= (NILP (use_floats
)
2521 ? make_number (100.0 * load_ave
[loads
])
2522 : make_float (load_ave
[loads
]));
2523 ret
= Fcons (load
, ret
);
2529 static Lisp_Object Qsubfeatures
;
2531 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2532 doc
: /* Return t if FEATURE is present in this Emacs.
2534 Use this to conditionalize execution of lisp code based on the
2535 presence or absence of Emacs or environment extensions.
2536 Use `provide' to declare that a feature is available. This function
2537 looks at the value of the variable `features'. The optional argument
2538 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2539 (Lisp_Object feature
, Lisp_Object subfeature
)
2541 register Lisp_Object tem
;
2542 CHECK_SYMBOL (feature
);
2543 tem
= Fmemq (feature
, Vfeatures
);
2544 if (!NILP (tem
) && !NILP (subfeature
))
2545 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2546 return (NILP (tem
)) ? Qnil
: Qt
;
2549 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2550 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2551 The optional argument SUBFEATURES should be a list of symbols listing
2552 particular subfeatures supported in this version of FEATURE. */)
2553 (Lisp_Object feature
, Lisp_Object subfeatures
)
2555 register Lisp_Object tem
;
2556 CHECK_SYMBOL (feature
);
2557 CHECK_LIST (subfeatures
);
2558 if (!NILP (Vautoload_queue
))
2559 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2561 tem
= Fmemq (feature
, Vfeatures
);
2563 Vfeatures
= Fcons (feature
, Vfeatures
);
2564 if (!NILP (subfeatures
))
2565 Fput (feature
, Qsubfeatures
, subfeatures
);
2566 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2568 /* Run any load-hooks for this file. */
2569 tem
= Fassq (feature
, Vafter_load_alist
);
2571 Fprogn (XCDR (tem
));
2576 /* `require' and its subroutines. */
2578 /* List of features currently being require'd, innermost first. */
2580 static Lisp_Object require_nesting_list
;
2583 require_unwind (Lisp_Object old_value
)
2585 return require_nesting_list
= old_value
;
2588 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2589 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2590 If FEATURE is not a member of the list `features', then the feature
2591 is not loaded; so load the file FILENAME.
2592 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2593 and `load' will try to load this name appended with the suffix `.elc' or
2594 `.el', in that order. The name without appended suffix will not be used.
2595 See `get-load-suffixes' for the complete list of suffixes.
2596 If the optional third argument NOERROR is non-nil,
2597 then return nil if the file is not found instead of signaling an error.
2598 Normally the return value is FEATURE.
2599 The normal messages at start and end of loading FILENAME are suppressed. */)
2600 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2603 struct gcpro gcpro1
, gcpro2
;
2604 bool from_file
= load_in_progress
;
2606 CHECK_SYMBOL (feature
);
2608 /* Record the presence of `require' in this file
2609 even if the feature specified is already loaded.
2610 But not more than once in any file,
2611 and not when we aren't loading or reading from a file. */
2613 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2614 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2619 tem
= Fcons (Qrequire
, feature
);
2620 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2621 LOADHIST_ATTACH (tem
);
2623 tem
= Fmemq (feature
, Vfeatures
);
2627 ptrdiff_t count
= SPECPDL_INDEX ();
2630 /* This is to make sure that loadup.el gives a clear picture
2631 of what files are preloaded and when. */
2632 if (! NILP (Vpurify_flag
))
2633 error ("(require %s) while preparing to dump",
2634 SDATA (SYMBOL_NAME (feature
)));
2636 /* A certain amount of recursive `require' is legitimate,
2637 but if we require the same feature recursively 3 times,
2639 tem
= require_nesting_list
;
2640 while (! NILP (tem
))
2642 if (! NILP (Fequal (feature
, XCAR (tem
))))
2647 error ("Recursive `require' for feature `%s'",
2648 SDATA (SYMBOL_NAME (feature
)));
2650 /* Update the list for any nested `require's that occur. */
2651 record_unwind_protect (require_unwind
, require_nesting_list
);
2652 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2654 /* Value saved here is to be restored into Vautoload_queue */
2655 record_unwind_protect (un_autoload
, Vautoload_queue
);
2656 Vautoload_queue
= Qt
;
2658 /* Load the file. */
2659 GCPRO2 (feature
, filename
);
2660 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2661 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2664 /* If load failed entirely, return nil. */
2666 return unbind_to (count
, Qnil
);
2668 tem
= Fmemq (feature
, Vfeatures
);
2670 error ("Required feature `%s' was not provided",
2671 SDATA (SYMBOL_NAME (feature
)));
2673 /* Once loading finishes, don't undo it. */
2674 Vautoload_queue
= Qt
;
2675 feature
= unbind_to (count
, feature
);
2681 /* Primitives for work of the "widget" library.
2682 In an ideal world, this section would not have been necessary.
2683 However, lisp function calls being as slow as they are, it turns
2684 out that some functions in the widget library (wid-edit.el) are the
2685 bottleneck of Widget operation. Here is their translation to C,
2686 for the sole reason of efficiency. */
2688 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2689 doc
: /* Return non-nil if PLIST has the property PROP.
2690 PLIST is a property list, which is a list of the form
2691 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2692 Unlike `plist-get', this allows you to distinguish between a missing
2693 property and a property with the value nil.
2694 The value is actually the tail of PLIST whose car is PROP. */)
2695 (Lisp_Object plist
, Lisp_Object prop
)
2697 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2700 plist
= XCDR (plist
);
2701 plist
= CDR (plist
);
2706 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2707 doc
: /* In WIDGET, set PROPERTY to VALUE.
2708 The value can later be retrieved with `widget-get'. */)
2709 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2711 CHECK_CONS (widget
);
2712 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2716 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2717 doc
: /* In WIDGET, get the value of PROPERTY.
2718 The value could either be specified when the widget was created, or
2719 later with `widget-put'. */)
2720 (Lisp_Object widget
, Lisp_Object property
)
2728 CHECK_CONS (widget
);
2729 tmp
= Fplist_member (XCDR (widget
), property
);
2735 tmp
= XCAR (widget
);
2738 widget
= Fget (tmp
, Qwidget_type
);
2742 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2743 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2744 ARGS are passed as extra arguments to the function.
2745 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2746 (ptrdiff_t nargs
, Lisp_Object
*args
)
2748 /* This function can GC. */
2749 Lisp_Object newargs
[3];
2750 struct gcpro gcpro1
, gcpro2
;
2753 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2754 newargs
[1] = args
[0];
2755 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2756 GCPRO2 (newargs
[0], newargs
[2]);
2757 result
= Fapply (3, newargs
);
2762 #ifdef HAVE_LANGINFO_CODESET
2763 #include <langinfo.h>
2766 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2767 doc
: /* Access locale data ITEM for the current C locale, if available.
2768 ITEM should be one of the following:
2770 `codeset', returning the character set as a string (locale item CODESET);
2772 `days', returning a 7-element vector of day names (locale items DAY_n);
2774 `months', returning a 12-element vector of month names (locale items MON_n);
2776 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2777 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2779 If the system can't provide such information through a call to
2780 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2782 See also Info node `(libc)Locales'.
2784 The data read from the system are decoded using `locale-coding-system'. */)
2788 #ifdef HAVE_LANGINFO_CODESET
2790 if (EQ (item
, Qcodeset
))
2792 str
= nl_langinfo (CODESET
);
2793 return build_string (str
);
2796 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2798 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2799 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2801 struct gcpro gcpro1
;
2803 synchronize_system_time_locale ();
2804 for (i
= 0; i
< 7; i
++)
2806 str
= nl_langinfo (days
[i
]);
2807 val
= build_unibyte_string (str
);
2808 /* Fixme: Is this coding system necessarily right, even if
2809 it is consistent with CODESET? If not, what to do? */
2810 Faset (v
, make_number (i
),
2811 code_convert_string_norecord (val
, Vlocale_coding_system
,
2819 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2821 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2822 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2823 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2825 struct gcpro gcpro1
;
2827 synchronize_system_time_locale ();
2828 for (i
= 0; i
< 12; i
++)
2830 str
= nl_langinfo (months
[i
]);
2831 val
= build_unibyte_string (str
);
2832 Faset (v
, make_number (i
),
2833 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2839 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2840 but is in the locale files. This could be used by ps-print. */
2842 else if (EQ (item
, Qpaper
))
2844 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2845 make_number (nl_langinfo (PAPER_HEIGHT
)));
2847 #endif /* PAPER_WIDTH */
2848 #endif /* HAVE_LANGINFO_CODESET*/
2852 /* base64 encode/decode functions (RFC 2045).
2853 Based on code from GNU recode. */
2855 #define MIME_LINE_LENGTH 76
2857 #define IS_ASCII(Character) \
2859 #define IS_BASE64(Character) \
2860 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2861 #define IS_BASE64_IGNORABLE(Character) \
2862 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2863 || (Character) == '\f' || (Character) == '\r')
2865 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2866 character or return retval if there are no characters left to
2868 #define READ_QUADRUPLET_BYTE(retval) \
2873 if (nchars_return) \
2874 *nchars_return = nchars; \
2879 while (IS_BASE64_IGNORABLE (c))
2881 /* Table of characters coding the 64 values. */
2882 static const char base64_value_to_char
[64] =
2884 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2885 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2886 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2887 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2888 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2889 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2890 '8', '9', '+', '/' /* 60-63 */
2893 /* Table of base64 values for first 128 characters. */
2894 static const short base64_char_to_value
[128] =
2896 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2897 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2898 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2899 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2900 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2901 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2902 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2903 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2904 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2905 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2906 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2907 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2908 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2911 /* The following diagram shows the logical steps by which three octets
2912 get transformed into four base64 characters.
2914 .--------. .--------. .--------.
2915 |aaaaaabb| |bbbbcccc| |ccdddddd|
2916 `--------' `--------' `--------'
2918 .--------+--------+--------+--------.
2919 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2920 `--------+--------+--------+--------'
2922 .--------+--------+--------+--------.
2923 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2924 `--------+--------+--------+--------'
2926 The octets are divided into 6 bit chunks, which are then encoded into
2927 base64 characters. */
2930 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2931 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2934 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2936 doc
: /* Base64-encode the region between BEG and END.
2937 Return the length of the encoded text.
2938 Optional third argument NO-LINE-BREAK means do not break long lines
2939 into shorter lines. */)
2940 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2943 ptrdiff_t allength
, length
;
2944 ptrdiff_t ibeg
, iend
, encoded_length
;
2945 ptrdiff_t old_pos
= PT
;
2948 validate_region (&beg
, &end
);
2950 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2951 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2952 move_gap_both (XFASTINT (beg
), ibeg
);
2954 /* We need to allocate enough room for encoding the text.
2955 We need 33 1/3% more space, plus a newline every 76
2956 characters, and then we round up. */
2957 length
= iend
- ibeg
;
2958 allength
= length
+ length
/3 + 1;
2959 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2961 encoded
= SAFE_ALLOCA (allength
);
2962 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2963 encoded
, length
, NILP (no_line_break
),
2964 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2965 if (encoded_length
> allength
)
2968 if (encoded_length
< 0)
2970 /* The encoding wasn't possible. */
2972 error ("Multibyte character in data for base64 encoding");
2975 /* Now we have encoded the region, so we insert the new contents
2976 and delete the old. (Insert first in order to preserve markers.) */
2977 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2978 insert (encoded
, encoded_length
);
2980 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2982 /* If point was outside of the region, restore it exactly; else just
2983 move to the beginning of the region. */
2984 if (old_pos
>= XFASTINT (end
))
2985 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2986 else if (old_pos
> XFASTINT (beg
))
2987 old_pos
= XFASTINT (beg
);
2990 /* We return the length of the encoded text. */
2991 return make_number (encoded_length
);
2994 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2996 doc
: /* Base64-encode STRING and return the result.
2997 Optional second argument NO-LINE-BREAK means do not break long lines
2998 into shorter lines. */)
2999 (Lisp_Object string
, Lisp_Object no_line_break
)
3001 ptrdiff_t allength
, length
, encoded_length
;
3003 Lisp_Object encoded_string
;
3006 CHECK_STRING (string
);
3008 /* We need to allocate enough room for encoding the text.
3009 We need 33 1/3% more space, plus a newline every 76
3010 characters, and then we round up. */
3011 length
= SBYTES (string
);
3012 allength
= length
+ length
/3 + 1;
3013 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3015 /* We need to allocate enough room for decoding the text. */
3016 encoded
= SAFE_ALLOCA (allength
);
3018 encoded_length
= base64_encode_1 (SSDATA (string
),
3019 encoded
, length
, NILP (no_line_break
),
3020 STRING_MULTIBYTE (string
));
3021 if (encoded_length
> allength
)
3024 if (encoded_length
< 0)
3026 /* The encoding wasn't possible. */
3028 error ("Multibyte character in data for base64 encoding");
3031 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3034 return encoded_string
;
3038 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3039 bool line_break
, bool multibyte
)
3052 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3053 if (CHAR_BYTE8_P (c
))
3054 c
= CHAR_TO_BYTE8 (c
);
3062 /* Wrap line every 76 characters. */
3066 if (counter
< MIME_LINE_LENGTH
/ 4)
3075 /* Process first byte of a triplet. */
3077 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3078 value
= (0x03 & c
) << 4;
3080 /* Process second byte of a triplet. */
3084 *e
++ = base64_value_to_char
[value
];
3092 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3093 if (CHAR_BYTE8_P (c
))
3094 c
= CHAR_TO_BYTE8 (c
);
3102 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3103 value
= (0x0f & c
) << 2;
3105 /* Process third byte of a triplet. */
3109 *e
++ = base64_value_to_char
[value
];
3116 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3117 if (CHAR_BYTE8_P (c
))
3118 c
= CHAR_TO_BYTE8 (c
);
3126 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3127 *e
++ = base64_value_to_char
[0x3f & c
];
3134 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3136 doc
: /* Base64-decode the region between BEG and END.
3137 Return the length of the decoded text.
3138 If the region can't be decoded, signal an error and don't modify the buffer. */)
3139 (Lisp_Object beg
, Lisp_Object end
)
3141 ptrdiff_t ibeg
, iend
, length
, allength
;
3143 ptrdiff_t old_pos
= PT
;
3144 ptrdiff_t decoded_length
;
3145 ptrdiff_t inserted_chars
;
3146 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3149 validate_region (&beg
, &end
);
3151 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3152 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3154 length
= iend
- ibeg
;
3156 /* We need to allocate enough room for decoding the text. If we are
3157 working on a multibyte buffer, each decoded code may occupy at
3159 allength
= multibyte
? length
* 2 : length
;
3160 decoded
= SAFE_ALLOCA (allength
);
3162 move_gap_both (XFASTINT (beg
), ibeg
);
3163 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3165 multibyte
, &inserted_chars
);
3166 if (decoded_length
> allength
)
3169 if (decoded_length
< 0)
3171 /* The decoding wasn't possible. */
3173 error ("Invalid base64 data");
3176 /* Now we have decoded the region, so we insert the new contents
3177 and delete the old. (Insert first in order to preserve markers.) */
3178 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3179 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3182 /* Delete the original text. */
3183 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3184 iend
+ decoded_length
, 1);
3186 /* If point was outside of the region, restore it exactly; else just
3187 move to the beginning of the region. */
3188 if (old_pos
>= XFASTINT (end
))
3189 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3190 else if (old_pos
> XFASTINT (beg
))
3191 old_pos
= XFASTINT (beg
);
3192 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3194 return make_number (inserted_chars
);
3197 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3199 doc
: /* Base64-decode STRING and return the result. */)
3200 (Lisp_Object string
)
3203 ptrdiff_t length
, decoded_length
;
3204 Lisp_Object decoded_string
;
3207 CHECK_STRING (string
);
3209 length
= SBYTES (string
);
3210 /* We need to allocate enough room for decoding the text. */
3211 decoded
= SAFE_ALLOCA (length
);
3213 /* The decoded result should be unibyte. */
3214 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3216 if (decoded_length
> length
)
3218 else if (decoded_length
>= 0)
3219 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3221 decoded_string
= Qnil
;
3224 if (!STRINGP (decoded_string
))
3225 error ("Invalid base64 data");
3227 return decoded_string
;
3230 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3231 MULTIBYTE, the decoded result should be in multibyte
3232 form. If NCHARS_RETURN is not NULL, store the number of produced
3233 characters in *NCHARS_RETURN. */
3236 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3237 bool multibyte
, ptrdiff_t *nchars_return
)
3239 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3242 unsigned long value
;
3243 ptrdiff_t nchars
= 0;
3247 /* Process first byte of a quadruplet. */
3249 READ_QUADRUPLET_BYTE (e
-to
);
3253 value
= base64_char_to_value
[c
] << 18;
3255 /* Process second byte of a quadruplet. */
3257 READ_QUADRUPLET_BYTE (-1);
3261 value
|= base64_char_to_value
[c
] << 12;
3263 c
= (unsigned char) (value
>> 16);
3264 if (multibyte
&& c
>= 128)
3265 e
+= BYTE8_STRING (c
, e
);
3270 /* Process third byte of a quadruplet. */
3272 READ_QUADRUPLET_BYTE (-1);
3276 READ_QUADRUPLET_BYTE (-1);
3285 value
|= base64_char_to_value
[c
] << 6;
3287 c
= (unsigned char) (0xff & value
>> 8);
3288 if (multibyte
&& c
>= 128)
3289 e
+= BYTE8_STRING (c
, e
);
3294 /* Process fourth byte of a quadruplet. */
3296 READ_QUADRUPLET_BYTE (-1);
3303 value
|= base64_char_to_value
[c
];
3305 c
= (unsigned char) (0xff & value
);
3306 if (multibyte
&& c
>= 128)
3307 e
+= BYTE8_STRING (c
, e
);
3316 /***********************************************************************
3318 ***** Hash Tables *****
3320 ***********************************************************************/
3322 /* Implemented by gerd@gnu.org. This hash table implementation was
3323 inspired by CMUCL hash tables. */
3327 1. For small tables, association lists are probably faster than
3328 hash tables because they have lower overhead.
3330 For uses of hash tables where the O(1) behavior of table
3331 operations is not a requirement, it might therefore be a good idea
3332 not to hash. Instead, we could just do a linear search in the
3333 key_and_value vector of the hash table. This could be done
3334 if a `:linear-search t' argument is given to make-hash-table. */
3337 /* The list of all weak hash tables. Don't staticpro this one. */
3339 static struct Lisp_Hash_Table
*weak_hash_tables
;
3341 /* Various symbols. */
3343 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
, Qeql
;
3344 Lisp_Object Qeq
, Qequal
;
3345 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3346 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3349 /***********************************************************************
3351 ***********************************************************************/
3353 /* If OBJ is a Lisp hash table, return a pointer to its struct
3354 Lisp_Hash_Table. Otherwise, signal an error. */
3356 static struct Lisp_Hash_Table
*
3357 check_hash_table (Lisp_Object obj
)
3359 CHECK_HASH_TABLE (obj
);
3360 return XHASH_TABLE (obj
);
3364 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3365 number. A number is "almost" a prime number if it is not divisible
3366 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3369 next_almost_prime (EMACS_INT n
)
3371 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3372 for (n
|= 1; ; n
+= 2)
3373 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3378 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3379 which USED[I] is non-zero. If found at index I in ARGS, set
3380 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3381 0. This function is used to extract a keyword/argument pair from
3382 a DEFUN parameter list. */
3385 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3389 for (i
= 1; i
< nargs
; i
++)
3390 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3401 /* Return a Lisp vector which has the same contents as VEC but has
3402 at least INCR_MIN more entries, where INCR_MIN is positive.
3403 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3404 than NITEMS_MAX. Entries in the resulting
3405 vector that are not copied from VEC are set to nil. */
3408 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3410 struct Lisp_Vector
*v
;
3411 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3412 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3413 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3414 ? nitems_max
: C_language_max
);
3415 eassert (VECTORP (vec
));
3416 eassert (0 < incr_min
&& -1 <= nitems_max
);
3417 old_size
= ASIZE (vec
);
3418 incr_max
= n_max
- old_size
;
3419 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3420 if (incr_max
< incr
)
3421 memory_full (SIZE_MAX
);
3422 new_size
= old_size
+ incr
;
3423 v
= allocate_vector (new_size
);
3424 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3425 for (i
= old_size
; i
< new_size
; ++i
)
3426 v
->contents
[i
] = Qnil
;
3427 XSETVECTOR (vec
, v
);
3432 /***********************************************************************
3434 ***********************************************************************/
3436 static struct hash_table_test hashtest_eq
;
3437 struct hash_table_test hashtest_eql
, hashtest_equal
;
3439 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3440 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3441 KEY2 are the same. */
3444 cmpfn_eql (struct hash_table_test
*ht
,
3448 return (FLOATP (key1
)
3450 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3454 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3455 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3456 KEY2 are the same. */
3459 cmpfn_equal (struct hash_table_test
*ht
,
3463 return !NILP (Fequal (key1
, key2
));
3467 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3468 HASH2 in hash table H using H->user_cmp_function. Value is true
3469 if KEY1 and KEY2 are the same. */
3472 cmpfn_user_defined (struct hash_table_test
*ht
,
3476 Lisp_Object args
[3];
3478 args
[0] = ht
->user_cmp_function
;
3481 return !NILP (Ffuncall (3, args
));
3485 /* Value is a hash code for KEY for use in hash table H which uses
3486 `eq' to compare keys. The hash code returned is guaranteed to fit
3487 in a Lisp integer. */
3490 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3492 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3496 /* Value is a hash code for KEY for use in hash table H which uses
3497 `eql' to compare keys. The hash code returned is guaranteed to fit
3498 in a Lisp integer. */
3501 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3505 hash
= sxhash (key
, 0);
3507 hash
= XHASH (key
) ^ XTYPE (key
);
3511 /* Value is a hash code for KEY for use in hash table H which uses
3512 `equal' to compare keys. The hash code returned is guaranteed to fit
3513 in a Lisp integer. */
3516 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3518 EMACS_UINT hash
= sxhash (key
, 0);
3522 /* Value is a hash code for KEY for use in hash table H which uses as
3523 user-defined function to compare keys. The hash code returned is
3524 guaranteed to fit in a Lisp integer. */
3527 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3529 Lisp_Object args
[2], hash
;
3531 args
[0] = ht
->user_hash_function
;
3533 hash
= Ffuncall (2, args
);
3534 if (!INTEGERP (hash
))
3535 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3536 return XUINT (hash
);
3539 /* An upper bound on the size of a hash table index. It must fit in
3540 ptrdiff_t and be a valid Emacs fixnum. */
3541 #define INDEX_SIZE_BOUND \
3542 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3544 /* Create and initialize a new hash table.
3546 TEST specifies the test the hash table will use to compare keys.
3547 It must be either one of the predefined tests `eq', `eql' or
3548 `equal' or a symbol denoting a user-defined test named TEST with
3549 test and hash functions USER_TEST and USER_HASH.
3551 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3553 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3554 new size when it becomes full is computed by adding REHASH_SIZE to
3555 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3556 table's new size is computed by multiplying its old size with
3559 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3560 be resized when the ratio of (number of entries in the table) /
3561 (table size) is >= REHASH_THRESHOLD.
3563 WEAK specifies the weakness of the table. If non-nil, it must be
3564 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3567 make_hash_table (struct hash_table_test test
,
3568 Lisp_Object size
, Lisp_Object rehash_size
,
3569 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3571 struct Lisp_Hash_Table
*h
;
3573 EMACS_INT index_size
, sz
;
3577 /* Preconditions. */
3578 eassert (SYMBOLP (test
.name
));
3579 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3580 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3581 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3582 eassert (FLOATP (rehash_threshold
)
3583 && 0 < XFLOAT_DATA (rehash_threshold
)
3584 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3586 if (XFASTINT (size
) == 0)
3587 size
= make_number (1);
3589 sz
= XFASTINT (size
);
3590 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3591 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3592 ? next_almost_prime (index_float
)
3593 : INDEX_SIZE_BOUND
+ 1);
3594 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3595 error ("Hash table too large");
3597 /* Allocate a table and initialize it. */
3598 h
= allocate_hash_table ();
3600 /* Initialize hash table slots. */
3603 h
->rehash_threshold
= rehash_threshold
;
3604 h
->rehash_size
= rehash_size
;
3606 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3607 h
->hash
= Fmake_vector (size
, Qnil
);
3608 h
->next
= Fmake_vector (size
, Qnil
);
3609 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3611 /* Set up the free list. */
3612 for (i
= 0; i
< sz
- 1; ++i
)
3613 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3614 h
->next_free
= make_number (0);
3616 XSET_HASH_TABLE (table
, h
);
3617 eassert (HASH_TABLE_P (table
));
3618 eassert (XHASH_TABLE (table
) == h
);
3620 /* Maybe add this hash table to the list of all weak hash tables. */
3622 h
->next_weak
= NULL
;
3625 h
->next_weak
= weak_hash_tables
;
3626 weak_hash_tables
= h
;
3633 /* Return a copy of hash table H1. Keys and values are not copied,
3634 only the table itself is. */
3637 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3640 struct Lisp_Hash_Table
*h2
;
3642 h2
= allocate_hash_table ();
3644 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3645 h2
->hash
= Fcopy_sequence (h1
->hash
);
3646 h2
->next
= Fcopy_sequence (h1
->next
);
3647 h2
->index
= Fcopy_sequence (h1
->index
);
3648 XSET_HASH_TABLE (table
, h2
);
3650 /* Maybe add this hash table to the list of all weak hash tables. */
3651 if (!NILP (h2
->weak
))
3653 h2
->next_weak
= weak_hash_tables
;
3654 weak_hash_tables
= h2
;
3661 /* Resize hash table H if it's too full. If H cannot be resized
3662 because it's already too large, throw an error. */
3665 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3667 if (NILP (h
->next_free
))
3669 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3670 EMACS_INT new_size
, index_size
, nsize
;
3674 if (INTEGERP (h
->rehash_size
))
3675 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3678 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3679 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3681 new_size
= float_new_size
;
3682 if (new_size
<= old_size
)
3683 new_size
= old_size
+ 1;
3686 new_size
= INDEX_SIZE_BOUND
+ 1;
3688 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3689 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3690 ? next_almost_prime (index_float
)
3691 : INDEX_SIZE_BOUND
+ 1);
3692 nsize
= max (index_size
, 2 * new_size
);
3693 if (INDEX_SIZE_BOUND
< nsize
)
3694 error ("Hash table too large to resize");
3696 #ifdef ENABLE_CHECKING
3697 if (HASH_TABLE_P (Vpurify_flag
)
3698 && XHASH_TABLE (Vpurify_flag
) == h
)
3700 Lisp_Object args
[2];
3701 args
[0] = build_string ("Growing hash table to: %d");
3702 args
[1] = make_number (new_size
);
3707 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3708 2 * (new_size
- old_size
), -1));
3709 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3710 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3711 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3713 /* Update the free list. Do it so that new entries are added at
3714 the end of the free list. This makes some operations like
3716 for (i
= old_size
; i
< new_size
- 1; ++i
)
3717 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3719 if (!NILP (h
->next_free
))
3721 Lisp_Object last
, next
;
3723 last
= h
->next_free
;
3724 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3728 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3731 XSETFASTINT (h
->next_free
, old_size
);
3734 for (i
= 0; i
< old_size
; ++i
)
3735 if (!NILP (HASH_HASH (h
, i
)))
3737 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3738 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3739 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3740 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3746 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3747 the hash code of KEY. Value is the index of the entry in H
3748 matching KEY, or -1 if not found. */
3751 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3753 EMACS_UINT hash_code
;
3754 ptrdiff_t start_of_bucket
;
3757 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3758 eassert ((hash_code
& ~INTMASK
) == 0);
3762 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3763 idx
= HASH_INDEX (h
, start_of_bucket
);
3765 /* We need not gcpro idx since it's either an integer or nil. */
3768 ptrdiff_t i
= XFASTINT (idx
);
3769 if (EQ (key
, HASH_KEY (h
, i
))
3771 && hash_code
== XUINT (HASH_HASH (h
, i
))
3772 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3774 idx
= HASH_NEXT (h
, i
);
3777 return NILP (idx
) ? -1 : XFASTINT (idx
);
3781 /* Put an entry into hash table H that associates KEY with VALUE.
3782 HASH is a previously computed hash code of KEY.
3783 Value is the index of the entry in H matching KEY. */
3786 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3789 ptrdiff_t start_of_bucket
, i
;
3791 eassert ((hash
& ~INTMASK
) == 0);
3793 /* Increment count after resizing because resizing may fail. */
3794 maybe_resize_hash_table (h
);
3797 /* Store key/value in the key_and_value vector. */
3798 i
= XFASTINT (h
->next_free
);
3799 h
->next_free
= HASH_NEXT (h
, i
);
3800 set_hash_key_slot (h
, i
, key
);
3801 set_hash_value_slot (h
, i
, value
);
3803 /* Remember its hash code. */
3804 set_hash_hash_slot (h
, i
, make_number (hash
));
3806 /* Add new entry to its collision chain. */
3807 start_of_bucket
= hash
% ASIZE (h
->index
);
3808 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3809 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3814 /* Remove the entry matching KEY from hash table H, if there is one. */
3817 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3819 EMACS_UINT hash_code
;
3820 ptrdiff_t start_of_bucket
;
3821 Lisp_Object idx
, prev
;
3823 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3824 eassert ((hash_code
& ~INTMASK
) == 0);
3825 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3826 idx
= HASH_INDEX (h
, start_of_bucket
);
3829 /* We need not gcpro idx, prev since they're either integers or nil. */
3832 ptrdiff_t i
= XFASTINT (idx
);
3834 if (EQ (key
, HASH_KEY (h
, i
))
3836 && hash_code
== XUINT (HASH_HASH (h
, i
))
3837 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3839 /* Take entry out of collision chain. */
3841 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3843 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3845 /* Clear slots in key_and_value and add the slots to
3847 set_hash_key_slot (h
, i
, Qnil
);
3848 set_hash_value_slot (h
, i
, Qnil
);
3849 set_hash_hash_slot (h
, i
, Qnil
);
3850 set_hash_next_slot (h
, i
, h
->next_free
);
3851 h
->next_free
= make_number (i
);
3853 eassert (h
->count
>= 0);
3859 idx
= HASH_NEXT (h
, i
);
3865 /* Clear hash table H. */
3868 hash_clear (struct Lisp_Hash_Table
*h
)
3872 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3874 for (i
= 0; i
< size
; ++i
)
3876 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3877 set_hash_key_slot (h
, i
, Qnil
);
3878 set_hash_value_slot (h
, i
, Qnil
);
3879 set_hash_hash_slot (h
, i
, Qnil
);
3882 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3883 ASET (h
->index
, i
, Qnil
);
3885 h
->next_free
= make_number (0);
3892 /************************************************************************
3894 ************************************************************************/
3896 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3897 entries from the table that don't survive the current GC.
3898 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3899 true if anything was marked. */
3902 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3904 ptrdiff_t bucket
, n
;
3907 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3910 for (bucket
= 0; bucket
< n
; ++bucket
)
3912 Lisp_Object idx
, next
, prev
;
3914 /* Follow collision chain, removing entries that
3915 don't survive this garbage collection. */
3917 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3919 ptrdiff_t i
= XFASTINT (idx
);
3920 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3921 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3924 if (EQ (h
->weak
, Qkey
))
3925 remove_p
= !key_known_to_survive_p
;
3926 else if (EQ (h
->weak
, Qvalue
))
3927 remove_p
= !value_known_to_survive_p
;
3928 else if (EQ (h
->weak
, Qkey_or_value
))
3929 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3930 else if (EQ (h
->weak
, Qkey_and_value
))
3931 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3935 next
= HASH_NEXT (h
, i
);
3937 if (remove_entries_p
)
3941 /* Take out of collision chain. */
3943 set_hash_index_slot (h
, bucket
, next
);
3945 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3947 /* Add to free list. */
3948 set_hash_next_slot (h
, i
, h
->next_free
);
3951 /* Clear key, value, and hash. */
3952 set_hash_key_slot (h
, i
, Qnil
);
3953 set_hash_value_slot (h
, i
, Qnil
);
3954 set_hash_hash_slot (h
, i
, Qnil
);
3967 /* Make sure key and value survive. */
3968 if (!key_known_to_survive_p
)
3970 mark_object (HASH_KEY (h
, i
));
3974 if (!value_known_to_survive_p
)
3976 mark_object (HASH_VALUE (h
, i
));
3987 /* Remove elements from weak hash tables that don't survive the
3988 current garbage collection. Remove weak tables that don't survive
3989 from Vweak_hash_tables. Called from gc_sweep. */
3992 sweep_weak_hash_tables (void)
3994 struct Lisp_Hash_Table
*h
, *used
, *next
;
3997 /* Mark all keys and values that are in use. Keep on marking until
3998 there is no more change. This is necessary for cases like
3999 value-weak table A containing an entry X -> Y, where Y is used in a
4000 key-weak table B, Z -> Y. If B comes after A in the list of weak
4001 tables, X -> Y might be removed from A, although when looking at B
4002 one finds that it shouldn't. */
4006 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4008 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4009 marked
|= sweep_weak_table (h
, 0);
4014 /* Remove tables and entries that aren't used. */
4015 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4017 next
= h
->next_weak
;
4019 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4021 /* TABLE is marked as used. Sweep its contents. */
4023 sweep_weak_table (h
, 1);
4025 /* Add table to the list of used weak hash tables. */
4026 h
->next_weak
= used
;
4031 weak_hash_tables
= used
;
4036 /***********************************************************************
4037 Hash Code Computation
4038 ***********************************************************************/
4040 /* Maximum depth up to which to dive into Lisp structures. */
4042 #define SXHASH_MAX_DEPTH 3
4044 /* Maximum length up to which to take list and vector elements into
4047 #define SXHASH_MAX_LEN 7
4049 /* Hash X, returning a value that fits into a Lisp integer. */
4050 #define SXHASH_REDUCE(X) \
4051 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4053 /* Return a hash for string PTR which has length LEN. The hash value
4054 can be any EMACS_UINT value. */
4057 hash_string (char const *ptr
, ptrdiff_t len
)
4059 char const *p
= ptr
;
4060 char const *end
= p
+ len
;
4062 EMACS_UINT hash
= 0;
4067 hash
= sxhash_combine (hash
, c
);
4073 /* Return a hash for string PTR which has length LEN. The hash
4074 code returned is guaranteed to fit in a Lisp integer. */
4077 sxhash_string (char const *ptr
, ptrdiff_t len
)
4079 EMACS_UINT hash
= hash_string (ptr
, len
);
4080 return SXHASH_REDUCE (hash
);
4083 /* Return a hash for the floating point value VAL. */
4086 sxhash_float (double val
)
4088 EMACS_UINT hash
= 0;
4090 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4091 + (sizeof val
% sizeof hash
!= 0))
4095 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4099 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4100 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4101 hash
= sxhash_combine (hash
, u
.word
[i
]);
4102 return SXHASH_REDUCE (hash
);
4105 /* Return a hash for list LIST. DEPTH is the current depth in the
4106 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4109 sxhash_list (Lisp_Object list
, int depth
)
4111 EMACS_UINT hash
= 0;
4114 if (depth
< SXHASH_MAX_DEPTH
)
4116 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4117 list
= XCDR (list
), ++i
)
4119 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4120 hash
= sxhash_combine (hash
, hash2
);
4125 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4126 hash
= sxhash_combine (hash
, hash2
);
4129 return SXHASH_REDUCE (hash
);
4133 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4134 the Lisp structure. */
4137 sxhash_vector (Lisp_Object vec
, int depth
)
4139 EMACS_UINT hash
= ASIZE (vec
);
4142 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4143 for (i
= 0; i
< n
; ++i
)
4145 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4146 hash
= sxhash_combine (hash
, hash2
);
4149 return SXHASH_REDUCE (hash
);
4152 /* Return a hash for bool-vector VECTOR. */
4155 sxhash_bool_vector (Lisp_Object vec
)
4157 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4160 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4161 for (i
= 0; i
< n
; ++i
)
4162 hash
= sxhash_combine (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4164 return SXHASH_REDUCE (hash
);
4168 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4169 structure. Value is an unsigned integer clipped to INTMASK. */
4172 sxhash (Lisp_Object obj
, int depth
)
4176 if (depth
> SXHASH_MAX_DEPTH
)
4179 switch (XTYPE (obj
))
4190 obj
= SYMBOL_NAME (obj
);
4194 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4197 /* This can be everything from a vector to an overlay. */
4198 case Lisp_Vectorlike
:
4200 /* According to the CL HyperSpec, two arrays are equal only if
4201 they are `eq', except for strings and bit-vectors. In
4202 Emacs, this works differently. We have to compare element
4204 hash
= sxhash_vector (obj
, depth
);
4205 else if (BOOL_VECTOR_P (obj
))
4206 hash
= sxhash_bool_vector (obj
);
4208 /* Others are `equal' if they are `eq', so let's take their
4214 hash
= sxhash_list (obj
, depth
);
4218 hash
= sxhash_float (XFLOAT_DATA (obj
));
4230 /***********************************************************************
4232 ***********************************************************************/
4235 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4236 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4239 EMACS_UINT hash
= sxhash (obj
, 0);
4240 return make_number (hash
);
4244 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4245 doc
: /* Create and return a new hash table.
4247 Arguments are specified as keyword/argument pairs. The following
4248 arguments are defined:
4250 :test TEST -- TEST must be a symbol that specifies how to compare
4251 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4252 `equal'. User-supplied test and hash functions can be specified via
4253 `define-hash-table-test'.
4255 :size SIZE -- A hint as to how many elements will be put in the table.
4258 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4259 fills up. If REHASH-SIZE is an integer, increase the size by that
4260 amount. If it is a float, it must be > 1.0, and the new size is the
4261 old size multiplied by that factor. Default is 1.5.
4263 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4264 Resize the hash table when the ratio (number of entries / table size)
4265 is greater than or equal to THRESHOLD. Default is 0.8.
4267 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4268 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4269 returned is a weak table. Key/value pairs are removed from a weak
4270 hash table when there are no non-weak references pointing to their
4271 key, value, one of key or value, or both key and value, depending on
4272 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4275 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4276 (ptrdiff_t nargs
, Lisp_Object
*args
)
4278 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4279 struct hash_table_test testdesc
;
4283 /* The vector `used' is used to keep track of arguments that
4284 have been consumed. */
4285 used
= alloca (nargs
* sizeof *used
);
4286 memset (used
, 0, nargs
* sizeof *used
);
4288 /* See if there's a `:test TEST' among the arguments. */
4289 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4290 test
= i
? args
[i
] : Qeql
;
4292 testdesc
= hashtest_eq
;
4293 else if (EQ (test
, Qeql
))
4294 testdesc
= hashtest_eql
;
4295 else if (EQ (test
, Qequal
))
4296 testdesc
= hashtest_equal
;
4299 /* See if it is a user-defined test. */
4302 prop
= Fget (test
, Qhash_table_test
);
4303 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4304 signal_error ("Invalid hash table test", test
);
4305 testdesc
.name
= test
;
4306 testdesc
.user_cmp_function
= XCAR (prop
);
4307 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4308 testdesc
.hashfn
= hashfn_user_defined
;
4309 testdesc
.cmpfn
= cmpfn_user_defined
;
4312 /* See if there's a `:size SIZE' argument. */
4313 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4314 size
= i
? args
[i
] : Qnil
;
4316 size
= make_number (DEFAULT_HASH_SIZE
);
4317 else if (!INTEGERP (size
) || XINT (size
) < 0)
4318 signal_error ("Invalid hash table size", size
);
4320 /* Look for `:rehash-size SIZE'. */
4321 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4322 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4323 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4324 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4325 signal_error ("Invalid hash table rehash size", rehash_size
);
4327 /* Look for `:rehash-threshold THRESHOLD'. */
4328 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4329 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4330 if (! (FLOATP (rehash_threshold
)
4331 && 0 < XFLOAT_DATA (rehash_threshold
)
4332 && XFLOAT_DATA (rehash_threshold
) <= 1))
4333 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4335 /* Look for `:weakness WEAK'. */
4336 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4337 weak
= i
? args
[i
] : Qnil
;
4339 weak
= Qkey_and_value
;
4342 && !EQ (weak
, Qvalue
)
4343 && !EQ (weak
, Qkey_or_value
)
4344 && !EQ (weak
, Qkey_and_value
))
4345 signal_error ("Invalid hash table weakness", weak
);
4347 /* Now, all args should have been used up, or there's a problem. */
4348 for (i
= 0; i
< nargs
; ++i
)
4350 signal_error ("Invalid argument list", args
[i
]);
4352 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4356 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4357 doc
: /* Return a copy of hash table TABLE. */)
4360 return copy_hash_table (check_hash_table (table
));
4364 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4365 doc
: /* Return the number of elements in TABLE. */)
4368 return make_number (check_hash_table (table
)->count
);
4372 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4373 Shash_table_rehash_size
, 1, 1, 0,
4374 doc
: /* Return the current rehash size of TABLE. */)
4377 return check_hash_table (table
)->rehash_size
;
4381 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4382 Shash_table_rehash_threshold
, 1, 1, 0,
4383 doc
: /* Return the current rehash threshold of TABLE. */)
4386 return check_hash_table (table
)->rehash_threshold
;
4390 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4391 doc
: /* Return the size of TABLE.
4392 The size can be used as an argument to `make-hash-table' to create
4393 a hash table than can hold as many elements as TABLE holds
4394 without need for resizing. */)
4397 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4398 return make_number (HASH_TABLE_SIZE (h
));
4402 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4403 doc
: /* Return the test TABLE uses. */)
4406 return check_hash_table (table
)->test
.name
;
4410 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4412 doc
: /* Return the weakness of TABLE. */)
4415 return check_hash_table (table
)->weak
;
4419 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4420 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4423 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4427 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4428 doc
: /* Clear hash table TABLE and return it. */)
4431 hash_clear (check_hash_table (table
));
4432 /* Be compatible with XEmacs. */
4437 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4438 doc
: /* Look up KEY in TABLE and return its associated value.
4439 If KEY is not found, return DFLT which defaults to nil. */)
4440 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4442 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4443 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4444 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4448 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4449 doc
: /* Associate KEY with VALUE in hash table TABLE.
4450 If KEY is already present in table, replace its current value with
4451 VALUE. In any case, return VALUE. */)
4452 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4454 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4458 i
= hash_lookup (h
, key
, &hash
);
4460 set_hash_value_slot (h
, i
, value
);
4462 hash_put (h
, key
, value
, hash
);
4468 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4469 doc
: /* Remove KEY from TABLE. */)
4470 (Lisp_Object key
, Lisp_Object table
)
4472 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4473 hash_remove_from_table (h
, key
);
4478 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4479 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4480 FUNCTION is called with two arguments, KEY and VALUE. */)
4481 (Lisp_Object function
, Lisp_Object table
)
4483 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4484 Lisp_Object args
[3];
4487 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4488 if (!NILP (HASH_HASH (h
, i
)))
4491 args
[1] = HASH_KEY (h
, i
);
4492 args
[2] = HASH_VALUE (h
, i
);
4500 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4501 Sdefine_hash_table_test
, 3, 3, 0,
4502 doc
: /* Define a new hash table test with name NAME, a symbol.
4504 In hash tables created with NAME specified as test, use TEST to
4505 compare keys, and HASH for computing hash codes of keys.
4507 TEST must be a function taking two arguments and returning non-nil if
4508 both arguments are the same. HASH must be a function taking one
4509 argument and return an integer that is the hash code of the argument.
4510 Hash code computation should use the whole value range of integers,
4511 including negative integers. */)
4512 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4514 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4519 /************************************************************************
4520 MD5, SHA-1, and SHA-2
4521 ************************************************************************/
4528 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4531 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4535 EMACS_INT start_char
= 0, end_char
= 0;
4536 ptrdiff_t start_byte
, end_byte
;
4537 register EMACS_INT b
, e
;
4538 register struct buffer
*bp
;
4541 void *(*hash_func
) (const char *, size_t, void *);
4544 CHECK_SYMBOL (algorithm
);
4546 if (STRINGP (object
))
4548 if (NILP (coding_system
))
4550 /* Decide the coding-system to encode the data with. */
4552 if (STRING_MULTIBYTE (object
))
4553 /* use default, we can't guess correct value */
4554 coding_system
= preferred_coding_system ();
4556 coding_system
= Qraw_text
;
4559 if (NILP (Fcoding_system_p (coding_system
)))
4561 /* Invalid coding system. */
4563 if (!NILP (noerror
))
4564 coding_system
= Qraw_text
;
4566 xsignal1 (Qcoding_system_error
, coding_system
);
4569 if (STRING_MULTIBYTE (object
))
4570 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4572 size
= SCHARS (object
);
4576 CHECK_NUMBER (start
);
4578 start_char
= XINT (start
);
4590 end_char
= XINT (end
);
4596 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4597 args_out_of_range_3 (object
, make_number (start_char
),
4598 make_number (end_char
));
4600 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4602 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4606 struct buffer
*prev
= current_buffer
;
4608 record_unwind_current_buffer ();
4610 CHECK_BUFFER (object
);
4612 bp
= XBUFFER (object
);
4613 set_buffer_internal (bp
);
4619 CHECK_NUMBER_COERCE_MARKER (start
);
4627 CHECK_NUMBER_COERCE_MARKER (end
);
4632 temp
= b
, b
= e
, e
= temp
;
4634 if (!(BEGV
<= b
&& e
<= ZV
))
4635 args_out_of_range (start
, end
);
4637 if (NILP (coding_system
))
4639 /* Decide the coding-system to encode the data with.
4640 See fileio.c:Fwrite-region */
4642 if (!NILP (Vcoding_system_for_write
))
4643 coding_system
= Vcoding_system_for_write
;
4646 bool force_raw_text
= 0;
4648 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4649 if (NILP (coding_system
)
4650 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4652 coding_system
= Qnil
;
4653 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4657 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4659 /* Check file-coding-system-alist. */
4660 Lisp_Object args
[4], val
;
4662 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4663 args
[3] = Fbuffer_file_name (object
);
4664 val
= Ffind_operation_coding_system (4, args
);
4665 if (CONSP (val
) && !NILP (XCDR (val
)))
4666 coding_system
= XCDR (val
);
4669 if (NILP (coding_system
)
4670 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4672 /* If we still have not decided a coding system, use the
4673 default value of buffer-file-coding-system. */
4674 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4678 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4679 /* Confirm that VAL can surely encode the current region. */
4680 coding_system
= call4 (Vselect_safe_coding_system_function
,
4681 make_number (b
), make_number (e
),
4682 coding_system
, Qnil
);
4685 coding_system
= Qraw_text
;
4688 if (NILP (Fcoding_system_p (coding_system
)))
4690 /* Invalid coding system. */
4692 if (!NILP (noerror
))
4693 coding_system
= Qraw_text
;
4695 xsignal1 (Qcoding_system_error
, coding_system
);
4699 object
= make_buffer_string (b
, e
, 0);
4700 set_buffer_internal (prev
);
4701 /* Discard the unwind protect for recovering the current
4705 if (STRING_MULTIBYTE (object
))
4706 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4708 end_byte
= SBYTES (object
);
4711 if (EQ (algorithm
, Qmd5
))
4713 digest_size
= MD5_DIGEST_SIZE
;
4714 hash_func
= md5_buffer
;
4716 else if (EQ (algorithm
, Qsha1
))
4718 digest_size
= SHA1_DIGEST_SIZE
;
4719 hash_func
= sha1_buffer
;
4721 else if (EQ (algorithm
, Qsha224
))
4723 digest_size
= SHA224_DIGEST_SIZE
;
4724 hash_func
= sha224_buffer
;
4726 else if (EQ (algorithm
, Qsha256
))
4728 digest_size
= SHA256_DIGEST_SIZE
;
4729 hash_func
= sha256_buffer
;
4731 else if (EQ (algorithm
, Qsha384
))
4733 digest_size
= SHA384_DIGEST_SIZE
;
4734 hash_func
= sha384_buffer
;
4736 else if (EQ (algorithm
, Qsha512
))
4738 digest_size
= SHA512_DIGEST_SIZE
;
4739 hash_func
= sha512_buffer
;
4742 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4744 /* allocate 2 x digest_size so that it can be re-used to hold the
4746 digest
= make_uninit_string (digest_size
* 2);
4748 hash_func (SSDATA (object
) + start_byte
,
4749 end_byte
- start_byte
,
4754 unsigned char *p
= SDATA (digest
);
4755 for (i
= digest_size
- 1; i
>= 0; i
--)
4757 static char const hexdigit
[16] = "0123456789abcdef";
4759 p
[2 * i
] = hexdigit
[p_i
>> 4];
4760 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4765 return make_unibyte_string (SSDATA (digest
), digest_size
);
4768 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4769 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4771 A message digest is a cryptographic checksum of a document, and the
4772 algorithm to calculate it is defined in RFC 1321.
4774 The two optional arguments START and END are character positions
4775 specifying for which part of OBJECT the message digest should be
4776 computed. If nil or omitted, the digest is computed for the whole
4779 The MD5 message digest is computed from the result of encoding the
4780 text in a coding system, not directly from the internal Emacs form of
4781 the text. The optional fourth argument CODING-SYSTEM specifies which
4782 coding system to encode the text with. It should be the same coding
4783 system that you used or will use when actually writing the text into a
4786 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4787 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4788 system would be chosen by default for writing this text into a file.
4790 If OBJECT is a string, the most preferred coding system (see the
4791 command `prefer-coding-system') is used.
4793 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4794 guesswork fails. Normally, an error is signaled in such case. */)
4795 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4797 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4800 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4801 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4802 ALGORITHM is a symbol specifying the hash to use:
4803 md5, sha1, sha224, sha256, sha384 or sha512.
4805 The two optional arguments START and END are positions specifying for
4806 which part of OBJECT to compute the hash. If nil or omitted, uses the
4809 If BINARY is non-nil, returns a string in binary form. */)
4810 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4812 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4818 DEFSYM (Qmd5
, "md5");
4819 DEFSYM (Qsha1
, "sha1");
4820 DEFSYM (Qsha224
, "sha224");
4821 DEFSYM (Qsha256
, "sha256");
4822 DEFSYM (Qsha384
, "sha384");
4823 DEFSYM (Qsha512
, "sha512");
4825 /* Hash table stuff. */
4826 DEFSYM (Qhash_table_p
, "hash-table-p");
4828 DEFSYM (Qeql
, "eql");
4829 DEFSYM (Qequal
, "equal");
4830 DEFSYM (QCtest
, ":test");
4831 DEFSYM (QCsize
, ":size");
4832 DEFSYM (QCrehash_size
, ":rehash-size");
4833 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4834 DEFSYM (QCweakness
, ":weakness");
4835 DEFSYM (Qkey
, "key");
4836 DEFSYM (Qvalue
, "value");
4837 DEFSYM (Qhash_table_test
, "hash-table-test");
4838 DEFSYM (Qkey_or_value
, "key-or-value");
4839 DEFSYM (Qkey_and_value
, "key-and-value");
4842 defsubr (&Smake_hash_table
);
4843 defsubr (&Scopy_hash_table
);
4844 defsubr (&Shash_table_count
);
4845 defsubr (&Shash_table_rehash_size
);
4846 defsubr (&Shash_table_rehash_threshold
);
4847 defsubr (&Shash_table_size
);
4848 defsubr (&Shash_table_test
);
4849 defsubr (&Shash_table_weakness
);
4850 defsubr (&Shash_table_p
);
4851 defsubr (&Sclrhash
);
4852 defsubr (&Sgethash
);
4853 defsubr (&Sputhash
);
4854 defsubr (&Sremhash
);
4855 defsubr (&Smaphash
);
4856 defsubr (&Sdefine_hash_table_test
);
4858 DEFSYM (Qstring_lessp
, "string-lessp");
4859 DEFSYM (Qprovide
, "provide");
4860 DEFSYM (Qrequire
, "require");
4861 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4862 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4863 DEFSYM (Qwidget_type
, "widget-type");
4865 staticpro (&string_char_byte_cache_string
);
4866 string_char_byte_cache_string
= Qnil
;
4868 require_nesting_list
= Qnil
;
4869 staticpro (&require_nesting_list
);
4871 Fset (Qyes_or_no_p_history
, Qnil
);
4873 DEFVAR_LISP ("features", Vfeatures
,
4874 doc
: /* A list of symbols which are the features of the executing Emacs.
4875 Used by `featurep' and `require', and altered by `provide'. */);
4876 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4877 DEFSYM (Qsubfeatures
, "subfeatures");
4879 #ifdef HAVE_LANGINFO_CODESET
4880 DEFSYM (Qcodeset
, "codeset");
4881 DEFSYM (Qdays
, "days");
4882 DEFSYM (Qmonths
, "months");
4883 DEFSYM (Qpaper
, "paper");
4884 #endif /* HAVE_LANGINFO_CODESET */
4886 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4887 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4888 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4889 invoked by mouse clicks and mouse menu items.
4891 On some platforms, file selection dialogs are also enabled if this is
4895 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4896 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4897 This applies to commands from menus and tool bar buttons even when
4898 they are initiated from the keyboard. If `use-dialog-box' is nil,
4899 that disables the use of a file dialog, regardless of the value of
4901 use_file_dialog
= 1;
4903 defsubr (&Sidentity
);
4906 defsubr (&Ssafe_length
);
4907 defsubr (&Sstring_bytes
);
4908 defsubr (&Sstring_equal
);
4909 defsubr (&Scompare_strings
);
4910 defsubr (&Sstring_lessp
);
4913 defsubr (&Svconcat
);
4914 defsubr (&Scopy_sequence
);
4915 defsubr (&Sstring_make_multibyte
);
4916 defsubr (&Sstring_make_unibyte
);
4917 defsubr (&Sstring_as_multibyte
);
4918 defsubr (&Sstring_as_unibyte
);
4919 defsubr (&Sstring_to_multibyte
);
4920 defsubr (&Sstring_to_unibyte
);
4921 defsubr (&Scopy_alist
);
4922 defsubr (&Ssubstring
);
4923 defsubr (&Ssubstring_no_properties
);
4936 defsubr (&Snreverse
);
4937 defsubr (&Sreverse
);
4939 defsubr (&Splist_get
);
4941 defsubr (&Splist_put
);
4943 defsubr (&Slax_plist_get
);
4944 defsubr (&Slax_plist_put
);
4947 defsubr (&Sequal_including_properties
);
4948 defsubr (&Sfillarray
);
4949 defsubr (&Sclear_string
);
4953 defsubr (&Smapconcat
);
4954 defsubr (&Syes_or_no_p
);
4955 defsubr (&Sload_average
);
4956 defsubr (&Sfeaturep
);
4957 defsubr (&Srequire
);
4958 defsubr (&Sprovide
);
4959 defsubr (&Splist_member
);
4960 defsubr (&Swidget_put
);
4961 defsubr (&Swidget_get
);
4962 defsubr (&Swidget_apply
);
4963 defsubr (&Sbase64_encode_region
);
4964 defsubr (&Sbase64_decode_region
);
4965 defsubr (&Sbase64_encode_string
);
4966 defsubr (&Sbase64_decode_string
);
4968 defsubr (&Ssecure_hash
);
4969 defsubr (&Slocale_info
);
4972 struct hash_table_test
4973 eq
= { Qeq
, Qnil
, Qnil
, NULL
, hashfn_eq
},
4974 eql
= { Qeql
, Qnil
, Qnil
, cmpfn_eql
, hashfn_eql
},
4975 equal
= { Qequal
, Qnil
, Qnil
, cmpfn_equal
, hashfn_equal
};
4978 hashtest_equal
= equal
;