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. */
95 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
97 CHECK_TYPE (NILP (x
), Qlistp
, y
);
100 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
101 doc
: /* Return the length of vector, list or string SEQUENCE.
102 A byte-code function object is also allowed.
103 If the string contains multibyte characters, this is not necessarily
104 the number of bytes in the string; it is the number of characters.
105 To get the number of bytes, use `string-bytes'. */)
106 (register Lisp_Object sequence
)
108 register Lisp_Object val
;
110 if (STRINGP (sequence
))
111 XSETFASTINT (val
, SCHARS (sequence
));
112 else if (VECTORP (sequence
))
113 XSETFASTINT (val
, ASIZE (sequence
));
114 else if (CHAR_TABLE_P (sequence
))
115 XSETFASTINT (val
, MAX_CHAR
);
116 else if (BOOL_VECTOR_P (sequence
))
117 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
118 else if (COMPILEDP (sequence
))
119 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
120 else if (CONSP (sequence
))
127 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
129 if (MOST_POSITIVE_FIXNUM
< i
)
130 error ("List too long");
133 sequence
= XCDR (sequence
);
135 while (CONSP (sequence
));
137 CHECK_LIST_END (sequence
, sequence
);
139 val
= make_number (i
);
141 else if (NILP (sequence
))
142 XSETFASTINT (val
, 0);
144 wrong_type_argument (Qsequencep
, sequence
);
149 /* This does not check for quits. That is safe since it must terminate. */
151 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
152 doc
: /* Return the length of a list, but avoid error or infinite loop.
153 This function never gets an error. If LIST is not really a list,
154 it returns 0. If LIST is circular, it returns a finite value
155 which is at least the number of distinct elements. */)
158 Lisp_Object tail
, halftail
;
163 return make_number (0);
165 /* halftail is used to detect circular lists. */
166 for (tail
= halftail
= list
; ; )
171 if (EQ (tail
, halftail
))
174 if ((lolen
& 1) == 0)
176 halftail
= XCDR (halftail
);
177 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
181 hilen
+= UINTMAX_MAX
+ 1.0;
186 /* If the length does not fit into a fixnum, return a float.
187 On all known practical machines this returns an upper bound on
189 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
192 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
193 doc
: /* Return the number of bytes in STRING.
194 If STRING is multibyte, this may be greater than the length of STRING. */)
197 CHECK_STRING (string
);
198 return make_number (SBYTES (string
));
201 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
202 doc
: /* Return t if two strings have identical contents.
203 Case is significant, but text properties are ignored.
204 Symbols are also allowed; their print names are used instead. */)
205 (register Lisp_Object s1
, Lisp_Object s2
)
208 s1
= SYMBOL_NAME (s1
);
210 s2
= SYMBOL_NAME (s2
);
214 if (SCHARS (s1
) != SCHARS (s2
)
215 || SBYTES (s1
) != SBYTES (s2
)
216 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
221 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
222 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
223 The arguments START1, END1, START2, and END2, if non-nil, are
224 positions specifying which parts of STR1 or STR2 to compare. In
225 string STR1, compare the part between START1 (inclusive) and END1
226 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
227 the string; if END1 is nil, it defaults to the length of the string.
228 Likewise, in string STR2, compare the part between START2 and END2.
230 The strings are compared by the numeric values of their characters.
231 For instance, STR1 is "less than" STR2 if its first differing
232 character has a smaller numeric value. If IGNORE-CASE is non-nil,
233 characters are converted to lower-case before comparing them. Unibyte
234 strings are converted to multibyte for comparison.
236 The value is t if the strings (or specified portions) match.
237 If string STR1 is less, the value is a negative number N;
238 - 1 - N is the number of characters that match at the beginning.
239 If string STR1 is greater, the value is a positive number N;
240 N - 1 is the number of characters that match at the beginning. */)
241 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
243 register ptrdiff_t end1_char
, end2_char
;
244 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
249 start1
= make_number (0);
251 start2
= make_number (0);
252 CHECK_NATNUM (start1
);
253 CHECK_NATNUM (start2
);
259 end1_char
= SCHARS (str1
);
260 if (! NILP (end1
) && end1_char
> XINT (end1
))
261 end1_char
= XINT (end1
);
262 if (end1_char
< XINT (start1
))
263 args_out_of_range (str1
, start1
);
265 end2_char
= SCHARS (str2
);
266 if (! NILP (end2
) && end2_char
> XINT (end2
))
267 end2_char
= XINT (end2
);
268 if (end2_char
< XINT (start2
))
269 args_out_of_range (str2
, start2
);
274 i1_byte
= string_char_to_byte (str1
, i1
);
275 i2_byte
= string_char_to_byte (str2
, i2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
287 c1
= SREF (str1
, i1
++);
288 MAKE_CHAR_MULTIBYTE (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
295 c2
= SREF (str2
, i2
++);
296 MAKE_CHAR_MULTIBYTE (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
+ XINT (start1
));
321 return make_number (i1
- XINT (start1
));
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 doc
: /* Return t if first arg string is less than second in lexicographic order.
335 Symbols are also allowed; their print names are used instead. */)
336 (register Lisp_Object s1
, Lisp_Object s2
)
338 register ptrdiff_t end
;
339 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
342 s1
= SYMBOL_NAME (s1
);
344 s2
= SYMBOL_NAME (s2
);
348 i1
= i1_byte
= i2
= i2_byte
= 0;
351 if (end
> SCHARS (s2
))
356 /* When we find a mismatch, we must compare the
357 characters, not just the bytes. */
360 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
361 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
364 return c1
< c2
? Qt
: Qnil
;
366 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
369 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
370 enum Lisp_Type target_type
, bool last_special
);
374 concat2 (Lisp_Object s1
, Lisp_Object s2
)
379 return concat (2, args
, Lisp_String
, 0);
384 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
390 return concat (3, args
, Lisp_String
, 0);
393 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
394 doc
: /* Concatenate all the arguments and make the result a list.
395 The result is a list whose elements are the elements of all the arguments.
396 Each argument may be a list, vector or string.
397 The last argument is not copied, just used as the tail of the new list.
398 usage: (append &rest SEQUENCES) */)
399 (ptrdiff_t nargs
, Lisp_Object
*args
)
401 return concat (nargs
, args
, Lisp_Cons
, 1);
404 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
405 doc
: /* Concatenate all the arguments and make the result a string.
406 The result is a string whose elements are the elements of all the arguments.
407 Each argument may be a string or a list or vector of characters (integers).
408 usage: (concat &rest SEQUENCES) */)
409 (ptrdiff_t nargs
, Lisp_Object
*args
)
411 return concat (nargs
, args
, Lisp_String
, 0);
414 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
415 doc
: /* Concatenate all the arguments and make the result a vector.
416 The result is a vector whose elements are the elements of all the arguments.
417 Each argument may be a list, vector or string.
418 usage: (vconcat &rest SEQUENCES) */)
419 (ptrdiff_t nargs
, Lisp_Object
*args
)
421 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
425 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
426 doc
: /* Return a copy of a list, vector, string or char-table.
427 The elements of a list or vector are not copied; they are shared
428 with the original. */)
431 if (NILP (arg
)) return arg
;
433 if (CHAR_TABLE_P (arg
))
435 return copy_char_table (arg
);
438 if (BOOL_VECTOR_P (arg
))
441 ptrdiff_t size_in_chars
442 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
443 / BOOL_VECTOR_BITS_PER_CHAR
);
445 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
446 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
451 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
452 wrong_type_argument (Qsequencep
, arg
);
454 return concat (1, &arg
, XTYPE (arg
), 0);
457 /* This structure holds information of an argument of `concat' that is
458 a string and has text properties to be copied. */
461 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
462 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
463 ptrdiff_t to
; /* refer to VAL (the target string) */
467 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
468 enum Lisp_Type target_type
, bool last_special
)
474 ptrdiff_t toindex_byte
= 0;
475 EMACS_INT result_len
;
476 EMACS_INT result_len_byte
;
478 Lisp_Object last_tail
;
481 /* When we make a multibyte string, we can't copy text properties
482 while concatenating each string because the length of resulting
483 string can't be decided until we finish the whole concatenation.
484 So, we record strings that have text properties to be copied
485 here, and copy the text properties after the concatenation. */
486 struct textprop_rec
*textprops
= NULL
;
487 /* Number of elements in textprops. */
488 ptrdiff_t num_textprops
= 0;
493 /* In append, the last arg isn't treated like the others */
494 if (last_special
&& nargs
> 0)
497 last_tail
= args
[nargs
];
502 /* Check each argument. */
503 for (argnum
= 0; argnum
< nargs
; argnum
++)
506 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
507 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
508 wrong_type_argument (Qsequencep
, this);
511 /* Compute total length in chars of arguments in RESULT_LEN.
512 If desired output is a string, also compute length in bytes
513 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
514 whether the result should be a multibyte string. */
518 for (argnum
= 0; argnum
< nargs
; argnum
++)
522 len
= XFASTINT (Flength (this));
523 if (target_type
== Lisp_String
)
525 /* We must count the number of bytes needed in the string
526 as well as the number of characters. */
530 ptrdiff_t this_len_byte
;
532 if (VECTORP (this) || COMPILEDP (this))
533 for (i
= 0; i
< len
; i
++)
536 CHECK_CHARACTER (ch
);
538 this_len_byte
= CHAR_BYTES (c
);
539 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
541 result_len_byte
+= this_len_byte
;
542 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
545 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
546 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
547 else if (CONSP (this))
548 for (; CONSP (this); this = XCDR (this))
551 CHECK_CHARACTER (ch
);
553 this_len_byte
= CHAR_BYTES (c
);
554 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
556 result_len_byte
+= this_len_byte
;
557 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
560 else if (STRINGP (this))
562 if (STRING_MULTIBYTE (this))
565 this_len_byte
= SBYTES (this);
568 this_len_byte
= count_size_as_multibyte (SDATA (this),
570 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
572 result_len_byte
+= this_len_byte
;
577 if (MOST_POSITIVE_FIXNUM
< result_len
)
578 memory_full (SIZE_MAX
);
581 if (! some_multibyte
)
582 result_len_byte
= result_len
;
584 /* Create the output object. */
585 if (target_type
== Lisp_Cons
)
586 val
= Fmake_list (make_number (result_len
), Qnil
);
587 else if (target_type
== Lisp_Vectorlike
)
588 val
= Fmake_vector (make_number (result_len
), Qnil
);
589 else if (some_multibyte
)
590 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
592 val
= make_uninit_string (result_len
);
594 /* In `append', if all but last arg are nil, return last arg. */
595 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
598 /* Copy the contents of the args into the result. */
600 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
602 toindex
= 0, toindex_byte
= 0;
606 SAFE_NALLOCA (textprops
, 1, nargs
);
608 for (argnum
= 0; argnum
< nargs
; argnum
++)
611 ptrdiff_t thisleni
= 0;
612 register ptrdiff_t thisindex
= 0;
613 register ptrdiff_t thisindex_byte
= 0;
617 thislen
= Flength (this), thisleni
= XINT (thislen
);
619 /* Between strings of the same kind, copy fast. */
620 if (STRINGP (this) && STRINGP (val
)
621 && STRING_MULTIBYTE (this) == some_multibyte
)
623 ptrdiff_t thislen_byte
= SBYTES (this);
625 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
626 if (string_intervals (this))
628 textprops
[num_textprops
].argnum
= argnum
;
629 textprops
[num_textprops
].from
= 0;
630 textprops
[num_textprops
++].to
= toindex
;
632 toindex_byte
+= thislen_byte
;
635 /* Copy a single-byte string to a multibyte string. */
636 else if (STRINGP (this) && STRINGP (val
))
638 if (string_intervals (this))
640 textprops
[num_textprops
].argnum
= argnum
;
641 textprops
[num_textprops
].from
= 0;
642 textprops
[num_textprops
++].to
= toindex
;
644 toindex_byte
+= copy_text (SDATA (this),
645 SDATA (val
) + toindex_byte
,
646 SCHARS (this), 0, 1);
650 /* Copy element by element. */
653 register Lisp_Object elt
;
655 /* Fetch next element of `this' arg into `elt', or break if
656 `this' is exhausted. */
657 if (NILP (this)) break;
659 elt
= XCAR (this), this = XCDR (this);
660 else if (thisindex
>= thisleni
)
662 else if (STRINGP (this))
665 if (STRING_MULTIBYTE (this))
666 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
671 c
= SREF (this, thisindex
); thisindex
++;
672 if (some_multibyte
&& !ASCII_CHAR_P (c
))
673 c
= BYTE8_TO_CHAR (c
);
675 XSETFASTINT (elt
, c
);
677 else if (BOOL_VECTOR_P (this))
680 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
681 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
689 elt
= AREF (this, thisindex
);
693 /* Store this element into the result. */
700 else if (VECTORP (val
))
702 ASET (val
, toindex
, elt
);
708 CHECK_CHARACTER (elt
);
711 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
713 SSET (val
, toindex_byte
++, c
);
719 XSETCDR (prev
, last_tail
);
721 if (num_textprops
> 0)
724 ptrdiff_t last_to_end
= -1;
726 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
728 this = args
[textprops
[argnum
].argnum
];
729 props
= text_property_list (this,
731 make_number (SCHARS (this)),
733 /* If successive arguments have properties, be sure that the
734 value of `composition' property be the copy. */
735 if (last_to_end
== textprops
[argnum
].to
)
736 make_composition_value_copy (props
);
737 add_text_properties_from_list (val
, props
,
738 make_number (textprops
[argnum
].to
));
739 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
747 static Lisp_Object string_char_byte_cache_string
;
748 static ptrdiff_t string_char_byte_cache_charpos
;
749 static ptrdiff_t string_char_byte_cache_bytepos
;
752 clear_string_char_byte_cache (void)
754 string_char_byte_cache_string
= Qnil
;
757 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
760 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
763 ptrdiff_t best_below
, best_below_byte
;
764 ptrdiff_t best_above
, best_above_byte
;
766 best_below
= best_below_byte
= 0;
767 best_above
= SCHARS (string
);
768 best_above_byte
= SBYTES (string
);
769 if (best_above
== best_above_byte
)
772 if (EQ (string
, string_char_byte_cache_string
))
774 if (string_char_byte_cache_charpos
< char_index
)
776 best_below
= string_char_byte_cache_charpos
;
777 best_below_byte
= string_char_byte_cache_bytepos
;
781 best_above
= string_char_byte_cache_charpos
;
782 best_above_byte
= string_char_byte_cache_bytepos
;
786 if (char_index
- best_below
< best_above
- char_index
)
788 unsigned char *p
= SDATA (string
) + best_below_byte
;
790 while (best_below
< char_index
)
792 p
+= BYTES_BY_CHAR_HEAD (*p
);
795 i_byte
= p
- SDATA (string
);
799 unsigned char *p
= SDATA (string
) + best_above_byte
;
801 while (best_above
> char_index
)
804 while (!CHAR_HEAD_P (*p
)) p
--;
807 i_byte
= p
- SDATA (string
);
810 string_char_byte_cache_bytepos
= i_byte
;
811 string_char_byte_cache_charpos
= char_index
;
812 string_char_byte_cache_string
= string
;
817 /* Return the character index corresponding to BYTE_INDEX in STRING. */
820 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
823 ptrdiff_t best_below
, best_below_byte
;
824 ptrdiff_t best_above
, best_above_byte
;
826 best_below
= best_below_byte
= 0;
827 best_above
= SCHARS (string
);
828 best_above_byte
= SBYTES (string
);
829 if (best_above
== best_above_byte
)
832 if (EQ (string
, string_char_byte_cache_string
))
834 if (string_char_byte_cache_bytepos
< byte_index
)
836 best_below
= string_char_byte_cache_charpos
;
837 best_below_byte
= string_char_byte_cache_bytepos
;
841 best_above
= string_char_byte_cache_charpos
;
842 best_above_byte
= string_char_byte_cache_bytepos
;
846 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
848 unsigned char *p
= SDATA (string
) + best_below_byte
;
849 unsigned char *pend
= SDATA (string
) + byte_index
;
853 p
+= BYTES_BY_CHAR_HEAD (*p
);
857 i_byte
= p
- SDATA (string
);
861 unsigned char *p
= SDATA (string
) + best_above_byte
;
862 unsigned char *pbeg
= SDATA (string
) + byte_index
;
867 while (!CHAR_HEAD_P (*p
)) p
--;
871 i_byte
= p
- SDATA (string
);
874 string_char_byte_cache_bytepos
= i_byte
;
875 string_char_byte_cache_charpos
= i
;
876 string_char_byte_cache_string
= string
;
881 /* Convert STRING to a multibyte string. */
884 string_make_multibyte (Lisp_Object string
)
891 if (STRING_MULTIBYTE (string
))
894 nbytes
= count_size_as_multibyte (SDATA (string
),
896 /* If all the chars are ASCII, they won't need any more bytes
897 once converted. In that case, we can return STRING itself. */
898 if (nbytes
== SBYTES (string
))
901 buf
= SAFE_ALLOCA (nbytes
);
902 copy_text (SDATA (string
), buf
, SBYTES (string
),
905 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
912 /* Convert STRING (if unibyte) to a multibyte string without changing
913 the number of characters. Characters 0200 trough 0237 are
914 converted to eight-bit characters. */
917 string_to_multibyte (Lisp_Object string
)
924 if (STRING_MULTIBYTE (string
))
927 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
928 /* If all the chars are ASCII, they won't need any more bytes once
930 if (nbytes
== SBYTES (string
))
931 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
933 buf
= SAFE_ALLOCA (nbytes
);
934 memcpy (buf
, SDATA (string
), SBYTES (string
));
935 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
937 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
944 /* Convert STRING to a single-byte string. */
947 string_make_unibyte (Lisp_Object string
)
954 if (! STRING_MULTIBYTE (string
))
957 nchars
= SCHARS (string
);
959 buf
= SAFE_ALLOCA (nchars
);
960 copy_text (SDATA (string
), buf
, SBYTES (string
),
963 ret
= make_unibyte_string ((char *) buf
, nchars
);
969 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
971 doc
: /* Return the multibyte equivalent of STRING.
972 If STRING is unibyte and contains non-ASCII characters, the function
973 `unibyte-char-to-multibyte' is used to convert each unibyte character
974 to a multibyte character. In this case, the returned string is a
975 newly created string with no text properties. If STRING is multibyte
976 or entirely ASCII, it is returned unchanged. In particular, when
977 STRING is unibyte and entirely ASCII, the returned string is unibyte.
978 \(When the characters are all ASCII, Emacs primitives will treat the
979 string the same way whether it is unibyte or multibyte.) */)
982 CHECK_STRING (string
);
984 return string_make_multibyte (string
);
987 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
989 doc
: /* Return the unibyte equivalent of STRING.
990 Multibyte character codes are converted to unibyte according to
991 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
992 If the lookup in the translation table fails, this function takes just
993 the low 8 bits of each character. */)
996 CHECK_STRING (string
);
998 return string_make_unibyte (string
);
1001 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1003 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1004 If STRING is unibyte, the result is STRING itself.
1005 Otherwise it is a newly created string, with no text properties.
1006 If STRING is multibyte and contains a character of charset
1007 `eight-bit', it is converted to the corresponding single byte. */)
1008 (Lisp_Object string
)
1010 CHECK_STRING (string
);
1012 if (STRING_MULTIBYTE (string
))
1014 ptrdiff_t bytes
= SBYTES (string
);
1015 unsigned char *str
= xmalloc (bytes
);
1017 memcpy (str
, SDATA (string
), bytes
);
1018 bytes
= str_as_unibyte (str
, bytes
);
1019 string
= make_unibyte_string ((char *) str
, bytes
);
1025 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1027 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1028 If STRING is multibyte, the result is STRING itself.
1029 Otherwise it is a newly created string, with no text properties.
1031 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1032 part of a correct utf-8 sequence), it is converted to the corresponding
1033 multibyte character of charset `eight-bit'.
1034 See also `string-to-multibyte'.
1036 Beware, this often doesn't really do what you think it does.
1037 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1038 If you're not sure, whether to use `string-as-multibyte' or
1039 `string-to-multibyte', use `string-to-multibyte'. */)
1040 (Lisp_Object string
)
1042 CHECK_STRING (string
);
1044 if (! STRING_MULTIBYTE (string
))
1046 Lisp_Object new_string
;
1047 ptrdiff_t nchars
, nbytes
;
1049 parse_str_as_multibyte (SDATA (string
),
1052 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1053 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1054 if (nbytes
!= SBYTES (string
))
1055 str_as_multibyte (SDATA (new_string
), nbytes
,
1056 SBYTES (string
), NULL
);
1057 string
= new_string
;
1058 set_string_intervals (string
, NULL
);
1063 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1065 doc
: /* Return a multibyte string with the same individual chars as STRING.
1066 If STRING is multibyte, the result is STRING itself.
1067 Otherwise it is a newly created string, with no text properties.
1069 If STRING is unibyte and contains an 8-bit byte, it is converted to
1070 the corresponding multibyte character of charset `eight-bit'.
1072 This differs from `string-as-multibyte' by converting each byte of a correct
1073 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1074 correct sequence. */)
1075 (Lisp_Object string
)
1077 CHECK_STRING (string
);
1079 return string_to_multibyte (string
);
1082 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1084 doc
: /* Return a unibyte string with the same individual chars as STRING.
1085 If STRING is unibyte, the result is STRING itself.
1086 Otherwise it is a newly created string, with no text properties,
1087 where each `eight-bit' character is converted to the corresponding byte.
1088 If STRING contains a non-ASCII, non-`eight-bit' character,
1089 an error is signaled. */)
1090 (Lisp_Object string
)
1092 CHECK_STRING (string
);
1094 if (STRING_MULTIBYTE (string
))
1096 ptrdiff_t chars
= SCHARS (string
);
1097 unsigned char *str
= xmalloc (chars
);
1098 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1100 if (converted
< chars
)
1101 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1102 string
= make_unibyte_string ((char *) str
, chars
);
1109 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1110 doc
: /* Return a copy of ALIST.
1111 This is an alist which represents the same mapping from objects to objects,
1112 but does not share the alist structure with ALIST.
1113 The objects mapped (cars and cdrs of elements of the alist)
1114 are shared, however.
1115 Elements of ALIST that are not conses are also shared. */)
1118 register Lisp_Object tem
;
1123 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1124 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1126 register Lisp_Object car
;
1130 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1135 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1136 doc
: /* Return a new string whose contents are a substring of STRING.
1137 The returned string consists of the characters between index FROM
1138 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1139 zero-indexed: 0 means the first character of STRING. Negative values
1140 are counted from the end of STRING. If TO is nil, the substring runs
1141 to the end of STRING.
1143 The STRING argument may also be a vector. In that case, the return
1144 value is a new vector that contains the elements between index FROM
1145 \(inclusive) and index TO (exclusive) of that vector argument. */)
1146 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1150 EMACS_INT from_char
, to_char
;
1152 CHECK_VECTOR_OR_STRING (string
);
1153 CHECK_NUMBER (from
);
1155 if (STRINGP (string
))
1156 size
= SCHARS (string
);
1158 size
= ASIZE (string
);
1166 to_char
= XINT (to
);
1171 from_char
= XINT (from
);
1174 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1175 args_out_of_range_3 (string
, make_number (from_char
),
1176 make_number (to_char
));
1178 if (STRINGP (string
))
1181 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1182 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1183 res
= make_specified_string (SSDATA (string
) + from_byte
,
1184 to_char
- from_char
, to_byte
- from_byte
,
1185 STRING_MULTIBYTE (string
));
1186 copy_text_properties (make_number (from_char
), make_number (to_char
),
1187 string
, make_number (0), res
, Qnil
);
1190 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1196 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1197 doc
: /* Return a substring of STRING, without text properties.
1198 It starts at index FROM and ends before TO.
1199 TO may be nil or omitted; then the substring runs to the end of STRING.
1200 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1201 If FROM or TO is negative, it counts from the end.
1203 With one argument, just copy STRING without its properties. */)
1204 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1207 EMACS_INT from_char
, to_char
;
1208 ptrdiff_t from_byte
, to_byte
;
1210 CHECK_STRING (string
);
1212 size
= SCHARS (string
);
1218 CHECK_NUMBER (from
);
1219 from_char
= XINT (from
);
1229 to_char
= XINT (to
);
1234 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1235 args_out_of_range_3 (string
, make_number (from_char
),
1236 make_number (to_char
));
1238 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1240 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1241 return make_specified_string (SSDATA (string
) + from_byte
,
1242 to_char
- from_char
, to_byte
- from_byte
,
1243 STRING_MULTIBYTE (string
));
1246 /* Extract a substring of STRING, giving start and end positions
1247 both in characters and in bytes. */
1250 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1251 ptrdiff_t to
, ptrdiff_t to_byte
)
1256 CHECK_VECTOR_OR_STRING (string
);
1258 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1260 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1261 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1263 if (STRINGP (string
))
1265 res
= make_specified_string (SSDATA (string
) + from_byte
,
1266 to
- from
, to_byte
- from_byte
,
1267 STRING_MULTIBYTE (string
));
1268 copy_text_properties (make_number (from
), make_number (to
),
1269 string
, make_number (0), res
, Qnil
);
1272 res
= Fvector (to
- from
, aref_addr (string
, from
));
1277 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1278 doc
: /* Take cdr N times on LIST, return the result. */)
1279 (Lisp_Object n
, Lisp_Object list
)
1284 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1287 CHECK_LIST_CONS (list
, list
);
1293 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1294 doc
: /* Return the Nth element of LIST.
1295 N counts from zero. If LIST is not that long, nil is returned. */)
1296 (Lisp_Object n
, Lisp_Object list
)
1298 return Fcar (Fnthcdr (n
, list
));
1301 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1302 doc
: /* Return element of SEQUENCE at index N. */)
1303 (register Lisp_Object sequence
, Lisp_Object n
)
1306 if (CONSP (sequence
) || NILP (sequence
))
1307 return Fcar (Fnthcdr (n
, sequence
));
1309 /* Faref signals a "not array" error, so check here. */
1310 CHECK_ARRAY (sequence
, Qsequencep
);
1311 return Faref (sequence
, n
);
1314 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1315 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1316 The value is actually the tail of LIST whose car is ELT. */)
1317 (register Lisp_Object elt
, Lisp_Object list
)
1319 register Lisp_Object tail
;
1320 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1322 register Lisp_Object tem
;
1323 CHECK_LIST_CONS (tail
, list
);
1325 if (! NILP (Fequal (elt
, tem
)))
1332 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1333 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1334 The value is actually the tail of LIST whose car is ELT. */)
1335 (register Lisp_Object elt
, Lisp_Object list
)
1339 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1343 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1347 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1358 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1359 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1360 The value is actually the tail of LIST whose car is ELT. */)
1361 (register Lisp_Object elt
, Lisp_Object list
)
1363 register Lisp_Object tail
;
1366 return Fmemq (elt
, list
);
1368 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1370 register Lisp_Object tem
;
1371 CHECK_LIST_CONS (tail
, list
);
1373 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1380 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1381 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1382 The value is actually the first element of LIST whose car is KEY.
1383 Elements of LIST that are not conses are ignored. */)
1384 (Lisp_Object key
, Lisp_Object list
)
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1395 || (CONSP (XCAR (list
))
1396 && EQ (XCAR (XCAR (list
)), key
)))
1401 || (CONSP (XCAR (list
))
1402 && EQ (XCAR (XCAR (list
)), key
)))
1412 /* Like Fassq but never report an error and do not allow quits.
1413 Use only on lists known never to be circular. */
1416 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1419 && (!CONSP (XCAR (list
))
1420 || !EQ (XCAR (XCAR (list
)), key
)))
1423 return CAR_SAFE (list
);
1426 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1427 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1428 The value is actually the first element of LIST whose car equals KEY. */)
1429 (Lisp_Object key
, Lisp_Object list
)
1436 || (CONSP (XCAR (list
))
1437 && (car
= XCAR (XCAR (list
)),
1438 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1443 || (CONSP (XCAR (list
))
1444 && (car
= XCAR (XCAR (list
)),
1445 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1450 || (CONSP (XCAR (list
))
1451 && (car
= XCAR (XCAR (list
)),
1452 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1462 /* Like Fassoc but never report an error and do not allow quits.
1463 Use only on lists known never to be circular. */
1466 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1469 && (!CONSP (XCAR (list
))
1470 || (!EQ (XCAR (XCAR (list
)), key
)
1471 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1474 return CONSP (list
) ? XCAR (list
) : Qnil
;
1477 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1478 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1479 The value is actually the first element of LIST whose cdr is KEY. */)
1480 (register Lisp_Object key
, Lisp_Object list
)
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCDR (XCAR (list
)), key
)))
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCDR (XCAR (list
)), key
)))
1497 || (CONSP (XCAR (list
))
1498 && EQ (XCDR (XCAR (list
)), key
)))
1508 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1509 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1510 The value is actually the first element of LIST whose cdr equals KEY. */)
1511 (Lisp_Object key
, Lisp_Object list
)
1518 || (CONSP (XCAR (list
))
1519 && (cdr
= XCDR (XCAR (list
)),
1520 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1525 || (CONSP (XCAR (list
))
1526 && (cdr
= XCDR (XCAR (list
)),
1527 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1532 || (CONSP (XCAR (list
))
1533 && (cdr
= XCDR (XCAR (list
)),
1534 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1544 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1545 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1546 More precisely, this function skips any members `eq' to ELT at the
1547 front of LIST, then removes members `eq' to ELT from the remaining
1548 sublist by modifying its list structure, then returns the resulting
1551 Write `(setq foo (delq element foo))' to be sure of correctly changing
1552 the value of a list `foo'. */)
1553 (register Lisp_Object elt
, Lisp_Object list
)
1555 register Lisp_Object tail
, prev
;
1556 register Lisp_Object tem
;
1560 while (CONSP (tail
))
1562 CHECK_LIST_CONS (tail
, list
);
1569 Fsetcdr (prev
, XCDR (tail
));
1579 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1580 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1581 SEQ must be a sequence (i.e. a list, a vector, or a string).
1582 The return value is a sequence of the same type.
1584 If SEQ is a list, this behaves like `delq', except that it compares
1585 with `equal' instead of `eq'. In particular, it may remove elements
1586 by altering the list structure.
1588 If SEQ is not a list, deletion is never performed destructively;
1589 instead this function creates and returns a new vector or string.
1591 Write `(setq foo (delete element foo))' to be sure of correctly
1592 changing the value of a sequence `foo'. */)
1593 (Lisp_Object elt
, Lisp_Object seq
)
1599 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1600 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1603 if (n
!= ASIZE (seq
))
1605 struct Lisp_Vector
*p
= allocate_vector (n
);
1607 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1608 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1609 p
->contents
[n
++] = AREF (seq
, i
);
1611 XSETVECTOR (seq
, p
);
1614 else if (STRINGP (seq
))
1616 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1619 for (i
= nchars
= nbytes
= ibyte
= 0;
1621 ++i
, ibyte
+= cbytes
)
1623 if (STRING_MULTIBYTE (seq
))
1625 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1626 cbytes
= CHAR_BYTES (c
);
1634 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1641 if (nchars
!= SCHARS (seq
))
1645 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1646 if (!STRING_MULTIBYTE (seq
))
1647 STRING_SET_UNIBYTE (tem
);
1649 for (i
= nchars
= nbytes
= ibyte
= 0;
1651 ++i
, ibyte
+= cbytes
)
1653 if (STRING_MULTIBYTE (seq
))
1655 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1656 cbytes
= CHAR_BYTES (c
);
1664 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1666 unsigned char *from
= SDATA (seq
) + ibyte
;
1667 unsigned char *to
= SDATA (tem
) + nbytes
;
1673 for (n
= cbytes
; n
--; )
1683 Lisp_Object tail
, prev
;
1685 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1687 CHECK_LIST_CONS (tail
, seq
);
1689 if (!NILP (Fequal (elt
, XCAR (tail
))))
1694 Fsetcdr (prev
, XCDR (tail
));
1705 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1706 doc
: /* Reverse LIST by modifying cdr pointers.
1707 Return the reversed list. Expects a properly nil-terminated list. */)
1710 register Lisp_Object prev
, tail
, next
;
1712 if (NILP (list
)) return list
;
1715 while (!NILP (tail
))
1718 CHECK_LIST_CONS (tail
, tail
);
1720 Fsetcdr (tail
, prev
);
1727 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1728 doc
: /* Reverse LIST, copying. Return the reversed list.
1729 See also the function `nreverse', which is used more often. */)
1734 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1737 new = Fcons (XCAR (list
), new);
1739 CHECK_LIST_END (list
, list
);
1743 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1745 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1746 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1747 Returns the sorted list. LIST is modified by side effects.
1748 PREDICATE is called with two elements of LIST, and should return non-nil
1749 if the first element should sort before the second. */)
1750 (Lisp_Object list
, Lisp_Object predicate
)
1752 Lisp_Object front
, back
;
1753 register Lisp_Object len
, tem
;
1754 struct gcpro gcpro1
, gcpro2
;
1758 len
= Flength (list
);
1759 length
= XINT (len
);
1763 XSETINT (len
, (length
/ 2) - 1);
1764 tem
= Fnthcdr (len
, list
);
1766 Fsetcdr (tem
, Qnil
);
1768 GCPRO2 (front
, back
);
1769 front
= Fsort (front
, predicate
);
1770 back
= Fsort (back
, predicate
);
1772 return merge (front
, back
, predicate
);
1776 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1779 register Lisp_Object tail
;
1781 register Lisp_Object l1
, l2
;
1782 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1789 /* It is sufficient to protect org_l1 and org_l2.
1790 When l1 and l2 are updated, we copy the new values
1791 back into the org_ vars. */
1792 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1812 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1828 Fsetcdr (tail
, tem
);
1834 /* This does not check for quits. That is safe since it must terminate. */
1836 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1837 doc
: /* Extract a value from a property list.
1838 PLIST is a property list, which is a list of the form
1839 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1840 corresponding to the given PROP, or nil if PROP is not one of the
1841 properties on the list. This function never signals an error. */)
1842 (Lisp_Object plist
, Lisp_Object prop
)
1844 Lisp_Object tail
, halftail
;
1846 /* halftail is used to detect circular lists. */
1847 tail
= halftail
= plist
;
1848 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1850 if (EQ (prop
, XCAR (tail
)))
1851 return XCAR (XCDR (tail
));
1853 tail
= XCDR (XCDR (tail
));
1854 halftail
= XCDR (halftail
);
1855 if (EQ (tail
, halftail
))
1862 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1863 doc
: /* Return the value of SYMBOL's PROPNAME property.
1864 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1865 (Lisp_Object symbol
, Lisp_Object propname
)
1867 CHECK_SYMBOL (symbol
);
1868 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1871 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1872 doc
: /* Change value in PLIST of PROP to VAL.
1873 PLIST is a property list, which is a list of the form
1874 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1875 If PROP is already a property on the list, its value is set to VAL,
1876 otherwise the new PROP VAL pair is added. The new plist is returned;
1877 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1878 The PLIST is modified by side effects. */)
1879 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1881 register Lisp_Object tail
, prev
;
1882 Lisp_Object newcell
;
1884 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1885 tail
= XCDR (XCDR (tail
)))
1887 if (EQ (prop
, XCAR (tail
)))
1889 Fsetcar (XCDR (tail
), val
);
1896 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1900 Fsetcdr (XCDR (prev
), newcell
);
1904 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1905 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1906 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1907 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1909 CHECK_SYMBOL (symbol
);
1911 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1915 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1916 doc
: /* Extract a value from a property list, comparing with `equal'.
1917 PLIST is a property list, which is a list of the form
1918 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1919 corresponding to the given PROP, or nil if PROP is not
1920 one of the properties on the list. */)
1921 (Lisp_Object plist
, Lisp_Object prop
)
1926 CONSP (tail
) && CONSP (XCDR (tail
));
1927 tail
= XCDR (XCDR (tail
)))
1929 if (! NILP (Fequal (prop
, XCAR (tail
))))
1930 return XCAR (XCDR (tail
));
1935 CHECK_LIST_END (tail
, prop
);
1940 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1941 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1942 PLIST is a property list, which is a list of the form
1943 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1944 If PROP is already a property on the list, its value is set to VAL,
1945 otherwise the new PROP VAL pair is added. The new plist is returned;
1946 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1947 The PLIST is modified by side effects. */)
1948 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1950 register Lisp_Object tail
, prev
;
1951 Lisp_Object newcell
;
1953 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1954 tail
= XCDR (XCDR (tail
)))
1956 if (! NILP (Fequal (prop
, XCAR (tail
))))
1958 Fsetcar (XCDR (tail
), val
);
1965 newcell
= list2 (prop
, val
);
1969 Fsetcdr (XCDR (prev
), newcell
);
1973 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1974 doc
: /* Return t if the two args are the same Lisp object.
1975 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1976 (Lisp_Object obj1
, Lisp_Object obj2
)
1979 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1981 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1984 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1985 doc
: /* Return t if two Lisp objects have similar structure and contents.
1986 They must have the same data type.
1987 Conses are compared by comparing the cars and the cdrs.
1988 Vectors and strings are compared element by element.
1989 Numbers are compared by value, but integers cannot equal floats.
1990 (Use `=' if you want integers and floats to be able to be equal.)
1991 Symbols must match exactly. */)
1992 (register Lisp_Object o1
, Lisp_Object o2
)
1994 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1997 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1998 doc
: /* Return t if two Lisp objects have similar structure and contents.
1999 This is like `equal' except that it compares the text properties
2000 of strings. (`equal' ignores text properties.) */)
2001 (register Lisp_Object o1
, Lisp_Object o2
)
2003 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2006 /* DEPTH is current depth of recursion. Signal an error if it
2008 PROPS means compare string text properties too. */
2011 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
)
2014 error ("Stack overflow in equal");
2020 if (XTYPE (o1
) != XTYPE (o2
))
2029 d1
= extract_float (o1
);
2030 d2
= extract_float (o2
);
2031 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2032 though they are not =. */
2033 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2037 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2044 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2048 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2050 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2053 o1
= XOVERLAY (o1
)->plist
;
2054 o2
= XOVERLAY (o2
)->plist
;
2059 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2060 && (XMARKER (o1
)->buffer
== 0
2061 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2065 case Lisp_Vectorlike
:
2068 ptrdiff_t size
= ASIZE (o1
);
2069 /* Pseudovectors have the type encoded in the size field, so this test
2070 actually checks that the objects have the same type as well as the
2072 if (ASIZE (o2
) != size
)
2074 /* Boolvectors are compared much like strings. */
2075 if (BOOL_VECTOR_P (o1
))
2077 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2079 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2080 ((XBOOL_VECTOR (o1
)->size
2081 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2082 / BOOL_VECTOR_BITS_PER_CHAR
)))
2086 if (WINDOW_CONFIGURATIONP (o1
))
2087 return compare_window_configurations (o1
, o2
, 0);
2089 /* Aside from them, only true vectors, char-tables, compiled
2090 functions, and fonts (font-spec, font-entity, font-object)
2091 are sensible to compare, so eliminate the others now. */
2092 if (size
& PSEUDOVECTOR_FLAG
)
2094 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2097 size
&= PSEUDOVECTOR_SIZE_MASK
;
2099 for (i
= 0; i
< size
; i
++)
2104 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2112 if (SCHARS (o1
) != SCHARS (o2
))
2114 if (SBYTES (o1
) != SBYTES (o2
))
2116 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2118 if (props
&& !compare_string_intervals (o1
, o2
))
2130 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2131 doc
: /* Store each element of ARRAY with ITEM.
2132 ARRAY is a vector, string, char-table, or bool-vector. */)
2133 (Lisp_Object array
, Lisp_Object item
)
2135 register ptrdiff_t size
, idx
;
2137 if (VECTORP (array
))
2138 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2139 ASET (array
, idx
, item
);
2140 else if (CHAR_TABLE_P (array
))
2144 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2145 set_char_table_contents (array
, i
, item
);
2146 set_char_table_defalt (array
, item
);
2148 else if (STRINGP (array
))
2150 register unsigned char *p
= SDATA (array
);
2152 CHECK_CHARACTER (item
);
2153 charval
= XFASTINT (item
);
2154 size
= SCHARS (array
);
2155 if (STRING_MULTIBYTE (array
))
2157 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2158 int len
= CHAR_STRING (charval
, str
);
2159 ptrdiff_t size_byte
= SBYTES (array
);
2161 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2162 || SCHARS (array
) * len
!= size_byte
)
2163 error ("Attempt to change byte length of a string");
2164 for (idx
= 0; idx
< size_byte
; idx
++)
2165 *p
++ = str
[idx
% len
];
2168 for (idx
= 0; idx
< size
; idx
++)
2171 else if (BOOL_VECTOR_P (array
))
2173 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2175 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2176 / BOOL_VECTOR_BITS_PER_CHAR
);
2180 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2182 /* Clear any extraneous bits in the last byte. */
2183 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2187 wrong_type_argument (Qarrayp
, array
);
2191 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2193 doc
: /* Clear the contents of STRING.
2194 This makes STRING unibyte and may change its length. */)
2195 (Lisp_Object string
)
2198 CHECK_STRING (string
);
2199 len
= SBYTES (string
);
2200 memset (SDATA (string
), 0, len
);
2201 STRING_SET_CHARS (string
, len
);
2202 STRING_SET_UNIBYTE (string
);
2208 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2210 Lisp_Object args
[2];
2213 return Fnconc (2, args
);
2216 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2217 doc
: /* Concatenate any number of lists by altering them.
2218 Only the last argument is not altered, and need not be a list.
2219 usage: (nconc &rest LISTS) */)
2220 (ptrdiff_t nargs
, Lisp_Object
*args
)
2223 register Lisp_Object tail
, tem
, val
;
2227 for (argnum
= 0; argnum
< nargs
; argnum
++)
2230 if (NILP (tem
)) continue;
2235 if (argnum
+ 1 == nargs
) break;
2237 CHECK_LIST_CONS (tem
, tem
);
2246 tem
= args
[argnum
+ 1];
2247 Fsetcdr (tail
, tem
);
2249 args
[argnum
+ 1] = tail
;
2255 /* This is the guts of all mapping functions.
2256 Apply FN to each element of SEQ, one by one,
2257 storing the results into elements of VALS, a C vector of Lisp_Objects.
2258 LENI is the length of VALS, which should also be the length of SEQ. */
2261 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2263 register Lisp_Object tail
;
2265 register EMACS_INT i
;
2266 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2270 /* Don't let vals contain any garbage when GC happens. */
2271 for (i
= 0; i
< leni
; i
++)
2274 GCPRO3 (dummy
, fn
, seq
);
2276 gcpro1
.nvars
= leni
;
2280 /* We need not explicitly protect `tail' because it is used only on lists, and
2281 1) lists are not relocated and 2) the list is marked via `seq' so will not
2284 if (VECTORP (seq
) || COMPILEDP (seq
))
2286 for (i
= 0; i
< leni
; i
++)
2288 dummy
= call1 (fn
, AREF (seq
, i
));
2293 else if (BOOL_VECTOR_P (seq
))
2295 for (i
= 0; i
< leni
; i
++)
2298 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2299 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2300 dummy
= call1 (fn
, dummy
);
2305 else if (STRINGP (seq
))
2309 for (i
= 0, i_byte
= 0; i
< leni
;)
2312 ptrdiff_t i_before
= i
;
2314 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2315 XSETFASTINT (dummy
, c
);
2316 dummy
= call1 (fn
, dummy
);
2318 vals
[i_before
] = dummy
;
2321 else /* Must be a list, since Flength did not get an error */
2324 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2326 dummy
= call1 (fn
, XCAR (tail
));
2336 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2337 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2338 In between each pair of results, stick in SEPARATOR. Thus, " " as
2339 SEPARATOR results in spaces between the values returned by FUNCTION.
2340 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2341 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2344 register EMACS_INT leni
;
2347 register Lisp_Object
*args
;
2348 struct gcpro gcpro1
;
2352 len
= Flength (sequence
);
2353 if (CHAR_TABLE_P (sequence
))
2354 wrong_type_argument (Qlistp
, sequence
);
2356 nargs
= leni
+ leni
- 1;
2357 if (nargs
< 0) return empty_unibyte_string
;
2359 SAFE_ALLOCA_LISP (args
, nargs
);
2362 mapcar1 (leni
, args
, function
, sequence
);
2365 for (i
= leni
- 1; i
> 0; i
--)
2366 args
[i
+ i
] = args
[i
];
2368 for (i
= 1; i
< nargs
; i
+= 2)
2369 args
[i
] = separator
;
2371 ret
= Fconcat (nargs
, args
);
2377 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2378 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2379 The result is a list just as long as SEQUENCE.
2380 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2381 (Lisp_Object function
, Lisp_Object sequence
)
2383 register Lisp_Object len
;
2384 register EMACS_INT leni
;
2385 register Lisp_Object
*args
;
2389 len
= Flength (sequence
);
2390 if (CHAR_TABLE_P (sequence
))
2391 wrong_type_argument (Qlistp
, sequence
);
2392 leni
= XFASTINT (len
);
2394 SAFE_ALLOCA_LISP (args
, leni
);
2396 mapcar1 (leni
, args
, function
, sequence
);
2398 ret
= Flist (leni
, args
);
2404 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2405 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2406 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2407 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2408 (Lisp_Object function
, Lisp_Object sequence
)
2410 register EMACS_INT leni
;
2412 leni
= XFASTINT (Flength (sequence
));
2413 if (CHAR_TABLE_P (sequence
))
2414 wrong_type_argument (Qlistp
, sequence
);
2415 mapcar1 (leni
, 0, function
, sequence
);
2420 /* This is how C code calls `yes-or-no-p' and allows the user
2423 Anything that calls this function must protect from GC! */
2426 do_yes_or_no_p (Lisp_Object prompt
)
2428 return call1 (intern ("yes-or-no-p"), prompt
);
2431 /* Anything that calls this function must protect from GC! */
2433 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2434 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2435 PROMPT is the string to display to ask the question. It should end in
2436 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2438 The user must confirm the answer with RET, and can edit it until it
2441 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2442 is nil, and `use-dialog-box' is non-nil. */)
2443 (Lisp_Object prompt
)
2445 register Lisp_Object ans
;
2446 Lisp_Object args
[2];
2447 struct gcpro gcpro1
;
2449 CHECK_STRING (prompt
);
2452 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2454 && window_system_available (SELECTED_FRAME ()))
2456 Lisp_Object pane
, menu
, obj
;
2457 redisplay_preserve_echo_area (4);
2458 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2459 Fcons (build_string ("No"), Qnil
));
2461 menu
= Fcons (prompt
, pane
);
2462 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2466 #endif /* HAVE_MENUS */
2469 args
[1] = build_string ("(yes or no) ");
2470 prompt
= Fconcat (2, args
);
2476 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2477 Qyes_or_no_p_history
, Qnil
,
2479 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2484 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2492 message1 ("Please answer yes or no.");
2493 Fsleep_for (make_number (2), Qnil
);
2497 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2498 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2500 Each of the three load averages is multiplied by 100, then converted
2503 When USE-FLOATS is non-nil, floats will be used instead of integers.
2504 These floats are not multiplied by 100.
2506 If the 5-minute or 15-minute load averages are not available, return a
2507 shortened list, containing only those averages which are available.
2509 An error is thrown if the load average can't be obtained. In some
2510 cases making it work would require Emacs being installed setuid or
2511 setgid so that it can read kernel information, and that usually isn't
2513 (Lisp_Object use_floats
)
2516 int loads
= getloadavg (load_ave
, 3);
2517 Lisp_Object ret
= Qnil
;
2520 error ("load-average not implemented for this operating system");
2524 Lisp_Object load
= (NILP (use_floats
)
2525 ? make_number (100.0 * load_ave
[loads
])
2526 : make_float (load_ave
[loads
]));
2527 ret
= Fcons (load
, ret
);
2533 static Lisp_Object Qsubfeatures
;
2535 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2536 doc
: /* Return t if FEATURE is present in this Emacs.
2538 Use this to conditionalize execution of lisp code based on the
2539 presence or absence of Emacs or environment extensions.
2540 Use `provide' to declare that a feature is available. This function
2541 looks at the value of the variable `features'. The optional argument
2542 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2543 (Lisp_Object feature
, Lisp_Object subfeature
)
2545 register Lisp_Object tem
;
2546 CHECK_SYMBOL (feature
);
2547 tem
= Fmemq (feature
, Vfeatures
);
2548 if (!NILP (tem
) && !NILP (subfeature
))
2549 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2550 return (NILP (tem
)) ? Qnil
: Qt
;
2553 static Lisp_Object Qfuncall
;
2555 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2556 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2557 The optional argument SUBFEATURES should be a list of symbols listing
2558 particular subfeatures supported in this version of FEATURE. */)
2559 (Lisp_Object feature
, Lisp_Object subfeatures
)
2561 register Lisp_Object tem
;
2562 CHECK_SYMBOL (feature
);
2563 CHECK_LIST (subfeatures
);
2564 if (!NILP (Vautoload_queue
))
2565 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2567 tem
= Fmemq (feature
, Vfeatures
);
2569 Vfeatures
= Fcons (feature
, Vfeatures
);
2570 if (!NILP (subfeatures
))
2571 Fput (feature
, Qsubfeatures
, subfeatures
);
2572 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2574 /* Run any load-hooks for this file. */
2575 tem
= Fassq (feature
, Vafter_load_alist
);
2577 Fmapc (Qfuncall
, XCDR (tem
));
2582 /* `require' and its subroutines. */
2584 /* List of features currently being require'd, innermost first. */
2586 static Lisp_Object require_nesting_list
;
2589 require_unwind (Lisp_Object old_value
)
2591 require_nesting_list
= old_value
;
2594 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2595 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2596 If FEATURE is not a member of the list `features', then the feature
2597 is not loaded; so load the file FILENAME.
2598 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2599 and `load' will try to load this name appended with the suffix `.elc' or
2600 `.el', in that order. The name without appended suffix will not be used.
2601 See `get-load-suffixes' for the complete list of suffixes.
2602 If the optional third argument NOERROR is non-nil,
2603 then return nil if the file is not found instead of signaling an error.
2604 Normally the return value is FEATURE.
2605 The normal messages at start and end of loading FILENAME are suppressed. */)
2606 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2609 struct gcpro gcpro1
, gcpro2
;
2610 bool from_file
= load_in_progress
;
2612 CHECK_SYMBOL (feature
);
2614 /* Record the presence of `require' in this file
2615 even if the feature specified is already loaded.
2616 But not more than once in any file,
2617 and not when we aren't loading or reading from a file. */
2619 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2620 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2625 tem
= Fcons (Qrequire
, feature
);
2626 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2627 LOADHIST_ATTACH (tem
);
2629 tem
= Fmemq (feature
, Vfeatures
);
2633 ptrdiff_t count
= SPECPDL_INDEX ();
2636 /* This is to make sure that loadup.el gives a clear picture
2637 of what files are preloaded and when. */
2638 if (! NILP (Vpurify_flag
))
2639 error ("(require %s) while preparing to dump",
2640 SDATA (SYMBOL_NAME (feature
)));
2642 /* A certain amount of recursive `require' is legitimate,
2643 but if we require the same feature recursively 3 times,
2645 tem
= require_nesting_list
;
2646 while (! NILP (tem
))
2648 if (! NILP (Fequal (feature
, XCAR (tem
))))
2653 error ("Recursive `require' for feature `%s'",
2654 SDATA (SYMBOL_NAME (feature
)));
2656 /* Update the list for any nested `require's that occur. */
2657 record_unwind_protect (require_unwind
, require_nesting_list
);
2658 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2660 /* Value saved here is to be restored into Vautoload_queue */
2661 record_unwind_protect (un_autoload
, Vautoload_queue
);
2662 Vautoload_queue
= Qt
;
2664 /* Load the file. */
2665 GCPRO2 (feature
, filename
);
2666 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2667 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2670 /* If load failed entirely, return nil. */
2672 return unbind_to (count
, Qnil
);
2674 tem
= Fmemq (feature
, Vfeatures
);
2676 error ("Required feature `%s' was not provided",
2677 SDATA (SYMBOL_NAME (feature
)));
2679 /* Once loading finishes, don't undo it. */
2680 Vautoload_queue
= Qt
;
2681 feature
= unbind_to (count
, feature
);
2687 /* Primitives for work of the "widget" library.
2688 In an ideal world, this section would not have been necessary.
2689 However, lisp function calls being as slow as they are, it turns
2690 out that some functions in the widget library (wid-edit.el) are the
2691 bottleneck of Widget operation. Here is their translation to C,
2692 for the sole reason of efficiency. */
2694 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2695 doc
: /* Return non-nil if PLIST has the property PROP.
2696 PLIST is a property list, which is a list of the form
2697 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2698 Unlike `plist-get', this allows you to distinguish between a missing
2699 property and a property with the value nil.
2700 The value is actually the tail of PLIST whose car is PROP. */)
2701 (Lisp_Object plist
, Lisp_Object prop
)
2703 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2706 plist
= XCDR (plist
);
2707 plist
= CDR (plist
);
2712 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2713 doc
: /* In WIDGET, set PROPERTY to VALUE.
2714 The value can later be retrieved with `widget-get'. */)
2715 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2717 CHECK_CONS (widget
);
2718 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2722 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2723 doc
: /* In WIDGET, get the value of PROPERTY.
2724 The value could either be specified when the widget was created, or
2725 later with `widget-put'. */)
2726 (Lisp_Object widget
, Lisp_Object property
)
2734 CHECK_CONS (widget
);
2735 tmp
= Fplist_member (XCDR (widget
), property
);
2741 tmp
= XCAR (widget
);
2744 widget
= Fget (tmp
, Qwidget_type
);
2748 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2749 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2750 ARGS are passed as extra arguments to the function.
2751 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2752 (ptrdiff_t nargs
, Lisp_Object
*args
)
2754 /* This function can GC. */
2755 Lisp_Object newargs
[3];
2756 struct gcpro gcpro1
, gcpro2
;
2759 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2760 newargs
[1] = args
[0];
2761 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2762 GCPRO2 (newargs
[0], newargs
[2]);
2763 result
= Fapply (3, newargs
);
2768 #ifdef HAVE_LANGINFO_CODESET
2769 #include <langinfo.h>
2772 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2773 doc
: /* Access locale data ITEM for the current C locale, if available.
2774 ITEM should be one of the following:
2776 `codeset', returning the character set as a string (locale item CODESET);
2778 `days', returning a 7-element vector of day names (locale items DAY_n);
2780 `months', returning a 12-element vector of month names (locale items MON_n);
2782 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2783 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2785 If the system can't provide such information through a call to
2786 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2788 See also Info node `(libc)Locales'.
2790 The data read from the system are decoded using `locale-coding-system'. */)
2794 #ifdef HAVE_LANGINFO_CODESET
2796 if (EQ (item
, Qcodeset
))
2798 str
= nl_langinfo (CODESET
);
2799 return build_string (str
);
2802 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2804 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2805 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2807 struct gcpro gcpro1
;
2809 synchronize_system_time_locale ();
2810 for (i
= 0; i
< 7; i
++)
2812 str
= nl_langinfo (days
[i
]);
2813 val
= build_unibyte_string (str
);
2814 /* Fixme: Is this coding system necessarily right, even if
2815 it is consistent with CODESET? If not, what to do? */
2816 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2824 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2826 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2827 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2828 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2830 struct gcpro gcpro1
;
2832 synchronize_system_time_locale ();
2833 for (i
= 0; i
< 12; i
++)
2835 str
= nl_langinfo (months
[i
]);
2836 val
= build_unibyte_string (str
);
2837 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2844 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2845 but is in the locale files. This could be used by ps-print. */
2847 else if (EQ (item
, Qpaper
))
2848 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2849 #endif /* PAPER_WIDTH */
2850 #endif /* HAVE_LANGINFO_CODESET*/
2854 /* base64 encode/decode functions (RFC 2045).
2855 Based on code from GNU recode. */
2857 #define MIME_LINE_LENGTH 76
2859 #define IS_ASCII(Character) \
2861 #define IS_BASE64(Character) \
2862 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2863 #define IS_BASE64_IGNORABLE(Character) \
2864 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2865 || (Character) == '\f' || (Character) == '\r')
2867 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2868 character or return retval if there are no characters left to
2870 #define READ_QUADRUPLET_BYTE(retval) \
2875 if (nchars_return) \
2876 *nchars_return = nchars; \
2881 while (IS_BASE64_IGNORABLE (c))
2883 /* Table of characters coding the 64 values. */
2884 static const char base64_value_to_char
[64] =
2886 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2887 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2888 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2889 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2890 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2891 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2892 '8', '9', '+', '/' /* 60-63 */
2895 /* Table of base64 values for first 128 characters. */
2896 static const short base64_char_to_value
[128] =
2898 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2899 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2900 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2901 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2902 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2903 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2904 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2905 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2906 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2907 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2908 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2909 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2910 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2913 /* The following diagram shows the logical steps by which three octets
2914 get transformed into four base64 characters.
2916 .--------. .--------. .--------.
2917 |aaaaaabb| |bbbbcccc| |ccdddddd|
2918 `--------' `--------' `--------'
2920 .--------+--------+--------+--------.
2921 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2922 `--------+--------+--------+--------'
2924 .--------+--------+--------+--------.
2925 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2926 `--------+--------+--------+--------'
2928 The octets are divided into 6 bit chunks, which are then encoded into
2929 base64 characters. */
2932 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2933 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2936 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2938 doc
: /* Base64-encode the region between BEG and END.
2939 Return the length of the encoded text.
2940 Optional third argument NO-LINE-BREAK means do not break long lines
2941 into shorter lines. */)
2942 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2945 ptrdiff_t allength
, length
;
2946 ptrdiff_t ibeg
, iend
, encoded_length
;
2947 ptrdiff_t old_pos
= PT
;
2950 validate_region (&beg
, &end
);
2952 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2953 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2954 move_gap_both (XFASTINT (beg
), ibeg
);
2956 /* We need to allocate enough room for encoding the text.
2957 We need 33 1/3% more space, plus a newline every 76
2958 characters, and then we round up. */
2959 length
= iend
- ibeg
;
2960 allength
= length
+ length
/3 + 1;
2961 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2963 encoded
= SAFE_ALLOCA (allength
);
2964 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2965 encoded
, length
, NILP (no_line_break
),
2966 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2967 if (encoded_length
> allength
)
2970 if (encoded_length
< 0)
2972 /* The encoding wasn't possible. */
2974 error ("Multibyte character in data for base64 encoding");
2977 /* Now we have encoded the region, so we insert the new contents
2978 and delete the old. (Insert first in order to preserve markers.) */
2979 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2980 insert (encoded
, encoded_length
);
2982 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2984 /* If point was outside of the region, restore it exactly; else just
2985 move to the beginning of the region. */
2986 if (old_pos
>= XFASTINT (end
))
2987 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2988 else if (old_pos
> XFASTINT (beg
))
2989 old_pos
= XFASTINT (beg
);
2992 /* We return the length of the encoded text. */
2993 return make_number (encoded_length
);
2996 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2998 doc
: /* Base64-encode STRING and return the result.
2999 Optional second argument NO-LINE-BREAK means do not break long lines
3000 into shorter lines. */)
3001 (Lisp_Object string
, Lisp_Object no_line_break
)
3003 ptrdiff_t allength
, length
, encoded_length
;
3005 Lisp_Object encoded_string
;
3008 CHECK_STRING (string
);
3010 /* We need to allocate enough room for encoding the text.
3011 We need 33 1/3% more space, plus a newline every 76
3012 characters, and then we round up. */
3013 length
= SBYTES (string
);
3014 allength
= length
+ length
/3 + 1;
3015 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3017 /* We need to allocate enough room for decoding the text. */
3018 encoded
= SAFE_ALLOCA (allength
);
3020 encoded_length
= base64_encode_1 (SSDATA (string
),
3021 encoded
, length
, NILP (no_line_break
),
3022 STRING_MULTIBYTE (string
));
3023 if (encoded_length
> allength
)
3026 if (encoded_length
< 0)
3028 /* The encoding wasn't possible. */
3030 error ("Multibyte character in data for base64 encoding");
3033 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3036 return encoded_string
;
3040 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3041 bool line_break
, bool multibyte
)
3054 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3055 if (CHAR_BYTE8_P (c
))
3056 c
= CHAR_TO_BYTE8 (c
);
3064 /* Wrap line every 76 characters. */
3068 if (counter
< MIME_LINE_LENGTH
/ 4)
3077 /* Process first byte of a triplet. */
3079 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3080 value
= (0x03 & c
) << 4;
3082 /* Process second byte of a triplet. */
3086 *e
++ = base64_value_to_char
[value
];
3094 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3095 if (CHAR_BYTE8_P (c
))
3096 c
= CHAR_TO_BYTE8 (c
);
3104 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3105 value
= (0x0f & c
) << 2;
3107 /* Process third byte of a triplet. */
3111 *e
++ = base64_value_to_char
[value
];
3118 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3119 if (CHAR_BYTE8_P (c
))
3120 c
= CHAR_TO_BYTE8 (c
);
3128 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3129 *e
++ = base64_value_to_char
[0x3f & c
];
3136 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3138 doc
: /* Base64-decode the region between BEG and END.
3139 Return the length of the decoded text.
3140 If the region can't be decoded, signal an error and don't modify the buffer. */)
3141 (Lisp_Object beg
, Lisp_Object end
)
3143 ptrdiff_t ibeg
, iend
, length
, allength
;
3145 ptrdiff_t old_pos
= PT
;
3146 ptrdiff_t decoded_length
;
3147 ptrdiff_t inserted_chars
;
3148 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3151 validate_region (&beg
, &end
);
3153 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3154 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3156 length
= iend
- ibeg
;
3158 /* We need to allocate enough room for decoding the text. If we are
3159 working on a multibyte buffer, each decoded code may occupy at
3161 allength
= multibyte
? length
* 2 : length
;
3162 decoded
= SAFE_ALLOCA (allength
);
3164 move_gap_both (XFASTINT (beg
), ibeg
);
3165 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3167 multibyte
, &inserted_chars
);
3168 if (decoded_length
> allength
)
3171 if (decoded_length
< 0)
3173 /* The decoding wasn't possible. */
3175 error ("Invalid base64 data");
3178 /* Now we have decoded the region, so we insert the new contents
3179 and delete the old. (Insert first in order to preserve markers.) */
3180 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3181 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3184 /* Delete the original text. */
3185 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3186 iend
+ decoded_length
, 1);
3188 /* If point was outside of the region, restore it exactly; else just
3189 move to the beginning of the region. */
3190 if (old_pos
>= XFASTINT (end
))
3191 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3192 else if (old_pos
> XFASTINT (beg
))
3193 old_pos
= XFASTINT (beg
);
3194 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3196 return make_number (inserted_chars
);
3199 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3201 doc
: /* Base64-decode STRING and return the result. */)
3202 (Lisp_Object string
)
3205 ptrdiff_t length
, decoded_length
;
3206 Lisp_Object decoded_string
;
3209 CHECK_STRING (string
);
3211 length
= SBYTES (string
);
3212 /* We need to allocate enough room for decoding the text. */
3213 decoded
= SAFE_ALLOCA (length
);
3215 /* The decoded result should be unibyte. */
3216 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3218 if (decoded_length
> length
)
3220 else if (decoded_length
>= 0)
3221 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3223 decoded_string
= Qnil
;
3226 if (!STRINGP (decoded_string
))
3227 error ("Invalid base64 data");
3229 return decoded_string
;
3232 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3233 MULTIBYTE, the decoded result should be in multibyte
3234 form. If NCHARS_RETURN is not NULL, store the number of produced
3235 characters in *NCHARS_RETURN. */
3238 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3239 bool multibyte
, ptrdiff_t *nchars_return
)
3241 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3244 unsigned long value
;
3245 ptrdiff_t nchars
= 0;
3249 /* Process first byte of a quadruplet. */
3251 READ_QUADRUPLET_BYTE (e
-to
);
3255 value
= base64_char_to_value
[c
] << 18;
3257 /* Process second byte of a quadruplet. */
3259 READ_QUADRUPLET_BYTE (-1);
3263 value
|= base64_char_to_value
[c
] << 12;
3265 c
= (unsigned char) (value
>> 16);
3266 if (multibyte
&& c
>= 128)
3267 e
+= BYTE8_STRING (c
, e
);
3272 /* Process third byte of a quadruplet. */
3274 READ_QUADRUPLET_BYTE (-1);
3278 READ_QUADRUPLET_BYTE (-1);
3287 value
|= base64_char_to_value
[c
] << 6;
3289 c
= (unsigned char) (0xff & value
>> 8);
3290 if (multibyte
&& c
>= 128)
3291 e
+= BYTE8_STRING (c
, e
);
3296 /* Process fourth byte of a quadruplet. */
3298 READ_QUADRUPLET_BYTE (-1);
3305 value
|= base64_char_to_value
[c
];
3307 c
= (unsigned char) (0xff & value
);
3308 if (multibyte
&& c
>= 128)
3309 e
+= BYTE8_STRING (c
, e
);
3318 /***********************************************************************
3320 ***** Hash Tables *****
3322 ***********************************************************************/
3324 /* Implemented by gerd@gnu.org. This hash table implementation was
3325 inspired by CMUCL hash tables. */
3329 1. For small tables, association lists are probably faster than
3330 hash tables because they have lower overhead.
3332 For uses of hash tables where the O(1) behavior of table
3333 operations is not a requirement, it might therefore be a good idea
3334 not to hash. Instead, we could just do a linear search in the
3335 key_and_value vector of the hash table. This could be done
3336 if a `:linear-search t' argument is given to make-hash-table. */
3339 /* The list of all weak hash tables. Don't staticpro this one. */
3341 static struct Lisp_Hash_Table
*weak_hash_tables
;
3343 /* Various symbols. */
3345 static Lisp_Object Qhash_table_p
;
3346 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3347 Lisp_Object Qeq
, Qequal
;
3348 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3349 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3352 /***********************************************************************
3354 ***********************************************************************/
3357 CHECK_HASH_TABLE (Lisp_Object x
)
3359 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3363 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3365 h
->key_and_value
= key_and_value
;
3368 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3373 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3375 gc_aset (h
->next
, idx
, val
);
3378 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3383 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3385 gc_aset (h
->hash
, idx
, val
);
3388 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3393 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3395 gc_aset (h
->index
, idx
, val
);
3398 /* If OBJ is a Lisp hash table, return a pointer to its struct
3399 Lisp_Hash_Table. Otherwise, signal an error. */
3401 static struct Lisp_Hash_Table
*
3402 check_hash_table (Lisp_Object obj
)
3404 CHECK_HASH_TABLE (obj
);
3405 return XHASH_TABLE (obj
);
3409 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3410 number. A number is "almost" a prime number if it is not divisible
3411 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3414 next_almost_prime (EMACS_INT n
)
3416 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3417 for (n
|= 1; ; n
+= 2)
3418 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3423 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3424 which USED[I] is non-zero. If found at index I in ARGS, set
3425 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3426 0. This function is used to extract a keyword/argument pair from
3427 a DEFUN parameter list. */
3430 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3434 for (i
= 1; i
< nargs
; i
++)
3435 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3446 /* Return a Lisp vector which has the same contents as VEC but has
3447 at least INCR_MIN more entries, where INCR_MIN is positive.
3448 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3449 than NITEMS_MAX. Entries in the resulting
3450 vector that are not copied from VEC are set to nil. */
3453 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3455 struct Lisp_Vector
*v
;
3456 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3457 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3458 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3459 ? nitems_max
: C_language_max
);
3460 eassert (VECTORP (vec
));
3461 eassert (0 < incr_min
&& -1 <= nitems_max
);
3462 old_size
= ASIZE (vec
);
3463 incr_max
= n_max
- old_size
;
3464 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3465 if (incr_max
< incr
)
3466 memory_full (SIZE_MAX
);
3467 new_size
= old_size
+ incr
;
3468 v
= allocate_vector (new_size
);
3469 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3470 for (i
= old_size
; i
< new_size
; ++i
)
3471 v
->contents
[i
] = Qnil
;
3472 XSETVECTOR (vec
, v
);
3477 /***********************************************************************
3479 ***********************************************************************/
3481 static struct hash_table_test hashtest_eq
;
3482 struct hash_table_test hashtest_eql
, hashtest_equal
;
3484 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3485 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3486 KEY2 are the same. */
3489 cmpfn_eql (struct hash_table_test
*ht
,
3493 return (FLOATP (key1
)
3495 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3499 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3500 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3501 KEY2 are the same. */
3504 cmpfn_equal (struct hash_table_test
*ht
,
3508 return !NILP (Fequal (key1
, key2
));
3512 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3513 HASH2 in hash table H using H->user_cmp_function. Value is true
3514 if KEY1 and KEY2 are the same. */
3517 cmpfn_user_defined (struct hash_table_test
*ht
,
3521 Lisp_Object args
[3];
3523 args
[0] = ht
->user_cmp_function
;
3526 return !NILP (Ffuncall (3, args
));
3530 /* Value is a hash code for KEY for use in hash table H which uses
3531 `eq' to compare keys. The hash code returned is guaranteed to fit
3532 in a Lisp integer. */
3535 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3537 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3541 /* Value is a hash code for KEY for use in hash table H which uses
3542 `eql' to compare keys. The hash code returned is guaranteed to fit
3543 in a Lisp integer. */
3546 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3550 hash
= sxhash (key
, 0);
3552 hash
= XHASH (key
) ^ XTYPE (key
);
3556 /* Value is a hash code for KEY for use in hash table H which uses
3557 `equal' to compare keys. The hash code returned is guaranteed to fit
3558 in a Lisp integer. */
3561 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3563 EMACS_UINT hash
= sxhash (key
, 0);
3567 /* Value is a hash code for KEY for use in hash table H which uses as
3568 user-defined function to compare keys. The hash code returned is
3569 guaranteed to fit in a Lisp integer. */
3572 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3574 Lisp_Object args
[2], hash
;
3576 args
[0] = ht
->user_hash_function
;
3578 hash
= Ffuncall (2, args
);
3579 if (!INTEGERP (hash
))
3580 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3581 return XUINT (hash
);
3584 /* An upper bound on the size of a hash table index. It must fit in
3585 ptrdiff_t and be a valid Emacs fixnum. */
3586 #define INDEX_SIZE_BOUND \
3587 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3589 /* Create and initialize a new hash table.
3591 TEST specifies the test the hash table will use to compare keys.
3592 It must be either one of the predefined tests `eq', `eql' or
3593 `equal' or a symbol denoting a user-defined test named TEST with
3594 test and hash functions USER_TEST and USER_HASH.
3596 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3598 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3599 new size when it becomes full is computed by adding REHASH_SIZE to
3600 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3601 table's new size is computed by multiplying its old size with
3604 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3605 be resized when the ratio of (number of entries in the table) /
3606 (table size) is >= REHASH_THRESHOLD.
3608 WEAK specifies the weakness of the table. If non-nil, it must be
3609 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3612 make_hash_table (struct hash_table_test test
,
3613 Lisp_Object size
, Lisp_Object rehash_size
,
3614 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3616 struct Lisp_Hash_Table
*h
;
3618 EMACS_INT index_size
, sz
;
3622 /* Preconditions. */
3623 eassert (SYMBOLP (test
.name
));
3624 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3625 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3626 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3627 eassert (FLOATP (rehash_threshold
)
3628 && 0 < XFLOAT_DATA (rehash_threshold
)
3629 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3631 if (XFASTINT (size
) == 0)
3632 size
= make_number (1);
3634 sz
= XFASTINT (size
);
3635 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3636 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3637 ? next_almost_prime (index_float
)
3638 : INDEX_SIZE_BOUND
+ 1);
3639 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3640 error ("Hash table too large");
3642 /* Allocate a table and initialize it. */
3643 h
= allocate_hash_table ();
3645 /* Initialize hash table slots. */
3648 h
->rehash_threshold
= rehash_threshold
;
3649 h
->rehash_size
= rehash_size
;
3651 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3652 h
->hash
= Fmake_vector (size
, Qnil
);
3653 h
->next
= Fmake_vector (size
, Qnil
);
3654 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3656 /* Set up the free list. */
3657 for (i
= 0; i
< sz
- 1; ++i
)
3658 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3659 h
->next_free
= make_number (0);
3661 XSET_HASH_TABLE (table
, h
);
3662 eassert (HASH_TABLE_P (table
));
3663 eassert (XHASH_TABLE (table
) == h
);
3665 /* Maybe add this hash table to the list of all weak hash tables. */
3667 h
->next_weak
= NULL
;
3670 h
->next_weak
= weak_hash_tables
;
3671 weak_hash_tables
= h
;
3678 /* Return a copy of hash table H1. Keys and values are not copied,
3679 only the table itself is. */
3682 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3685 struct Lisp_Hash_Table
*h2
;
3687 h2
= allocate_hash_table ();
3689 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3690 h2
->hash
= Fcopy_sequence (h1
->hash
);
3691 h2
->next
= Fcopy_sequence (h1
->next
);
3692 h2
->index
= Fcopy_sequence (h1
->index
);
3693 XSET_HASH_TABLE (table
, h2
);
3695 /* Maybe add this hash table to the list of all weak hash tables. */
3696 if (!NILP (h2
->weak
))
3698 h2
->next_weak
= weak_hash_tables
;
3699 weak_hash_tables
= h2
;
3706 /* Resize hash table H if it's too full. If H cannot be resized
3707 because it's already too large, throw an error. */
3710 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3712 if (NILP (h
->next_free
))
3714 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3715 EMACS_INT new_size
, index_size
, nsize
;
3719 if (INTEGERP (h
->rehash_size
))
3720 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3723 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3724 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3726 new_size
= float_new_size
;
3727 if (new_size
<= old_size
)
3728 new_size
= old_size
+ 1;
3731 new_size
= INDEX_SIZE_BOUND
+ 1;
3733 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3734 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3735 ? next_almost_prime (index_float
)
3736 : INDEX_SIZE_BOUND
+ 1);
3737 nsize
= max (index_size
, 2 * new_size
);
3738 if (INDEX_SIZE_BOUND
< nsize
)
3739 error ("Hash table too large to resize");
3741 #ifdef ENABLE_CHECKING
3742 if (HASH_TABLE_P (Vpurify_flag
)
3743 && XHASH_TABLE (Vpurify_flag
) == h
)
3745 Lisp_Object args
[2];
3746 args
[0] = build_string ("Growing hash table to: %d");
3747 args
[1] = make_number (new_size
);
3752 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3753 2 * (new_size
- old_size
), -1));
3754 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3755 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3756 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3758 /* Update the free list. Do it so that new entries are added at
3759 the end of the free list. This makes some operations like
3761 for (i
= old_size
; i
< new_size
- 1; ++i
)
3762 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3764 if (!NILP (h
->next_free
))
3766 Lisp_Object last
, next
;
3768 last
= h
->next_free
;
3769 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3773 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3776 XSETFASTINT (h
->next_free
, old_size
);
3779 for (i
= 0; i
< old_size
; ++i
)
3780 if (!NILP (HASH_HASH (h
, i
)))
3782 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3783 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3784 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3785 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3791 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3792 the hash code of KEY. Value is the index of the entry in H
3793 matching KEY, or -1 if not found. */
3796 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3798 EMACS_UINT hash_code
;
3799 ptrdiff_t start_of_bucket
;
3802 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3803 eassert ((hash_code
& ~INTMASK
) == 0);
3807 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3808 idx
= HASH_INDEX (h
, start_of_bucket
);
3810 /* We need not gcpro idx since it's either an integer or nil. */
3813 ptrdiff_t i
= XFASTINT (idx
);
3814 if (EQ (key
, HASH_KEY (h
, i
))
3816 && hash_code
== XUINT (HASH_HASH (h
, i
))
3817 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3819 idx
= HASH_NEXT (h
, i
);
3822 return NILP (idx
) ? -1 : XFASTINT (idx
);
3826 /* Put an entry into hash table H that associates KEY with VALUE.
3827 HASH is a previously computed hash code of KEY.
3828 Value is the index of the entry in H matching KEY. */
3831 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3834 ptrdiff_t start_of_bucket
, i
;
3836 eassert ((hash
& ~INTMASK
) == 0);
3838 /* Increment count after resizing because resizing may fail. */
3839 maybe_resize_hash_table (h
);
3842 /* Store key/value in the key_and_value vector. */
3843 i
= XFASTINT (h
->next_free
);
3844 h
->next_free
= HASH_NEXT (h
, i
);
3845 set_hash_key_slot (h
, i
, key
);
3846 set_hash_value_slot (h
, i
, value
);
3848 /* Remember its hash code. */
3849 set_hash_hash_slot (h
, i
, make_number (hash
));
3851 /* Add new entry to its collision chain. */
3852 start_of_bucket
= hash
% ASIZE (h
->index
);
3853 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3854 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3859 /* Remove the entry matching KEY from hash table H, if there is one. */
3862 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3864 EMACS_UINT hash_code
;
3865 ptrdiff_t start_of_bucket
;
3866 Lisp_Object idx
, prev
;
3868 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3869 eassert ((hash_code
& ~INTMASK
) == 0);
3870 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3871 idx
= HASH_INDEX (h
, start_of_bucket
);
3874 /* We need not gcpro idx, prev since they're either integers or nil. */
3877 ptrdiff_t i
= XFASTINT (idx
);
3879 if (EQ (key
, HASH_KEY (h
, i
))
3881 && hash_code
== XUINT (HASH_HASH (h
, i
))
3882 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3884 /* Take entry out of collision chain. */
3886 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3888 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3890 /* Clear slots in key_and_value and add the slots to
3892 set_hash_key_slot (h
, i
, Qnil
);
3893 set_hash_value_slot (h
, i
, Qnil
);
3894 set_hash_hash_slot (h
, i
, Qnil
);
3895 set_hash_next_slot (h
, i
, h
->next_free
);
3896 h
->next_free
= make_number (i
);
3898 eassert (h
->count
>= 0);
3904 idx
= HASH_NEXT (h
, i
);
3910 /* Clear hash table H. */
3913 hash_clear (struct Lisp_Hash_Table
*h
)
3917 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3919 for (i
= 0; i
< size
; ++i
)
3921 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3922 set_hash_key_slot (h
, i
, Qnil
);
3923 set_hash_value_slot (h
, i
, Qnil
);
3924 set_hash_hash_slot (h
, i
, Qnil
);
3927 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3928 ASET (h
->index
, i
, Qnil
);
3930 h
->next_free
= make_number (0);
3937 /************************************************************************
3939 ************************************************************************/
3941 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3942 entries from the table that don't survive the current GC.
3943 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3944 true if anything was marked. */
3947 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3949 ptrdiff_t bucket
, n
;
3952 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3955 for (bucket
= 0; bucket
< n
; ++bucket
)
3957 Lisp_Object idx
, next
, prev
;
3959 /* Follow collision chain, removing entries that
3960 don't survive this garbage collection. */
3962 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3964 ptrdiff_t i
= XFASTINT (idx
);
3965 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3966 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3969 if (EQ (h
->weak
, Qkey
))
3970 remove_p
= !key_known_to_survive_p
;
3971 else if (EQ (h
->weak
, Qvalue
))
3972 remove_p
= !value_known_to_survive_p
;
3973 else if (EQ (h
->weak
, Qkey_or_value
))
3974 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3975 else if (EQ (h
->weak
, Qkey_and_value
))
3976 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3980 next
= HASH_NEXT (h
, i
);
3982 if (remove_entries_p
)
3986 /* Take out of collision chain. */
3988 set_hash_index_slot (h
, bucket
, next
);
3990 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3992 /* Add to free list. */
3993 set_hash_next_slot (h
, i
, h
->next_free
);
3996 /* Clear key, value, and hash. */
3997 set_hash_key_slot (h
, i
, Qnil
);
3998 set_hash_value_slot (h
, i
, Qnil
);
3999 set_hash_hash_slot (h
, i
, Qnil
);
4012 /* Make sure key and value survive. */
4013 if (!key_known_to_survive_p
)
4015 mark_object (HASH_KEY (h
, i
));
4019 if (!value_known_to_survive_p
)
4021 mark_object (HASH_VALUE (h
, i
));
4032 /* Remove elements from weak hash tables that don't survive the
4033 current garbage collection. Remove weak tables that don't survive
4034 from Vweak_hash_tables. Called from gc_sweep. */
4037 sweep_weak_hash_tables (void)
4039 struct Lisp_Hash_Table
*h
, *used
, *next
;
4042 /* Mark all keys and values that are in use. Keep on marking until
4043 there is no more change. This is necessary for cases like
4044 value-weak table A containing an entry X -> Y, where Y is used in a
4045 key-weak table B, Z -> Y. If B comes after A in the list of weak
4046 tables, X -> Y might be removed from A, although when looking at B
4047 one finds that it shouldn't. */
4051 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4053 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4054 marked
|= sweep_weak_table (h
, 0);
4059 /* Remove tables and entries that aren't used. */
4060 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4062 next
= h
->next_weak
;
4064 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4066 /* TABLE is marked as used. Sweep its contents. */
4068 sweep_weak_table (h
, 1);
4070 /* Add table to the list of used weak hash tables. */
4071 h
->next_weak
= used
;
4076 weak_hash_tables
= used
;
4081 /***********************************************************************
4082 Hash Code Computation
4083 ***********************************************************************/
4085 /* Maximum depth up to which to dive into Lisp structures. */
4087 #define SXHASH_MAX_DEPTH 3
4089 /* Maximum length up to which to take list and vector elements into
4092 #define SXHASH_MAX_LEN 7
4094 /* Return a hash for string PTR which has length LEN. The hash value
4095 can be any EMACS_UINT value. */
4098 hash_string (char const *ptr
, ptrdiff_t len
)
4100 char const *p
= ptr
;
4101 char const *end
= p
+ len
;
4103 EMACS_UINT hash
= 0;
4108 hash
= sxhash_combine (hash
, c
);
4114 /* Return a hash for string PTR which has length LEN. The hash
4115 code returned is guaranteed to fit in a Lisp integer. */
4118 sxhash_string (char const *ptr
, ptrdiff_t len
)
4120 EMACS_UINT hash
= hash_string (ptr
, len
);
4121 return SXHASH_REDUCE (hash
);
4124 /* Return a hash for the floating point value VAL. */
4127 sxhash_float (double val
)
4129 EMACS_UINT hash
= 0;
4131 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4132 + (sizeof val
% sizeof hash
!= 0))
4136 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4140 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4141 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4142 hash
= sxhash_combine (hash
, u
.word
[i
]);
4143 return SXHASH_REDUCE (hash
);
4146 /* Return a hash for list LIST. DEPTH is the current depth in the
4147 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4150 sxhash_list (Lisp_Object list
, int depth
)
4152 EMACS_UINT hash
= 0;
4155 if (depth
< SXHASH_MAX_DEPTH
)
4157 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4158 list
= XCDR (list
), ++i
)
4160 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4161 hash
= sxhash_combine (hash
, hash2
);
4166 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4167 hash
= sxhash_combine (hash
, hash2
);
4170 return SXHASH_REDUCE (hash
);
4174 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4175 the Lisp structure. */
4178 sxhash_vector (Lisp_Object vec
, int depth
)
4180 EMACS_UINT hash
= ASIZE (vec
);
4183 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4184 for (i
= 0; i
< n
; ++i
)
4186 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4187 hash
= sxhash_combine (hash
, hash2
);
4190 return SXHASH_REDUCE (hash
);
4193 /* Return a hash for bool-vector VECTOR. */
4196 sxhash_bool_vector (Lisp_Object vec
)
4198 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4201 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4202 for (i
= 0; i
< n
; ++i
)
4203 hash
= sxhash_combine (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4205 return SXHASH_REDUCE (hash
);
4209 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4210 structure. Value is an unsigned integer clipped to INTMASK. */
4213 sxhash (Lisp_Object obj
, int depth
)
4217 if (depth
> SXHASH_MAX_DEPTH
)
4220 switch (XTYPE (obj
))
4231 obj
= SYMBOL_NAME (obj
);
4235 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4238 /* This can be everything from a vector to an overlay. */
4239 case Lisp_Vectorlike
:
4241 /* According to the CL HyperSpec, two arrays are equal only if
4242 they are `eq', except for strings and bit-vectors. In
4243 Emacs, this works differently. We have to compare element
4245 hash
= sxhash_vector (obj
, depth
);
4246 else if (BOOL_VECTOR_P (obj
))
4247 hash
= sxhash_bool_vector (obj
);
4249 /* Others are `equal' if they are `eq', so let's take their
4255 hash
= sxhash_list (obj
, depth
);
4259 hash
= sxhash_float (XFLOAT_DATA (obj
));
4271 /***********************************************************************
4273 ***********************************************************************/
4276 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4277 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4280 EMACS_UINT hash
= sxhash (obj
, 0);
4281 return make_number (hash
);
4285 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4286 doc
: /* Create and return a new hash table.
4288 Arguments are specified as keyword/argument pairs. The following
4289 arguments are defined:
4291 :test TEST -- TEST must be a symbol that specifies how to compare
4292 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4293 `equal'. User-supplied test and hash functions can be specified via
4294 `define-hash-table-test'.
4296 :size SIZE -- A hint as to how many elements will be put in the table.
4299 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4300 fills up. If REHASH-SIZE is an integer, increase the size by that
4301 amount. If it is a float, it must be > 1.0, and the new size is the
4302 old size multiplied by that factor. Default is 1.5.
4304 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4305 Resize the hash table when the ratio (number of entries / table size)
4306 is greater than or equal to THRESHOLD. Default is 0.8.
4308 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4309 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4310 returned is a weak table. Key/value pairs are removed from a weak
4311 hash table when there are no non-weak references pointing to their
4312 key, value, one of key or value, or both key and value, depending on
4313 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4316 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4317 (ptrdiff_t nargs
, Lisp_Object
*args
)
4319 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4320 struct hash_table_test testdesc
;
4324 /* The vector `used' is used to keep track of arguments that
4325 have been consumed. */
4326 used
= alloca (nargs
* sizeof *used
);
4327 memset (used
, 0, nargs
* sizeof *used
);
4329 /* See if there's a `:test TEST' among the arguments. */
4330 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4331 test
= i
? args
[i
] : Qeql
;
4333 testdesc
= hashtest_eq
;
4334 else if (EQ (test
, Qeql
))
4335 testdesc
= hashtest_eql
;
4336 else if (EQ (test
, Qequal
))
4337 testdesc
= hashtest_equal
;
4340 /* See if it is a user-defined test. */
4343 prop
= Fget (test
, Qhash_table_test
);
4344 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4345 signal_error ("Invalid hash table test", test
);
4346 testdesc
.name
= test
;
4347 testdesc
.user_cmp_function
= XCAR (prop
);
4348 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4349 testdesc
.hashfn
= hashfn_user_defined
;
4350 testdesc
.cmpfn
= cmpfn_user_defined
;
4353 /* See if there's a `:size SIZE' argument. */
4354 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4355 size
= i
? args
[i
] : Qnil
;
4357 size
= make_number (DEFAULT_HASH_SIZE
);
4358 else if (!INTEGERP (size
) || XINT (size
) < 0)
4359 signal_error ("Invalid hash table size", size
);
4361 /* Look for `:rehash-size SIZE'. */
4362 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4363 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4364 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4365 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4366 signal_error ("Invalid hash table rehash size", rehash_size
);
4368 /* Look for `:rehash-threshold THRESHOLD'. */
4369 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4370 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4371 if (! (FLOATP (rehash_threshold
)
4372 && 0 < XFLOAT_DATA (rehash_threshold
)
4373 && XFLOAT_DATA (rehash_threshold
) <= 1))
4374 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4376 /* Look for `:weakness WEAK'. */
4377 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4378 weak
= i
? args
[i
] : Qnil
;
4380 weak
= Qkey_and_value
;
4383 && !EQ (weak
, Qvalue
)
4384 && !EQ (weak
, Qkey_or_value
)
4385 && !EQ (weak
, Qkey_and_value
))
4386 signal_error ("Invalid hash table weakness", weak
);
4388 /* Now, all args should have been used up, or there's a problem. */
4389 for (i
= 0; i
< nargs
; ++i
)
4391 signal_error ("Invalid argument list", args
[i
]);
4393 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4397 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4398 doc
: /* Return a copy of hash table TABLE. */)
4401 return copy_hash_table (check_hash_table (table
));
4405 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4406 doc
: /* Return the number of elements in TABLE. */)
4409 return make_number (check_hash_table (table
)->count
);
4413 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4414 Shash_table_rehash_size
, 1, 1, 0,
4415 doc
: /* Return the current rehash size of TABLE. */)
4418 return check_hash_table (table
)->rehash_size
;
4422 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4423 Shash_table_rehash_threshold
, 1, 1, 0,
4424 doc
: /* Return the current rehash threshold of TABLE. */)
4427 return check_hash_table (table
)->rehash_threshold
;
4431 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4432 doc
: /* Return the size of TABLE.
4433 The size can be used as an argument to `make-hash-table' to create
4434 a hash table than can hold as many elements as TABLE holds
4435 without need for resizing. */)
4438 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4439 return make_number (HASH_TABLE_SIZE (h
));
4443 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4444 doc
: /* Return the test TABLE uses. */)
4447 return check_hash_table (table
)->test
.name
;
4451 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4453 doc
: /* Return the weakness of TABLE. */)
4456 return check_hash_table (table
)->weak
;
4460 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4461 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4464 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4468 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4469 doc
: /* Clear hash table TABLE and return it. */)
4472 hash_clear (check_hash_table (table
));
4473 /* Be compatible with XEmacs. */
4478 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4479 doc
: /* Look up KEY in TABLE and return its associated value.
4480 If KEY is not found, return DFLT which defaults to nil. */)
4481 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4483 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4484 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4485 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4489 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4490 doc
: /* Associate KEY with VALUE in hash table TABLE.
4491 If KEY is already present in table, replace its current value with
4492 VALUE. In any case, return VALUE. */)
4493 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4495 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4499 i
= hash_lookup (h
, key
, &hash
);
4501 set_hash_value_slot (h
, i
, value
);
4503 hash_put (h
, key
, value
, hash
);
4509 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4510 doc
: /* Remove KEY from TABLE. */)
4511 (Lisp_Object key
, Lisp_Object table
)
4513 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4514 hash_remove_from_table (h
, key
);
4519 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4520 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4521 FUNCTION is called with two arguments, KEY and VALUE. */)
4522 (Lisp_Object function
, Lisp_Object table
)
4524 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4525 Lisp_Object args
[3];
4528 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4529 if (!NILP (HASH_HASH (h
, i
)))
4532 args
[1] = HASH_KEY (h
, i
);
4533 args
[2] = HASH_VALUE (h
, i
);
4541 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4542 Sdefine_hash_table_test
, 3, 3, 0,
4543 doc
: /* Define a new hash table test with name NAME, a symbol.
4545 In hash tables created with NAME specified as test, use TEST to
4546 compare keys, and HASH for computing hash codes of keys.
4548 TEST must be a function taking two arguments and returning non-nil if
4549 both arguments are the same. HASH must be a function taking one
4550 argument and return an integer that is the hash code of the argument.
4551 Hash code computation should use the whole value range of integers,
4552 including negative integers. */)
4553 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4555 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4560 /************************************************************************
4561 MD5, SHA-1, and SHA-2
4562 ************************************************************************/
4569 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4572 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4576 EMACS_INT start_char
= 0, end_char
= 0;
4577 ptrdiff_t start_byte
, end_byte
;
4578 register EMACS_INT b
, e
;
4579 register struct buffer
*bp
;
4582 void *(*hash_func
) (const char *, size_t, void *);
4585 CHECK_SYMBOL (algorithm
);
4587 if (STRINGP (object
))
4589 if (NILP (coding_system
))
4591 /* Decide the coding-system to encode the data with. */
4593 if (STRING_MULTIBYTE (object
))
4594 /* use default, we can't guess correct value */
4595 coding_system
= preferred_coding_system ();
4597 coding_system
= Qraw_text
;
4600 if (NILP (Fcoding_system_p (coding_system
)))
4602 /* Invalid coding system. */
4604 if (!NILP (noerror
))
4605 coding_system
= Qraw_text
;
4607 xsignal1 (Qcoding_system_error
, coding_system
);
4610 if (STRING_MULTIBYTE (object
))
4611 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4613 size
= SCHARS (object
);
4617 CHECK_NUMBER (start
);
4619 start_char
= XINT (start
);
4631 end_char
= XINT (end
);
4637 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4638 args_out_of_range_3 (object
, make_number (start_char
),
4639 make_number (end_char
));
4641 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4643 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4647 struct buffer
*prev
= current_buffer
;
4649 record_unwind_current_buffer ();
4651 CHECK_BUFFER (object
);
4653 bp
= XBUFFER (object
);
4654 set_buffer_internal (bp
);
4660 CHECK_NUMBER_COERCE_MARKER (start
);
4668 CHECK_NUMBER_COERCE_MARKER (end
);
4673 temp
= b
, b
= e
, e
= temp
;
4675 if (!(BEGV
<= b
&& e
<= ZV
))
4676 args_out_of_range (start
, end
);
4678 if (NILP (coding_system
))
4680 /* Decide the coding-system to encode the data with.
4681 See fileio.c:Fwrite-region */
4683 if (!NILP (Vcoding_system_for_write
))
4684 coding_system
= Vcoding_system_for_write
;
4687 bool force_raw_text
= 0;
4689 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4690 if (NILP (coding_system
)
4691 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4693 coding_system
= Qnil
;
4694 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4698 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4700 /* Check file-coding-system-alist. */
4701 Lisp_Object args
[4], val
;
4703 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4704 args
[3] = Fbuffer_file_name (object
);
4705 val
= Ffind_operation_coding_system (4, args
);
4706 if (CONSP (val
) && !NILP (XCDR (val
)))
4707 coding_system
= XCDR (val
);
4710 if (NILP (coding_system
)
4711 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4713 /* If we still have not decided a coding system, use the
4714 default value of buffer-file-coding-system. */
4715 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4719 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4720 /* Confirm that VAL can surely encode the current region. */
4721 coding_system
= call4 (Vselect_safe_coding_system_function
,
4722 make_number (b
), make_number (e
),
4723 coding_system
, Qnil
);
4726 coding_system
= Qraw_text
;
4729 if (NILP (Fcoding_system_p (coding_system
)))
4731 /* Invalid coding system. */
4733 if (!NILP (noerror
))
4734 coding_system
= Qraw_text
;
4736 xsignal1 (Qcoding_system_error
, coding_system
);
4740 object
= make_buffer_string (b
, e
, 0);
4741 set_buffer_internal (prev
);
4742 /* Discard the unwind protect for recovering the current
4746 if (STRING_MULTIBYTE (object
))
4747 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4749 end_byte
= SBYTES (object
);
4752 if (EQ (algorithm
, Qmd5
))
4754 digest_size
= MD5_DIGEST_SIZE
;
4755 hash_func
= md5_buffer
;
4757 else if (EQ (algorithm
, Qsha1
))
4759 digest_size
= SHA1_DIGEST_SIZE
;
4760 hash_func
= sha1_buffer
;
4762 else if (EQ (algorithm
, Qsha224
))
4764 digest_size
= SHA224_DIGEST_SIZE
;
4765 hash_func
= sha224_buffer
;
4767 else if (EQ (algorithm
, Qsha256
))
4769 digest_size
= SHA256_DIGEST_SIZE
;
4770 hash_func
= sha256_buffer
;
4772 else if (EQ (algorithm
, Qsha384
))
4774 digest_size
= SHA384_DIGEST_SIZE
;
4775 hash_func
= sha384_buffer
;
4777 else if (EQ (algorithm
, Qsha512
))
4779 digest_size
= SHA512_DIGEST_SIZE
;
4780 hash_func
= sha512_buffer
;
4783 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4785 /* allocate 2 x digest_size so that it can be re-used to hold the
4787 digest
= make_uninit_string (digest_size
* 2);
4789 hash_func (SSDATA (object
) + start_byte
,
4790 end_byte
- start_byte
,
4795 unsigned char *p
= SDATA (digest
);
4796 for (i
= digest_size
- 1; i
>= 0; i
--)
4798 static char const hexdigit
[16] = "0123456789abcdef";
4800 p
[2 * i
] = hexdigit
[p_i
>> 4];
4801 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4806 return make_unibyte_string (SSDATA (digest
), digest_size
);
4809 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4810 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4812 A message digest is a cryptographic checksum of a document, and the
4813 algorithm to calculate it is defined in RFC 1321.
4815 The two optional arguments START and END are character positions
4816 specifying for which part of OBJECT the message digest should be
4817 computed. If nil or omitted, the digest is computed for the whole
4820 The MD5 message digest is computed from the result of encoding the
4821 text in a coding system, not directly from the internal Emacs form of
4822 the text. The optional fourth argument CODING-SYSTEM specifies which
4823 coding system to encode the text with. It should be the same coding
4824 system that you used or will use when actually writing the text into a
4827 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4828 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4829 system would be chosen by default for writing this text into a file.
4831 If OBJECT is a string, the most preferred coding system (see the
4832 command `prefer-coding-system') is used.
4834 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4835 guesswork fails. Normally, an error is signaled in such case. */)
4836 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4838 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4841 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4842 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4843 ALGORITHM is a symbol specifying the hash to use:
4844 md5, sha1, sha224, sha256, sha384 or sha512.
4846 The two optional arguments START and END are positions specifying for
4847 which part of OBJECT to compute the hash. If nil or omitted, uses the
4850 If BINARY is non-nil, returns a string in binary form. */)
4851 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4853 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4859 DEFSYM (Qmd5
, "md5");
4860 DEFSYM (Qsha1
, "sha1");
4861 DEFSYM (Qsha224
, "sha224");
4862 DEFSYM (Qsha256
, "sha256");
4863 DEFSYM (Qsha384
, "sha384");
4864 DEFSYM (Qsha512
, "sha512");
4866 /* Hash table stuff. */
4867 DEFSYM (Qhash_table_p
, "hash-table-p");
4869 DEFSYM (Qeql
, "eql");
4870 DEFSYM (Qequal
, "equal");
4871 DEFSYM (QCtest
, ":test");
4872 DEFSYM (QCsize
, ":size");
4873 DEFSYM (QCrehash_size
, ":rehash-size");
4874 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4875 DEFSYM (QCweakness
, ":weakness");
4876 DEFSYM (Qkey
, "key");
4877 DEFSYM (Qvalue
, "value");
4878 DEFSYM (Qhash_table_test
, "hash-table-test");
4879 DEFSYM (Qkey_or_value
, "key-or-value");
4880 DEFSYM (Qkey_and_value
, "key-and-value");
4883 defsubr (&Smake_hash_table
);
4884 defsubr (&Scopy_hash_table
);
4885 defsubr (&Shash_table_count
);
4886 defsubr (&Shash_table_rehash_size
);
4887 defsubr (&Shash_table_rehash_threshold
);
4888 defsubr (&Shash_table_size
);
4889 defsubr (&Shash_table_test
);
4890 defsubr (&Shash_table_weakness
);
4891 defsubr (&Shash_table_p
);
4892 defsubr (&Sclrhash
);
4893 defsubr (&Sgethash
);
4894 defsubr (&Sputhash
);
4895 defsubr (&Sremhash
);
4896 defsubr (&Smaphash
);
4897 defsubr (&Sdefine_hash_table_test
);
4899 DEFSYM (Qstring_lessp
, "string-lessp");
4900 DEFSYM (Qprovide
, "provide");
4901 DEFSYM (Qrequire
, "require");
4902 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4903 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4904 DEFSYM (Qwidget_type
, "widget-type");
4906 staticpro (&string_char_byte_cache_string
);
4907 string_char_byte_cache_string
= Qnil
;
4909 require_nesting_list
= Qnil
;
4910 staticpro (&require_nesting_list
);
4912 Fset (Qyes_or_no_p_history
, Qnil
);
4914 DEFVAR_LISP ("features", Vfeatures
,
4915 doc
: /* A list of symbols which are the features of the executing Emacs.
4916 Used by `featurep' and `require', and altered by `provide'. */);
4917 Vfeatures
= list1 (intern_c_string ("emacs"));
4918 DEFSYM (Qsubfeatures
, "subfeatures");
4919 DEFSYM (Qfuncall
, "funcall");
4921 #ifdef HAVE_LANGINFO_CODESET
4922 DEFSYM (Qcodeset
, "codeset");
4923 DEFSYM (Qdays
, "days");
4924 DEFSYM (Qmonths
, "months");
4925 DEFSYM (Qpaper
, "paper");
4926 #endif /* HAVE_LANGINFO_CODESET */
4928 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4929 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4930 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4931 invoked by mouse clicks and mouse menu items.
4933 On some platforms, file selection dialogs are also enabled if this is
4937 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4938 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4939 This applies to commands from menus and tool bar buttons even when
4940 they are initiated from the keyboard. If `use-dialog-box' is nil,
4941 that disables the use of a file dialog, regardless of the value of
4943 use_file_dialog
= 1;
4945 defsubr (&Sidentity
);
4948 defsubr (&Ssafe_length
);
4949 defsubr (&Sstring_bytes
);
4950 defsubr (&Sstring_equal
);
4951 defsubr (&Scompare_strings
);
4952 defsubr (&Sstring_lessp
);
4955 defsubr (&Svconcat
);
4956 defsubr (&Scopy_sequence
);
4957 defsubr (&Sstring_make_multibyte
);
4958 defsubr (&Sstring_make_unibyte
);
4959 defsubr (&Sstring_as_multibyte
);
4960 defsubr (&Sstring_as_unibyte
);
4961 defsubr (&Sstring_to_multibyte
);
4962 defsubr (&Sstring_to_unibyte
);
4963 defsubr (&Scopy_alist
);
4964 defsubr (&Ssubstring
);
4965 defsubr (&Ssubstring_no_properties
);
4978 defsubr (&Snreverse
);
4979 defsubr (&Sreverse
);
4981 defsubr (&Splist_get
);
4983 defsubr (&Splist_put
);
4985 defsubr (&Slax_plist_get
);
4986 defsubr (&Slax_plist_put
);
4989 defsubr (&Sequal_including_properties
);
4990 defsubr (&Sfillarray
);
4991 defsubr (&Sclear_string
);
4995 defsubr (&Smapconcat
);
4996 defsubr (&Syes_or_no_p
);
4997 defsubr (&Sload_average
);
4998 defsubr (&Sfeaturep
);
4999 defsubr (&Srequire
);
5000 defsubr (&Sprovide
);
5001 defsubr (&Splist_member
);
5002 defsubr (&Swidget_put
);
5003 defsubr (&Swidget_get
);
5004 defsubr (&Swidget_apply
);
5005 defsubr (&Sbase64_encode_region
);
5006 defsubr (&Sbase64_decode_region
);
5007 defsubr (&Sbase64_encode_string
);
5008 defsubr (&Sbase64_decode_string
);
5010 defsubr (&Ssecure_hash
);
5011 defsubr (&Slocale_info
);
5013 hashtest_eq
.name
= Qeq
;
5014 hashtest_eq
.user_hash_function
= Qnil
;
5015 hashtest_eq
.user_cmp_function
= Qnil
;
5016 hashtest_eq
.cmpfn
= 0;
5017 hashtest_eq
.hashfn
= hashfn_eq
;
5019 hashtest_eql
.name
= Qeql
;
5020 hashtest_eql
.user_hash_function
= Qnil
;
5021 hashtest_eql
.user_cmp_function
= Qnil
;
5022 hashtest_eql
.cmpfn
= cmpfn_eql
;
5023 hashtest_eql
.hashfn
= hashfn_eql
;
5025 hashtest_equal
.name
= Qequal
;
5026 hashtest_equal
.user_hash_function
= Qnil
;
5027 hashtest_equal
.user_cmp_function
= Qnil
;
5028 hashtest_equal
.cmpfn
= cmpfn_equal
;
5029 hashtest_equal
.hashfn
= hashfn_equal
;