1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
43 Lisp_Object Qstring_lessp
;
44 static Lisp_Object Qprovide
, Qrequire
;
45 static Lisp_Object Qyes_or_no_p_history
;
46 Lisp_Object Qcursor_in_echo_area
;
47 static Lisp_Object Qwidget_type
;
48 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
50 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
52 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
54 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
55 doc
: /* Return the argument unchanged. */)
61 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
62 doc
: /* Return a pseudo-random number.
63 All integers representable in Lisp, i.e. between `most-negative-fixnum'
64 and `most-positive-fixnum', inclusive, are equally likely.
66 With positive integer LIMIT, return random number in interval [0,LIMIT).
67 With argument t, set the random number seed from the current time and pid.
68 With a string argument, set the seed based on the string's contents.
69 Other values of LIMIT are ignored.
71 See Info node `(elisp)Random Numbers' for more details. */)
78 else if (STRINGP (limit
))
79 seed_random (SSDATA (limit
), SBYTES (limit
));
82 if (INTEGERP (limit
) && 0 < XINT (limit
))
85 /* Return the remainder, except reject the rare case where
86 get_random returns a number so close to INTMASK that the
87 remainder isn't random. */
88 EMACS_INT remainder
= val
% XINT (limit
);
89 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
90 return make_number (remainder
);
93 return make_number (val
);
96 /* Heuristic on how many iterations of a tight loop can be safely done
97 before it's time to do a QUIT. This must be a power of 2. */
98 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
100 /* Random data-structure functions. */
103 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
105 CHECK_TYPE (NILP (x
), Qlistp
, y
);
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
118 if (STRINGP (sequence
))
119 XSETFASTINT (val
, SCHARS (sequence
));
120 else if (VECTORP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
));
122 else if (CHAR_TABLE_P (sequence
))
123 XSETFASTINT (val
, MAX_CHAR
);
124 else if (BOOL_VECTOR_P (sequence
))
125 XSETFASTINT (val
, bool_vector_size (sequence
));
126 else if (COMPILEDP (sequence
))
127 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
128 else if (CONSP (sequence
))
135 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
137 if (MOST_POSITIVE_FIXNUM
< i
)
138 error ("List too long");
141 sequence
= XCDR (sequence
);
143 while (CONSP (sequence
));
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
158 doc
: /* Return the length of a list, but avoid error or infinite loop.
159 This function never gets an error. If LIST is not really a list,
160 it returns 0. If LIST is circular, it returns a finite value
161 which is at least the number of distinct elements. */)
164 Lisp_Object tail
, halftail
;
169 return make_number (0);
171 /* halftail is used to detect circular lists. */
172 for (tail
= halftail
= list
; ; )
177 if (EQ (tail
, halftail
))
180 if ((lolen
& 1) == 0)
182 halftail
= XCDR (halftail
);
183 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
187 hilen
+= UINTMAX_MAX
+ 1.0;
192 /* If the length does not fit into a fixnum, return a float.
193 On all known practical machines this returns an upper bound on
195 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 doc
: /* Return the number of bytes in STRING.
200 If STRING is multibyte, this may be greater than the length of STRING. */)
203 CHECK_STRING (string
);
204 return make_number (SBYTES (string
));
207 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
208 doc
: /* Return t if two strings have identical contents.
209 Case is significant, but text properties are ignored.
210 Symbols are also allowed; their print names are used instead. */)
211 (register Lisp_Object s1
, Lisp_Object s2
)
214 s1
= SYMBOL_NAME (s1
);
216 s2
= SYMBOL_NAME (s2
);
220 if (SCHARS (s1
) != SCHARS (s2
)
221 || SBYTES (s1
) != SBYTES (s2
)
222 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
227 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
228 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
229 The arguments START1, END1, START2, and END2, if non-nil, are
230 positions specifying which parts of STR1 or STR2 to compare. In
231 string STR1, compare the part between START1 (inclusive) and END1
232 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
233 the string; if END1 is nil, it defaults to the length of the string.
234 Likewise, in string STR2, compare the part between START2 and END2.
236 The strings are compared by the numeric values of their characters.
237 For instance, STR1 is "less than" STR2 if its first differing
238 character has a smaller numeric value. If IGNORE-CASE is non-nil,
239 characters are converted to lower-case before comparing them. Unibyte
240 strings are converted to multibyte for comparison.
242 The value is t if the strings (or specified portions) match.
243 If string STR1 is less, the value is a negative number N;
244 - 1 - N is the number of characters that match at the beginning.
245 If string STR1 is greater, the value is a positive number N;
246 N - 1 is the number of characters that match at the beginning. */)
247 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
249 register ptrdiff_t end1_char
, end2_char
;
250 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
255 start1
= make_number (0);
257 start2
= make_number (0);
258 CHECK_NATNUM (start1
);
259 CHECK_NATNUM (start2
);
265 end1_char
= SCHARS (str1
);
266 if (! NILP (end1
) && end1_char
> XINT (end1
))
267 end1_char
= XINT (end1
);
268 if (end1_char
< XINT (start1
))
269 args_out_of_range (str1
, start1
);
271 end2_char
= SCHARS (str2
);
272 if (! NILP (end2
) && end2_char
> XINT (end2
))
273 end2_char
= XINT (end2
);
274 if (end2_char
< XINT (start2
))
275 args_out_of_range (str2
, start2
);
280 i1_byte
= string_char_to_byte (str1
, i1
);
281 i2_byte
= string_char_to_byte (str2
, i2
);
283 while (i1
< end1_char
&& i2
< end2_char
)
285 /* When we find a mismatch, we must compare the
286 characters, not just the bytes. */
289 if (STRING_MULTIBYTE (str1
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
293 c1
= SREF (str1
, i1
++);
294 MAKE_CHAR_MULTIBYTE (c1
);
297 if (STRING_MULTIBYTE (str2
))
298 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
301 c2
= SREF (str2
, i2
++);
302 MAKE_CHAR_MULTIBYTE (c2
);
308 if (! NILP (ignore_case
))
312 tem
= Fupcase (make_number (c1
));
314 tem
= Fupcase (make_number (c2
));
321 /* Note that I1 has already been incremented
322 past the character that we are comparing;
323 hence we don't add or subtract 1 here. */
325 return make_number (- i1
+ XINT (start1
));
327 return make_number (i1
- XINT (start1
));
331 return make_number (i1
- XINT (start1
) + 1);
333 return make_number (- i1
+ XINT (start1
) - 1);
338 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
339 doc
: /* Return t if first arg string is less than second in lexicographic order.
341 Symbols are also allowed; their print names are used instead. */)
342 (register Lisp_Object s1
, Lisp_Object s2
)
344 register ptrdiff_t end
;
345 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
348 s1
= SYMBOL_NAME (s1
);
350 s2
= SYMBOL_NAME (s2
);
354 i1
= i1_byte
= i2
= i2_byte
= 0;
357 if (end
> SCHARS (s2
))
362 /* When we find a mismatch, we must compare the
363 characters, not just the bytes. */
366 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
367 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
370 return c1
< c2
? Qt
: Qnil
;
372 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
375 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
376 enum Lisp_Type target_type
, bool last_special
);
380 concat2 (Lisp_Object s1
, Lisp_Object s2
)
385 return concat (2, args
, Lisp_String
, 0);
390 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
396 return concat (3, args
, Lisp_String
, 0);
399 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
400 doc
: /* Concatenate all the arguments and make the result a list.
401 The result is a list whose elements are the elements of all the arguments.
402 Each argument may be a list, vector or string.
403 The last argument is not copied, just used as the tail of the new list.
404 usage: (append &rest SEQUENCES) */)
405 (ptrdiff_t nargs
, Lisp_Object
*args
)
407 return concat (nargs
, args
, Lisp_Cons
, 1);
410 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
411 doc
: /* Concatenate all the arguments and make the result a string.
412 The result is a string whose elements are the elements of all the arguments.
413 Each argument may be a string or a list or vector of characters (integers).
414 usage: (concat &rest SEQUENCES) */)
415 (ptrdiff_t nargs
, Lisp_Object
*args
)
417 return concat (nargs
, args
, Lisp_String
, 0);
420 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
421 doc
: /* Concatenate all the arguments and make the result a vector.
422 The result is a vector whose elements are the elements of all the arguments.
423 Each argument may be a list, vector or string.
424 usage: (vconcat &rest SEQUENCES) */)
425 (ptrdiff_t nargs
, Lisp_Object
*args
)
427 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
431 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
432 doc
: /* Return a copy of a list, vector, string or char-table.
433 The elements of a list or vector are not copied; they are shared
434 with the original. */)
437 if (NILP (arg
)) return arg
;
439 if (CHAR_TABLE_P (arg
))
441 return copy_char_table (arg
);
444 if (BOOL_VECTOR_P (arg
))
446 EMACS_INT nbits
= bool_vector_size (arg
);
447 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
448 Lisp_Object val
= make_uninit_bool_vector (nbits
);
449 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
453 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
454 wrong_type_argument (Qsequencep
, arg
);
456 return concat (1, &arg
, XTYPE (arg
), 0);
459 /* This structure holds information of an argument of `concat' that is
460 a string and has text properties to be copied. */
463 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
464 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
465 ptrdiff_t to
; /* refer to VAL (the target string) */
469 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
470 enum Lisp_Type target_type
, bool last_special
)
476 ptrdiff_t toindex_byte
= 0;
477 EMACS_INT result_len
;
478 EMACS_INT result_len_byte
;
480 Lisp_Object last_tail
;
483 /* When we make a multibyte string, we can't copy text properties
484 while concatenating each string because the length of resulting
485 string can't be decided until we finish the whole concatenation.
486 So, we record strings that have text properties to be copied
487 here, and copy the text properties after the concatenation. */
488 struct textprop_rec
*textprops
= NULL
;
489 /* Number of elements in textprops. */
490 ptrdiff_t num_textprops
= 0;
495 /* In append, the last arg isn't treated like the others */
496 if (last_special
&& nargs
> 0)
499 last_tail
= args
[nargs
];
504 /* Check each argument. */
505 for (argnum
= 0; argnum
< nargs
; argnum
++)
508 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
509 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
510 wrong_type_argument (Qsequencep
, this);
513 /* Compute total length in chars of arguments in RESULT_LEN.
514 If desired output is a string, also compute length in bytes
515 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
516 whether the result should be a multibyte string. */
520 for (argnum
= 0; argnum
< nargs
; argnum
++)
524 len
= XFASTINT (Flength (this));
525 if (target_type
== Lisp_String
)
527 /* We must count the number of bytes needed in the string
528 as well as the number of characters. */
532 ptrdiff_t this_len_byte
;
534 if (VECTORP (this) || COMPILEDP (this))
535 for (i
= 0; i
< len
; i
++)
538 CHECK_CHARACTER (ch
);
540 this_len_byte
= CHAR_BYTES (c
);
541 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
543 result_len_byte
+= this_len_byte
;
544 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
547 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
548 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
549 else if (CONSP (this))
550 for (; CONSP (this); this = XCDR (this))
553 CHECK_CHARACTER (ch
);
555 this_len_byte
= CHAR_BYTES (c
);
556 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
558 result_len_byte
+= this_len_byte
;
559 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
562 else if (STRINGP (this))
564 if (STRING_MULTIBYTE (this))
567 this_len_byte
= SBYTES (this);
570 this_len_byte
= count_size_as_multibyte (SDATA (this),
572 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
574 result_len_byte
+= this_len_byte
;
579 if (MOST_POSITIVE_FIXNUM
< result_len
)
580 memory_full (SIZE_MAX
);
583 if (! some_multibyte
)
584 result_len_byte
= result_len
;
586 /* Create the output object. */
587 if (target_type
== Lisp_Cons
)
588 val
= Fmake_list (make_number (result_len
), Qnil
);
589 else if (target_type
== Lisp_Vectorlike
)
590 val
= Fmake_vector (make_number (result_len
), Qnil
);
591 else if (some_multibyte
)
592 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
594 val
= make_uninit_string (result_len
);
596 /* In `append', if all but last arg are nil, return last arg. */
597 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
600 /* Copy the contents of the args into the result. */
602 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
604 toindex
= 0, toindex_byte
= 0;
608 SAFE_NALLOCA (textprops
, 1, nargs
);
610 for (argnum
= 0; argnum
< nargs
; argnum
++)
613 ptrdiff_t thisleni
= 0;
614 register ptrdiff_t thisindex
= 0;
615 register ptrdiff_t thisindex_byte
= 0;
619 thislen
= Flength (this), thisleni
= XINT (thislen
);
621 /* Between strings of the same kind, copy fast. */
622 if (STRINGP (this) && STRINGP (val
)
623 && STRING_MULTIBYTE (this) == some_multibyte
)
625 ptrdiff_t thislen_byte
= SBYTES (this);
627 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
628 if (string_intervals (this))
630 textprops
[num_textprops
].argnum
= argnum
;
631 textprops
[num_textprops
].from
= 0;
632 textprops
[num_textprops
++].to
= toindex
;
634 toindex_byte
+= thislen_byte
;
637 /* Copy a single-byte string to a multibyte string. */
638 else if (STRINGP (this) && STRINGP (val
))
640 if (string_intervals (this))
642 textprops
[num_textprops
].argnum
= argnum
;
643 textprops
[num_textprops
].from
= 0;
644 textprops
[num_textprops
++].to
= toindex
;
646 toindex_byte
+= copy_text (SDATA (this),
647 SDATA (val
) + toindex_byte
,
648 SCHARS (this), 0, 1);
652 /* Copy element by element. */
655 register Lisp_Object elt
;
657 /* Fetch next element of `this' arg into `elt', or break if
658 `this' is exhausted. */
659 if (NILP (this)) break;
661 elt
= XCAR (this), this = XCDR (this);
662 else if (thisindex
>= thisleni
)
664 else if (STRINGP (this))
667 if (STRING_MULTIBYTE (this))
668 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
673 c
= SREF (this, thisindex
); thisindex
++;
674 if (some_multibyte
&& !ASCII_CHAR_P (c
))
675 c
= BYTE8_TO_CHAR (c
);
677 XSETFASTINT (elt
, c
);
679 else if (BOOL_VECTOR_P (this))
681 elt
= bool_vector_ref (this, thisindex
);
686 elt
= AREF (this, thisindex
);
690 /* Store this element into the result. */
697 else if (VECTORP (val
))
699 ASET (val
, toindex
, elt
);
705 CHECK_CHARACTER (elt
);
708 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
710 SSET (val
, toindex_byte
++, c
);
716 XSETCDR (prev
, last_tail
);
718 if (num_textprops
> 0)
721 ptrdiff_t last_to_end
= -1;
723 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
725 this = args
[textprops
[argnum
].argnum
];
726 props
= text_property_list (this,
728 make_number (SCHARS (this)),
730 /* If successive arguments have properties, be sure that the
731 value of `composition' property be the copy. */
732 if (last_to_end
== textprops
[argnum
].to
)
733 make_composition_value_copy (props
);
734 add_text_properties_from_list (val
, props
,
735 make_number (textprops
[argnum
].to
));
736 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
744 static Lisp_Object string_char_byte_cache_string
;
745 static ptrdiff_t string_char_byte_cache_charpos
;
746 static ptrdiff_t string_char_byte_cache_bytepos
;
749 clear_string_char_byte_cache (void)
751 string_char_byte_cache_string
= Qnil
;
754 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
757 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
760 ptrdiff_t best_below
, best_below_byte
;
761 ptrdiff_t best_above
, best_above_byte
;
763 best_below
= best_below_byte
= 0;
764 best_above
= SCHARS (string
);
765 best_above_byte
= SBYTES (string
);
766 if (best_above
== best_above_byte
)
769 if (EQ (string
, string_char_byte_cache_string
))
771 if (string_char_byte_cache_charpos
< char_index
)
773 best_below
= string_char_byte_cache_charpos
;
774 best_below_byte
= string_char_byte_cache_bytepos
;
778 best_above
= string_char_byte_cache_charpos
;
779 best_above_byte
= string_char_byte_cache_bytepos
;
783 if (char_index
- best_below
< best_above
- char_index
)
785 unsigned char *p
= SDATA (string
) + best_below_byte
;
787 while (best_below
< char_index
)
789 p
+= BYTES_BY_CHAR_HEAD (*p
);
792 i_byte
= p
- SDATA (string
);
796 unsigned char *p
= SDATA (string
) + best_above_byte
;
798 while (best_above
> char_index
)
801 while (!CHAR_HEAD_P (*p
)) p
--;
804 i_byte
= p
- SDATA (string
);
807 string_char_byte_cache_bytepos
= i_byte
;
808 string_char_byte_cache_charpos
= char_index
;
809 string_char_byte_cache_string
= string
;
814 /* Return the character index corresponding to BYTE_INDEX in STRING. */
817 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
820 ptrdiff_t best_below
, best_below_byte
;
821 ptrdiff_t best_above
, best_above_byte
;
823 best_below
= best_below_byte
= 0;
824 best_above
= SCHARS (string
);
825 best_above_byte
= SBYTES (string
);
826 if (best_above
== best_above_byte
)
829 if (EQ (string
, string_char_byte_cache_string
))
831 if (string_char_byte_cache_bytepos
< byte_index
)
833 best_below
= string_char_byte_cache_charpos
;
834 best_below_byte
= string_char_byte_cache_bytepos
;
838 best_above
= string_char_byte_cache_charpos
;
839 best_above_byte
= string_char_byte_cache_bytepos
;
843 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
845 unsigned char *p
= SDATA (string
) + best_below_byte
;
846 unsigned char *pend
= SDATA (string
) + byte_index
;
850 p
+= BYTES_BY_CHAR_HEAD (*p
);
854 i_byte
= p
- SDATA (string
);
858 unsigned char *p
= SDATA (string
) + best_above_byte
;
859 unsigned char *pbeg
= SDATA (string
) + byte_index
;
864 while (!CHAR_HEAD_P (*p
)) p
--;
868 i_byte
= p
- SDATA (string
);
871 string_char_byte_cache_bytepos
= i_byte
;
872 string_char_byte_cache_charpos
= i
;
873 string_char_byte_cache_string
= string
;
878 /* Convert STRING to a multibyte string. */
881 string_make_multibyte (Lisp_Object string
)
888 if (STRING_MULTIBYTE (string
))
891 nbytes
= count_size_as_multibyte (SDATA (string
),
893 /* If all the chars are ASCII, they won't need any more bytes
894 once converted. In that case, we can return STRING itself. */
895 if (nbytes
== SBYTES (string
))
898 buf
= SAFE_ALLOCA (nbytes
);
899 copy_text (SDATA (string
), buf
, SBYTES (string
),
902 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
909 /* Convert STRING (if unibyte) to a multibyte string without changing
910 the number of characters. Characters 0200 trough 0237 are
911 converted to eight-bit characters. */
914 string_to_multibyte (Lisp_Object string
)
921 if (STRING_MULTIBYTE (string
))
924 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
925 /* If all the chars are ASCII, they won't need any more bytes once
927 if (nbytes
== SBYTES (string
))
928 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
930 buf
= SAFE_ALLOCA (nbytes
);
931 memcpy (buf
, SDATA (string
), SBYTES (string
));
932 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
934 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
941 /* Convert STRING to a single-byte string. */
944 string_make_unibyte (Lisp_Object string
)
951 if (! STRING_MULTIBYTE (string
))
954 nchars
= SCHARS (string
);
956 buf
= SAFE_ALLOCA (nchars
);
957 copy_text (SDATA (string
), buf
, SBYTES (string
),
960 ret
= make_unibyte_string ((char *) buf
, nchars
);
966 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
968 doc
: /* Return the multibyte equivalent of STRING.
969 If STRING is unibyte and contains non-ASCII characters, the function
970 `unibyte-char-to-multibyte' is used to convert each unibyte character
971 to a multibyte character. In this case, the returned string is a
972 newly created string with no text properties. If STRING is multibyte
973 or entirely ASCII, it is returned unchanged. In particular, when
974 STRING is unibyte and entirely ASCII, the returned string is unibyte.
975 \(When the characters are all ASCII, Emacs primitives will treat the
976 string the same way whether it is unibyte or multibyte.) */)
979 CHECK_STRING (string
);
981 return string_make_multibyte (string
);
984 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
986 doc
: /* Return the unibyte equivalent of STRING.
987 Multibyte character codes are converted to unibyte according to
988 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
989 If the lookup in the translation table fails, this function takes just
990 the low 8 bits of each character. */)
993 CHECK_STRING (string
);
995 return string_make_unibyte (string
);
998 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1000 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1001 If STRING is unibyte, the result is STRING itself.
1002 Otherwise it is a newly created string, with no text properties.
1003 If STRING is multibyte and contains a character of charset
1004 `eight-bit', it is converted to the corresponding single byte. */)
1005 (Lisp_Object string
)
1007 CHECK_STRING (string
);
1009 if (STRING_MULTIBYTE (string
))
1011 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1012 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1014 string
= make_unibyte_string ((char *) str
, bytes
);
1020 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1022 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1023 If STRING is multibyte, the result is STRING itself.
1024 Otherwise it is a newly created string, with no text properties.
1026 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1027 part of a correct utf-8 sequence), it is converted to the corresponding
1028 multibyte character of charset `eight-bit'.
1029 See also `string-to-multibyte'.
1031 Beware, this often doesn't really do what you think it does.
1032 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1033 If you're not sure, whether to use `string-as-multibyte' or
1034 `string-to-multibyte', use `string-to-multibyte'. */)
1035 (Lisp_Object string
)
1037 CHECK_STRING (string
);
1039 if (! STRING_MULTIBYTE (string
))
1041 Lisp_Object new_string
;
1042 ptrdiff_t nchars
, nbytes
;
1044 parse_str_as_multibyte (SDATA (string
),
1047 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1048 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1049 if (nbytes
!= SBYTES (string
))
1050 str_as_multibyte (SDATA (new_string
), nbytes
,
1051 SBYTES (string
), NULL
);
1052 string
= new_string
;
1053 set_string_intervals (string
, NULL
);
1058 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1060 doc
: /* Return a multibyte string with the same individual chars as STRING.
1061 If STRING is multibyte, the result is STRING itself.
1062 Otherwise it is a newly created string, with no text properties.
1064 If STRING is unibyte and contains an 8-bit byte, it is converted to
1065 the corresponding multibyte character of charset `eight-bit'.
1067 This differs from `string-as-multibyte' by converting each byte of a correct
1068 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1069 correct sequence. */)
1070 (Lisp_Object string
)
1072 CHECK_STRING (string
);
1074 return string_to_multibyte (string
);
1077 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1079 doc
: /* Return a unibyte string with the same individual chars as STRING.
1080 If STRING is unibyte, the result is STRING itself.
1081 Otherwise it is a newly created string, with no text properties,
1082 where each `eight-bit' character is converted to the corresponding byte.
1083 If STRING contains a non-ASCII, non-`eight-bit' character,
1084 an error is signaled. */)
1085 (Lisp_Object string
)
1087 CHECK_STRING (string
);
1089 if (STRING_MULTIBYTE (string
))
1091 ptrdiff_t chars
= SCHARS (string
);
1092 unsigned char *str
= xmalloc (chars
);
1093 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1095 if (converted
< chars
)
1096 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1097 string
= make_unibyte_string ((char *) str
, chars
);
1104 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1105 doc
: /* Return a copy of ALIST.
1106 This is an alist which represents the same mapping from objects to objects,
1107 but does not share the alist structure with ALIST.
1108 The objects mapped (cars and cdrs of elements of the alist)
1109 are shared, however.
1110 Elements of ALIST that are not conses are also shared. */)
1113 register Lisp_Object tem
;
1118 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1119 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1121 register Lisp_Object car
;
1125 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1130 /* True if [FROM..TO) specifies a valid substring of SIZE-characters string.
1131 If FROM is nil, 0 assumed. If TO is nil, SIZE assumed. Negative
1132 values are counted from the end. *FROM_CHAR and *TO_CHAR are updated
1133 with corresponding C values of TO and FROM. */
1136 validate_substring (Lisp_Object from
, Lisp_Object to
, ptrdiff_t size
,
1137 EMACS_INT
*from_char
, EMACS_INT
*to_char
)
1143 CHECK_NUMBER (from
);
1144 *from_char
= XINT (from
);
1154 *to_char
= XINT (to
);
1159 return (0 <= *from_char
&& *from_char
<= *to_char
&& *to_char
<= size
);
1162 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1163 doc
: /* Return a new string whose contents are a substring of STRING.
1164 The returned string consists of the characters between index FROM
1165 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1166 zero-indexed: 0 means the first character of STRING. Negative values
1167 are counted from the end of STRING. If TO is nil, the substring runs
1168 to the end of STRING.
1170 The STRING argument may also be a vector. In that case, the return
1171 value is a new vector that contains the elements between index FROM
1172 \(inclusive) and index TO (exclusive) of that vector argument.
1174 With one argument, just copy STRING (with properties, if any). */)
1175 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1179 EMACS_INT from_char
, to_char
;
1181 if (STRINGP (string
))
1182 size
= SCHARS (string
);
1183 else if (VECTORP (string
))
1184 size
= ASIZE (string
);
1186 wrong_type_argument (Qarrayp
, string
);
1188 if (!validate_substring (from
, to
, size
, &from_char
, &to_char
))
1189 args_out_of_range_3 (string
, make_number (from_char
),
1190 make_number (to_char
));
1192 if (STRINGP (string
))
1195 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1196 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1197 res
= make_specified_string (SSDATA (string
) + from_byte
,
1198 to_char
- from_char
, to_byte
- from_byte
,
1199 STRING_MULTIBYTE (string
));
1200 copy_text_properties (make_number (from_char
), make_number (to_char
),
1201 string
, make_number (0), res
, Qnil
);
1204 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1210 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1211 doc
: /* Return a substring of STRING, without text properties.
1212 It starts at index FROM and ends before TO.
1213 TO may be nil or omitted; then the substring runs to the end of STRING.
1214 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1215 If FROM or TO is negative, it counts from the end.
1217 With one argument, just copy STRING without its properties. */)
1218 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1221 EMACS_INT from_char
, to_char
;
1222 ptrdiff_t from_byte
, to_byte
;
1224 CHECK_STRING (string
);
1226 size
= SCHARS (string
);
1228 if (!validate_substring (from
, to
, size
, &from_char
, &to_char
))
1229 args_out_of_range_3 (string
, make_number (from_char
),
1230 make_number (to_char
));
1232 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1234 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1235 return make_specified_string (SSDATA (string
) + from_byte
,
1236 to_char
- from_char
, to_byte
- from_byte
,
1237 STRING_MULTIBYTE (string
));
1240 /* Extract a substring of STRING, giving start and end positions
1241 both in characters and in bytes. */
1244 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1245 ptrdiff_t to
, ptrdiff_t to_byte
)
1250 CHECK_VECTOR_OR_STRING (string
);
1252 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1254 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1255 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1257 if (STRINGP (string
))
1259 res
= make_specified_string (SSDATA (string
) + from_byte
,
1260 to
- from
, to_byte
- from_byte
,
1261 STRING_MULTIBYTE (string
));
1262 copy_text_properties (make_number (from
), make_number (to
),
1263 string
, make_number (0), res
, Qnil
);
1266 res
= Fvector (to
- from
, aref_addr (string
, from
));
1271 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1272 doc
: /* Take cdr N times on LIST, return the result. */)
1273 (Lisp_Object n
, Lisp_Object list
)
1278 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1281 CHECK_LIST_CONS (list
, list
);
1287 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1288 doc
: /* Return the Nth element of LIST.
1289 N counts from zero. If LIST is not that long, nil is returned. */)
1290 (Lisp_Object n
, Lisp_Object list
)
1292 return Fcar (Fnthcdr (n
, list
));
1295 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1296 doc
: /* Return element of SEQUENCE at index N. */)
1297 (register Lisp_Object sequence
, Lisp_Object n
)
1300 if (CONSP (sequence
) || NILP (sequence
))
1301 return Fcar (Fnthcdr (n
, sequence
));
1303 /* Faref signals a "not array" error, so check here. */
1304 CHECK_ARRAY (sequence
, Qsequencep
);
1305 return Faref (sequence
, n
);
1308 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1309 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1310 The value is actually the tail of LIST whose car is ELT. */)
1311 (register Lisp_Object elt
, Lisp_Object list
)
1313 register Lisp_Object tail
;
1314 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1316 register Lisp_Object tem
;
1317 CHECK_LIST_CONS (tail
, list
);
1319 if (! NILP (Fequal (elt
, tem
)))
1326 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1327 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1328 The value is actually the tail of LIST whose car is ELT. */)
1329 (register Lisp_Object elt
, Lisp_Object list
)
1333 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1337 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1341 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1352 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1353 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1354 The value is actually the tail of LIST whose car is ELT. */)
1355 (register Lisp_Object elt
, Lisp_Object list
)
1357 register Lisp_Object tail
;
1360 return Fmemq (elt
, list
);
1362 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1364 register Lisp_Object tem
;
1365 CHECK_LIST_CONS (tail
, list
);
1367 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1374 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1375 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1376 The value is actually the first element of LIST whose car is KEY.
1377 Elements of LIST that are not conses are ignored. */)
1378 (Lisp_Object key
, Lisp_Object list
)
1383 || (CONSP (XCAR (list
))
1384 && EQ (XCAR (XCAR (list
)), key
)))
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1395 || (CONSP (XCAR (list
))
1396 && EQ (XCAR (XCAR (list
)), key
)))
1406 /* Like Fassq but never report an error and do not allow quits.
1407 Use only on lists known never to be circular. */
1410 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1413 && (!CONSP (XCAR (list
))
1414 || !EQ (XCAR (XCAR (list
)), key
)))
1417 return CAR_SAFE (list
);
1420 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1421 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1422 The value is actually the first element of LIST whose car equals KEY. */)
1423 (Lisp_Object key
, Lisp_Object list
)
1430 || (CONSP (XCAR (list
))
1431 && (car
= XCAR (XCAR (list
)),
1432 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1437 || (CONSP (XCAR (list
))
1438 && (car
= XCAR (XCAR (list
)),
1439 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1444 || (CONSP (XCAR (list
))
1445 && (car
= XCAR (XCAR (list
)),
1446 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1456 /* Like Fassoc but never report an error and do not allow quits.
1457 Use only on lists known never to be circular. */
1460 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1463 && (!CONSP (XCAR (list
))
1464 || (!EQ (XCAR (XCAR (list
)), key
)
1465 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1468 return CONSP (list
) ? XCAR (list
) : Qnil
;
1471 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1472 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1473 The value is actually the first element of LIST whose cdr is KEY. */)
1474 (register Lisp_Object key
, Lisp_Object list
)
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCDR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCDR (XCAR (list
)), key
)))
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCDR (XCAR (list
)), key
)))
1502 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1503 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1504 The value is actually the first element of LIST whose cdr equals KEY. */)
1505 (Lisp_Object key
, Lisp_Object list
)
1512 || (CONSP (XCAR (list
))
1513 && (cdr
= XCDR (XCAR (list
)),
1514 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1519 || (CONSP (XCAR (list
))
1520 && (cdr
= XCDR (XCAR (list
)),
1521 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1526 || (CONSP (XCAR (list
))
1527 && (cdr
= XCDR (XCAR (list
)),
1528 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1538 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1539 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1540 More precisely, this function skips any members `eq' to ELT at the
1541 front of LIST, then removes members `eq' to ELT from the remaining
1542 sublist by modifying its list structure, then returns the resulting
1545 Write `(setq foo (delq element foo))' to be sure of correctly changing
1546 the value of a list `foo'. */)
1547 (register Lisp_Object elt
, Lisp_Object list
)
1549 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1552 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1554 Lisp_Object tem
= XCAR (tail
);
1560 Fsetcdr (prev
, XCDR (tail
));
1568 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1569 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1570 SEQ must be a sequence (i.e. a list, a vector, or a string).
1571 The return value is a sequence of the same type.
1573 If SEQ is a list, this behaves like `delq', except that it compares
1574 with `equal' instead of `eq'. In particular, it may remove elements
1575 by altering the list structure.
1577 If SEQ is not a list, deletion is never performed destructively;
1578 instead this function creates and returns a new vector or string.
1580 Write `(setq foo (delete element foo))' to be sure of correctly
1581 changing the value of a sequence `foo'. */)
1582 (Lisp_Object elt
, Lisp_Object seq
)
1588 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1589 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1592 if (n
!= ASIZE (seq
))
1594 struct Lisp_Vector
*p
= allocate_vector (n
);
1596 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1597 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1598 p
->contents
[n
++] = AREF (seq
, i
);
1600 XSETVECTOR (seq
, p
);
1603 else if (STRINGP (seq
))
1605 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1608 for (i
= nchars
= nbytes
= ibyte
= 0;
1610 ++i
, ibyte
+= cbytes
)
1612 if (STRING_MULTIBYTE (seq
))
1614 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1615 cbytes
= CHAR_BYTES (c
);
1623 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1630 if (nchars
!= SCHARS (seq
))
1634 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1635 if (!STRING_MULTIBYTE (seq
))
1636 STRING_SET_UNIBYTE (tem
);
1638 for (i
= nchars
= nbytes
= ibyte
= 0;
1640 ++i
, ibyte
+= cbytes
)
1642 if (STRING_MULTIBYTE (seq
))
1644 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1645 cbytes
= CHAR_BYTES (c
);
1653 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1655 unsigned char *from
= SDATA (seq
) + ibyte
;
1656 unsigned char *to
= SDATA (tem
) + nbytes
;
1662 for (n
= cbytes
; n
--; )
1672 Lisp_Object tail
, prev
;
1674 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1676 CHECK_LIST_CONS (tail
, seq
);
1678 if (!NILP (Fequal (elt
, XCAR (tail
))))
1683 Fsetcdr (prev
, XCDR (tail
));
1694 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1695 doc
: /* Reverse LIST by modifying cdr pointers.
1696 Return the reversed list. Expects a properly nil-terminated list. */)
1699 register Lisp_Object prev
, tail
, next
;
1701 if (NILP (list
)) return list
;
1704 while (!NILP (tail
))
1707 CHECK_LIST_CONS (tail
, tail
);
1709 Fsetcdr (tail
, prev
);
1716 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1717 doc
: /* Reverse LIST, copying. Return the reversed list.
1718 See also the function `nreverse', which is used more often. */)
1723 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1726 new = Fcons (XCAR (list
), new);
1728 CHECK_LIST_END (list
, list
);
1732 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1733 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1734 Returns the sorted list. LIST is modified by side effects.
1735 PREDICATE is called with two elements of LIST, and should return non-nil
1736 if the first element should sort before the second. */)
1737 (Lisp_Object list
, Lisp_Object predicate
)
1739 Lisp_Object front
, back
;
1740 register Lisp_Object len
, tem
;
1741 struct gcpro gcpro1
, gcpro2
;
1745 len
= Flength (list
);
1746 length
= XINT (len
);
1750 XSETINT (len
, (length
/ 2) - 1);
1751 tem
= Fnthcdr (len
, list
);
1753 Fsetcdr (tem
, Qnil
);
1755 GCPRO2 (front
, back
);
1756 front
= Fsort (front
, predicate
);
1757 back
= Fsort (back
, predicate
);
1759 return merge (front
, back
, predicate
);
1763 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1766 register Lisp_Object tail
;
1768 register Lisp_Object l1
, l2
;
1769 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1776 /* It is sufficient to protect org_l1 and org_l2.
1777 When l1 and l2 are updated, we copy the new values
1778 back into the org_ vars. */
1779 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1799 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1815 Fsetcdr (tail
, tem
);
1821 /* This does not check for quits. That is safe since it must terminate. */
1823 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1824 doc
: /* Extract a value from a property list.
1825 PLIST is a property list, which is a list of the form
1826 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1827 corresponding to the given PROP, or nil if PROP is not one of the
1828 properties on the list. This function never signals an error. */)
1829 (Lisp_Object plist
, Lisp_Object prop
)
1831 Lisp_Object tail
, halftail
;
1833 /* halftail is used to detect circular lists. */
1834 tail
= halftail
= plist
;
1835 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1837 if (EQ (prop
, XCAR (tail
)))
1838 return XCAR (XCDR (tail
));
1840 tail
= XCDR (XCDR (tail
));
1841 halftail
= XCDR (halftail
);
1842 if (EQ (tail
, halftail
))
1849 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1850 doc
: /* Return the value of SYMBOL's PROPNAME property.
1851 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1852 (Lisp_Object symbol
, Lisp_Object propname
)
1854 CHECK_SYMBOL (symbol
);
1855 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1858 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1859 doc
: /* Change value in PLIST of PROP to VAL.
1860 PLIST is a property list, which is a list of the form
1861 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1862 If PROP is already a property on the list, its value is set to VAL,
1863 otherwise the new PROP VAL pair is added. The new plist is returned;
1864 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1865 The PLIST is modified by side effects. */)
1866 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1868 register Lisp_Object tail
, prev
;
1869 Lisp_Object newcell
;
1871 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1872 tail
= XCDR (XCDR (tail
)))
1874 if (EQ (prop
, XCAR (tail
)))
1876 Fsetcar (XCDR (tail
), val
);
1883 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1887 Fsetcdr (XCDR (prev
), newcell
);
1891 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1892 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1893 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1894 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1896 CHECK_SYMBOL (symbol
);
1898 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1902 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1903 doc
: /* Extract a value from a property list, comparing with `equal'.
1904 PLIST is a property list, which is a list of the form
1905 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1906 corresponding to the given PROP, or nil if PROP is not
1907 one of the properties on the list. */)
1908 (Lisp_Object plist
, Lisp_Object prop
)
1913 CONSP (tail
) && CONSP (XCDR (tail
));
1914 tail
= XCDR (XCDR (tail
)))
1916 if (! NILP (Fequal (prop
, XCAR (tail
))))
1917 return XCAR (XCDR (tail
));
1922 CHECK_LIST_END (tail
, prop
);
1927 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1928 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1929 PLIST is a property list, which is a list of the form
1930 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1931 If PROP is already a property on the list, its value is set to VAL,
1932 otherwise the new PROP VAL pair is added. The new plist is returned;
1933 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1934 The PLIST is modified by side effects. */)
1935 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1937 register Lisp_Object tail
, prev
;
1938 Lisp_Object newcell
;
1940 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1941 tail
= XCDR (XCDR (tail
)))
1943 if (! NILP (Fequal (prop
, XCAR (tail
))))
1945 Fsetcar (XCDR (tail
), val
);
1952 newcell
= list2 (prop
, val
);
1956 Fsetcdr (XCDR (prev
), newcell
);
1960 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1961 doc
: /* Return t if the two args are the same Lisp object.
1962 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1963 (Lisp_Object obj1
, Lisp_Object obj2
)
1966 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
1968 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1971 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1972 doc
: /* Return t if two Lisp objects have similar structure and contents.
1973 They must have the same data type.
1974 Conses are compared by comparing the cars and the cdrs.
1975 Vectors and strings are compared element by element.
1976 Numbers are compared by value, but integers cannot equal floats.
1977 (Use `=' if you want integers and floats to be able to be equal.)
1978 Symbols must match exactly. */)
1979 (register Lisp_Object o1
, Lisp_Object o2
)
1981 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
1984 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1985 doc
: /* Return t if two Lisp objects have similar structure and contents.
1986 This is like `equal' except that it compares the text properties
1987 of strings. (`equal' ignores text properties.) */)
1988 (register Lisp_Object o1
, Lisp_Object o2
)
1990 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
1993 /* DEPTH is current depth of recursion. Signal an error if it
1995 PROPS means compare string text properties too. */
1998 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2004 error ("Stack overflow in equal");
2007 Lisp_Object args
[2];
2010 ht
= Fmake_hash_table (2, args
);
2014 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2016 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2018 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2020 { /* `o1' was seen already. */
2021 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2022 if (!NILP (Fmemq (o2
, o2s
)))
2025 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2028 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2038 if (XTYPE (o1
) != XTYPE (o2
))
2047 d1
= extract_float (o1
);
2048 d2
= extract_float (o2
);
2049 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2050 though they are not =. */
2051 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2055 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2059 /* FIXME: This inf-loops in a circular list! */
2063 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2067 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2068 depth
+ 1, props
, ht
)
2069 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2070 depth
+ 1, props
, ht
))
2072 o1
= XOVERLAY (o1
)->plist
;
2073 o2
= XOVERLAY (o2
)->plist
;
2078 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2079 && (XMARKER (o1
)->buffer
== 0
2080 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2084 case Lisp_Vectorlike
:
2087 ptrdiff_t size
= ASIZE (o1
);
2088 /* Pseudovectors have the type encoded in the size field, so this test
2089 actually checks that the objects have the same type as well as the
2091 if (ASIZE (o2
) != size
)
2093 /* Boolvectors are compared much like strings. */
2094 if (BOOL_VECTOR_P (o1
))
2096 EMACS_INT size
= bool_vector_size (o1
);
2097 if (size
!= bool_vector_size (o2
))
2099 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2100 bool_vector_bytes (size
)))
2104 if (WINDOW_CONFIGURATIONP (o1
))
2105 return compare_window_configurations (o1
, o2
, 0);
2107 /* Aside from them, only true vectors, char-tables, compiled
2108 functions, and fonts (font-spec, font-entity, font-object)
2109 are sensible to compare, so eliminate the others now. */
2110 if (size
& PSEUDOVECTOR_FLAG
)
2112 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2115 size
&= PSEUDOVECTOR_SIZE_MASK
;
2117 for (i
= 0; i
< size
; i
++)
2122 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2130 if (SCHARS (o1
) != SCHARS (o2
))
2132 if (SBYTES (o1
) != SBYTES (o2
))
2134 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2136 if (props
&& !compare_string_intervals (o1
, o2
))
2148 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2149 doc
: /* Store each element of ARRAY with ITEM.
2150 ARRAY is a vector, string, char-table, or bool-vector. */)
2151 (Lisp_Object array
, Lisp_Object item
)
2153 register ptrdiff_t size
, idx
;
2155 if (VECTORP (array
))
2156 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2157 ASET (array
, idx
, item
);
2158 else if (CHAR_TABLE_P (array
))
2162 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2163 set_char_table_contents (array
, i
, item
);
2164 set_char_table_defalt (array
, item
);
2166 else if (STRINGP (array
))
2168 register unsigned char *p
= SDATA (array
);
2170 CHECK_CHARACTER (item
);
2171 charval
= XFASTINT (item
);
2172 size
= SCHARS (array
);
2173 if (STRING_MULTIBYTE (array
))
2175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2176 int len
= CHAR_STRING (charval
, str
);
2177 ptrdiff_t size_byte
= SBYTES (array
);
2179 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2180 || SCHARS (array
) * len
!= size_byte
)
2181 error ("Attempt to change byte length of a string");
2182 for (idx
= 0; idx
< size_byte
; idx
++)
2183 *p
++ = str
[idx
% len
];
2186 for (idx
= 0; idx
< size
; idx
++)
2189 else if (BOOL_VECTOR_P (array
))
2190 return bool_vector_fill (array
, item
);
2192 wrong_type_argument (Qarrayp
, array
);
2196 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2198 doc
: /* Clear the contents of STRING.
2199 This makes STRING unibyte and may change its length. */)
2200 (Lisp_Object string
)
2203 CHECK_STRING (string
);
2204 len
= SBYTES (string
);
2205 memset (SDATA (string
), 0, len
);
2206 STRING_SET_CHARS (string
, len
);
2207 STRING_SET_UNIBYTE (string
);
2213 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2215 Lisp_Object args
[2];
2218 return Fnconc (2, args
);
2221 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2222 doc
: /* Concatenate any number of lists by altering them.
2223 Only the last argument is not altered, and need not be a list.
2224 usage: (nconc &rest LISTS) */)
2225 (ptrdiff_t nargs
, Lisp_Object
*args
)
2228 register Lisp_Object tail
, tem
, val
;
2232 for (argnum
= 0; argnum
< nargs
; argnum
++)
2235 if (NILP (tem
)) continue;
2240 if (argnum
+ 1 == nargs
) break;
2242 CHECK_LIST_CONS (tem
, tem
);
2251 tem
= args
[argnum
+ 1];
2252 Fsetcdr (tail
, tem
);
2254 args
[argnum
+ 1] = tail
;
2260 /* This is the guts of all mapping functions.
2261 Apply FN to each element of SEQ, one by one,
2262 storing the results into elements of VALS, a C vector of Lisp_Objects.
2263 LENI is the length of VALS, which should also be the length of SEQ. */
2266 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2268 register Lisp_Object tail
;
2270 register EMACS_INT i
;
2271 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2275 /* Don't let vals contain any garbage when GC happens. */
2276 for (i
= 0; i
< leni
; i
++)
2279 GCPRO3 (dummy
, fn
, seq
);
2281 gcpro1
.nvars
= leni
;
2285 /* We need not explicitly protect `tail' because it is used only on lists, and
2286 1) lists are not relocated and 2) the list is marked via `seq' so will not
2289 if (VECTORP (seq
) || COMPILEDP (seq
))
2291 for (i
= 0; i
< leni
; i
++)
2293 dummy
= call1 (fn
, AREF (seq
, i
));
2298 else if (BOOL_VECTOR_P (seq
))
2300 for (i
= 0; i
< leni
; i
++)
2302 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2307 else if (STRINGP (seq
))
2311 for (i
= 0, i_byte
= 0; i
< leni
;)
2314 ptrdiff_t i_before
= i
;
2316 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2317 XSETFASTINT (dummy
, c
);
2318 dummy
= call1 (fn
, dummy
);
2320 vals
[i_before
] = dummy
;
2323 else /* Must be a list, since Flength did not get an error */
2326 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2328 dummy
= call1 (fn
, XCAR (tail
));
2338 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2339 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2340 In between each pair of results, stick in SEPARATOR. Thus, " " as
2341 SEPARATOR results in spaces between the values returned by FUNCTION.
2342 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2343 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2346 register EMACS_INT leni
;
2349 register Lisp_Object
*args
;
2350 struct gcpro gcpro1
;
2354 len
= Flength (sequence
);
2355 if (CHAR_TABLE_P (sequence
))
2356 wrong_type_argument (Qlistp
, sequence
);
2358 nargs
= leni
+ leni
- 1;
2359 if (nargs
< 0) return empty_unibyte_string
;
2361 SAFE_ALLOCA_LISP (args
, nargs
);
2364 mapcar1 (leni
, args
, function
, sequence
);
2367 for (i
= leni
- 1; i
> 0; i
--)
2368 args
[i
+ i
] = args
[i
];
2370 for (i
= 1; i
< nargs
; i
+= 2)
2371 args
[i
] = separator
;
2373 ret
= Fconcat (nargs
, args
);
2379 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2380 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2381 The result is a list just as long as SEQUENCE.
2382 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2383 (Lisp_Object function
, Lisp_Object sequence
)
2385 register Lisp_Object len
;
2386 register EMACS_INT leni
;
2387 register Lisp_Object
*args
;
2391 len
= Flength (sequence
);
2392 if (CHAR_TABLE_P (sequence
))
2393 wrong_type_argument (Qlistp
, sequence
);
2394 leni
= XFASTINT (len
);
2396 SAFE_ALLOCA_LISP (args
, leni
);
2398 mapcar1 (leni
, args
, function
, sequence
);
2400 ret
= Flist (leni
, args
);
2406 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2407 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2408 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2409 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2410 (Lisp_Object function
, Lisp_Object sequence
)
2412 register EMACS_INT leni
;
2414 leni
= XFASTINT (Flength (sequence
));
2415 if (CHAR_TABLE_P (sequence
))
2416 wrong_type_argument (Qlistp
, sequence
);
2417 mapcar1 (leni
, 0, function
, sequence
);
2422 /* This is how C code calls `yes-or-no-p' and allows the user
2425 Anything that calls this function must protect from GC! */
2428 do_yes_or_no_p (Lisp_Object prompt
)
2430 return call1 (intern ("yes-or-no-p"), prompt
);
2433 /* Anything that calls this function must protect from GC! */
2435 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2436 doc
: /* Ask user a yes-or-no question.
2437 Return t if answer is yes, and nil if the answer is no.
2438 PROMPT is the string to display to ask the question. It should end in
2439 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2441 The user must confirm the answer with RET, and can edit it until it
2444 If dialog boxes are supported, a dialog box will be used
2445 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2446 (Lisp_Object prompt
)
2448 register Lisp_Object ans
;
2449 Lisp_Object args
[2];
2450 struct gcpro gcpro1
;
2452 CHECK_STRING (prompt
);
2454 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2457 Lisp_Object pane
, menu
, obj
;
2458 redisplay_preserve_echo_area (4);
2459 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2460 Fcons (build_string ("No"), Qnil
));
2462 menu
= Fcons (prompt
, pane
);
2463 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
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 return hashfn_eq (ht
, hash
);
3582 /* An upper bound on the size of a hash table index. It must fit in
3583 ptrdiff_t and be a valid Emacs fixnum. */
3584 #define INDEX_SIZE_BOUND \
3585 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3587 /* Create and initialize a new hash table.
3589 TEST specifies the test the hash table will use to compare keys.
3590 It must be either one of the predefined tests `eq', `eql' or
3591 `equal' or a symbol denoting a user-defined test named TEST with
3592 test and hash functions USER_TEST and USER_HASH.
3594 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3596 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3597 new size when it becomes full is computed by adding REHASH_SIZE to
3598 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3599 table's new size is computed by multiplying its old size with
3602 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3603 be resized when the ratio of (number of entries in the table) /
3604 (table size) is >= REHASH_THRESHOLD.
3606 WEAK specifies the weakness of the table. If non-nil, it must be
3607 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3610 make_hash_table (struct hash_table_test test
,
3611 Lisp_Object size
, Lisp_Object rehash_size
,
3612 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3614 struct Lisp_Hash_Table
*h
;
3616 EMACS_INT index_size
, sz
;
3620 /* Preconditions. */
3621 eassert (SYMBOLP (test
.name
));
3622 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3623 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3624 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3625 eassert (FLOATP (rehash_threshold
)
3626 && 0 < XFLOAT_DATA (rehash_threshold
)
3627 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3629 if (XFASTINT (size
) == 0)
3630 size
= make_number (1);
3632 sz
= XFASTINT (size
);
3633 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3634 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3635 ? next_almost_prime (index_float
)
3636 : INDEX_SIZE_BOUND
+ 1);
3637 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3638 error ("Hash table too large");
3640 /* Allocate a table and initialize it. */
3641 h
= allocate_hash_table ();
3643 /* Initialize hash table slots. */
3646 h
->rehash_threshold
= rehash_threshold
;
3647 h
->rehash_size
= rehash_size
;
3649 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3650 h
->hash
= Fmake_vector (size
, Qnil
);
3651 h
->next
= Fmake_vector (size
, Qnil
);
3652 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3654 /* Set up the free list. */
3655 for (i
= 0; i
< sz
- 1; ++i
)
3656 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3657 h
->next_free
= make_number (0);
3659 XSET_HASH_TABLE (table
, h
);
3660 eassert (HASH_TABLE_P (table
));
3661 eassert (XHASH_TABLE (table
) == h
);
3663 /* Maybe add this hash table to the list of all weak hash tables. */
3665 h
->next_weak
= NULL
;
3668 h
->next_weak
= weak_hash_tables
;
3669 weak_hash_tables
= h
;
3676 /* Return a copy of hash table H1. Keys and values are not copied,
3677 only the table itself is. */
3680 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3683 struct Lisp_Hash_Table
*h2
;
3685 h2
= allocate_hash_table ();
3687 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3688 h2
->hash
= Fcopy_sequence (h1
->hash
);
3689 h2
->next
= Fcopy_sequence (h1
->next
);
3690 h2
->index
= Fcopy_sequence (h1
->index
);
3691 XSET_HASH_TABLE (table
, h2
);
3693 /* Maybe add this hash table to the list of all weak hash tables. */
3694 if (!NILP (h2
->weak
))
3696 h2
->next_weak
= weak_hash_tables
;
3697 weak_hash_tables
= h2
;
3704 /* Resize hash table H if it's too full. If H cannot be resized
3705 because it's already too large, throw an error. */
3708 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3710 if (NILP (h
->next_free
))
3712 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3713 EMACS_INT new_size
, index_size
, nsize
;
3717 if (INTEGERP (h
->rehash_size
))
3718 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3721 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3722 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3724 new_size
= float_new_size
;
3725 if (new_size
<= old_size
)
3726 new_size
= old_size
+ 1;
3729 new_size
= INDEX_SIZE_BOUND
+ 1;
3731 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3732 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3733 ? next_almost_prime (index_float
)
3734 : INDEX_SIZE_BOUND
+ 1);
3735 nsize
= max (index_size
, 2 * new_size
);
3736 if (INDEX_SIZE_BOUND
< nsize
)
3737 error ("Hash table too large to resize");
3739 #ifdef ENABLE_CHECKING
3740 if (HASH_TABLE_P (Vpurify_flag
)
3741 && XHASH_TABLE (Vpurify_flag
) == h
)
3743 Lisp_Object args
[2];
3744 args
[0] = build_string ("Growing hash table to: %d");
3745 args
[1] = make_number (new_size
);
3750 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3751 2 * (new_size
- old_size
), -1));
3752 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3753 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3754 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3756 /* Update the free list. Do it so that new entries are added at
3757 the end of the free list. This makes some operations like
3759 for (i
= old_size
; i
< new_size
- 1; ++i
)
3760 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3762 if (!NILP (h
->next_free
))
3764 Lisp_Object last
, next
;
3766 last
= h
->next_free
;
3767 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3771 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3774 XSETFASTINT (h
->next_free
, old_size
);
3777 for (i
= 0; i
< old_size
; ++i
)
3778 if (!NILP (HASH_HASH (h
, i
)))
3780 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3781 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3782 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3783 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3789 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3790 the hash code of KEY. Value is the index of the entry in H
3791 matching KEY, or -1 if not found. */
3794 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3796 EMACS_UINT hash_code
;
3797 ptrdiff_t start_of_bucket
;
3800 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3801 eassert ((hash_code
& ~INTMASK
) == 0);
3805 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3806 idx
= HASH_INDEX (h
, start_of_bucket
);
3808 /* We need not gcpro idx since it's either an integer or nil. */
3811 ptrdiff_t i
= XFASTINT (idx
);
3812 if (EQ (key
, HASH_KEY (h
, i
))
3814 && hash_code
== XUINT (HASH_HASH (h
, i
))
3815 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3817 idx
= HASH_NEXT (h
, i
);
3820 return NILP (idx
) ? -1 : XFASTINT (idx
);
3824 /* Put an entry into hash table H that associates KEY with VALUE.
3825 HASH is a previously computed hash code of KEY.
3826 Value is the index of the entry in H matching KEY. */
3829 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3832 ptrdiff_t start_of_bucket
, i
;
3834 eassert ((hash
& ~INTMASK
) == 0);
3836 /* Increment count after resizing because resizing may fail. */
3837 maybe_resize_hash_table (h
);
3840 /* Store key/value in the key_and_value vector. */
3841 i
= XFASTINT (h
->next_free
);
3842 h
->next_free
= HASH_NEXT (h
, i
);
3843 set_hash_key_slot (h
, i
, key
);
3844 set_hash_value_slot (h
, i
, value
);
3846 /* Remember its hash code. */
3847 set_hash_hash_slot (h
, i
, make_number (hash
));
3849 /* Add new entry to its collision chain. */
3850 start_of_bucket
= hash
% ASIZE (h
->index
);
3851 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3852 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3857 /* Remove the entry matching KEY from hash table H, if there is one. */
3860 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3862 EMACS_UINT hash_code
;
3863 ptrdiff_t start_of_bucket
;
3864 Lisp_Object idx
, prev
;
3866 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3867 eassert ((hash_code
& ~INTMASK
) == 0);
3868 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3869 idx
= HASH_INDEX (h
, start_of_bucket
);
3872 /* We need not gcpro idx, prev since they're either integers or nil. */
3875 ptrdiff_t i
= XFASTINT (idx
);
3877 if (EQ (key
, HASH_KEY (h
, i
))
3879 && hash_code
== XUINT (HASH_HASH (h
, i
))
3880 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3882 /* Take entry out of collision chain. */
3884 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3886 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3888 /* Clear slots in key_and_value and add the slots to
3890 set_hash_key_slot (h
, i
, Qnil
);
3891 set_hash_value_slot (h
, i
, Qnil
);
3892 set_hash_hash_slot (h
, i
, Qnil
);
3893 set_hash_next_slot (h
, i
, h
->next_free
);
3894 h
->next_free
= make_number (i
);
3896 eassert (h
->count
>= 0);
3902 idx
= HASH_NEXT (h
, i
);
3908 /* Clear hash table H. */
3911 hash_clear (struct Lisp_Hash_Table
*h
)
3915 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3917 for (i
= 0; i
< size
; ++i
)
3919 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3920 set_hash_key_slot (h
, i
, Qnil
);
3921 set_hash_value_slot (h
, i
, Qnil
);
3922 set_hash_hash_slot (h
, i
, Qnil
);
3925 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3926 ASET (h
->index
, i
, Qnil
);
3928 h
->next_free
= make_number (0);
3935 /************************************************************************
3937 ************************************************************************/
3939 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3940 entries from the table that don't survive the current GC.
3941 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3942 true if anything was marked. */
3945 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3947 ptrdiff_t bucket
, n
;
3950 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3953 for (bucket
= 0; bucket
< n
; ++bucket
)
3955 Lisp_Object idx
, next
, prev
;
3957 /* Follow collision chain, removing entries that
3958 don't survive this garbage collection. */
3960 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3962 ptrdiff_t i
= XFASTINT (idx
);
3963 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3964 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3967 if (EQ (h
->weak
, Qkey
))
3968 remove_p
= !key_known_to_survive_p
;
3969 else if (EQ (h
->weak
, Qvalue
))
3970 remove_p
= !value_known_to_survive_p
;
3971 else if (EQ (h
->weak
, Qkey_or_value
))
3972 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3973 else if (EQ (h
->weak
, Qkey_and_value
))
3974 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3978 next
= HASH_NEXT (h
, i
);
3980 if (remove_entries_p
)
3984 /* Take out of collision chain. */
3986 set_hash_index_slot (h
, bucket
, next
);
3988 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3990 /* Add to free list. */
3991 set_hash_next_slot (h
, i
, h
->next_free
);
3994 /* Clear key, value, and hash. */
3995 set_hash_key_slot (h
, i
, Qnil
);
3996 set_hash_value_slot (h
, i
, Qnil
);
3997 set_hash_hash_slot (h
, i
, Qnil
);
4010 /* Make sure key and value survive. */
4011 if (!key_known_to_survive_p
)
4013 mark_object (HASH_KEY (h
, i
));
4017 if (!value_known_to_survive_p
)
4019 mark_object (HASH_VALUE (h
, i
));
4030 /* Remove elements from weak hash tables that don't survive the
4031 current garbage collection. Remove weak tables that don't survive
4032 from Vweak_hash_tables. Called from gc_sweep. */
4034 NO_INLINE
/* For better stack traces */
4036 sweep_weak_hash_tables (void)
4038 struct Lisp_Hash_Table
*h
, *used
, *next
;
4041 /* Mark all keys and values that are in use. Keep on marking until
4042 there is no more change. This is necessary for cases like
4043 value-weak table A containing an entry X -> Y, where Y is used in a
4044 key-weak table B, Z -> Y. If B comes after A in the list of weak
4045 tables, X -> Y might be removed from A, although when looking at B
4046 one finds that it shouldn't. */
4050 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4052 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4053 marked
|= sweep_weak_table (h
, 0);
4058 /* Remove tables and entries that aren't used. */
4059 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4061 next
= h
->next_weak
;
4063 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4065 /* TABLE is marked as used. Sweep its contents. */
4067 sweep_weak_table (h
, 1);
4069 /* Add table to the list of used weak hash tables. */
4070 h
->next_weak
= used
;
4075 weak_hash_tables
= used
;
4080 /***********************************************************************
4081 Hash Code Computation
4082 ***********************************************************************/
4084 /* Maximum depth up to which to dive into Lisp structures. */
4086 #define SXHASH_MAX_DEPTH 3
4088 /* Maximum length up to which to take list and vector elements into
4091 #define SXHASH_MAX_LEN 7
4093 /* Return a hash for string PTR which has length LEN. The hash value
4094 can be any EMACS_UINT value. */
4097 hash_string (char const *ptr
, ptrdiff_t len
)
4099 char const *p
= ptr
;
4100 char const *end
= p
+ len
;
4102 EMACS_UINT hash
= 0;
4107 hash
= sxhash_combine (hash
, c
);
4113 /* Return a hash for string PTR which has length LEN. The hash
4114 code returned is guaranteed to fit in a Lisp integer. */
4117 sxhash_string (char const *ptr
, ptrdiff_t len
)
4119 EMACS_UINT hash
= hash_string (ptr
, len
);
4120 return SXHASH_REDUCE (hash
);
4123 /* Return a hash for the floating point value VAL. */
4126 sxhash_float (double val
)
4128 EMACS_UINT hash
= 0;
4130 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4131 + (sizeof val
% sizeof hash
!= 0))
4135 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4139 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4140 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4141 hash
= sxhash_combine (hash
, u
.word
[i
]);
4142 return SXHASH_REDUCE (hash
);
4145 /* Return a hash for list LIST. DEPTH is the current depth in the
4146 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4149 sxhash_list (Lisp_Object list
, int depth
)
4151 EMACS_UINT hash
= 0;
4154 if (depth
< SXHASH_MAX_DEPTH
)
4156 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4157 list
= XCDR (list
), ++i
)
4159 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4160 hash
= sxhash_combine (hash
, hash2
);
4165 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4166 hash
= sxhash_combine (hash
, hash2
);
4169 return SXHASH_REDUCE (hash
);
4173 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4174 the Lisp structure. */
4177 sxhash_vector (Lisp_Object vec
, int depth
)
4179 EMACS_UINT hash
= ASIZE (vec
);
4182 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4183 for (i
= 0; i
< n
; ++i
)
4185 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4186 hash
= sxhash_combine (hash
, hash2
);
4189 return SXHASH_REDUCE (hash
);
4192 /* Return a hash for bool-vector VECTOR. */
4195 sxhash_bool_vector (Lisp_Object vec
)
4197 EMACS_INT size
= bool_vector_size (vec
);
4198 EMACS_UINT hash
= size
;
4201 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4202 for (i
= 0; i
< n
; ++i
)
4203 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[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 `maphash' always returns nil. */)
4523 (Lisp_Object function
, Lisp_Object table
)
4525 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4526 Lisp_Object args
[3];
4529 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4530 if (!NILP (HASH_HASH (h
, i
)))
4533 args
[1] = HASH_KEY (h
, i
);
4534 args
[2] = HASH_VALUE (h
, i
);
4542 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4543 Sdefine_hash_table_test
, 3, 3, 0,
4544 doc
: /* Define a new hash table test with name NAME, a symbol.
4546 In hash tables created with NAME specified as test, use TEST to
4547 compare keys, and HASH for computing hash codes of keys.
4549 TEST must be a function taking two arguments and returning non-nil if
4550 both arguments are the same. HASH must be a function taking one
4551 argument and returning an object that is the hash code of the argument.
4552 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4553 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4554 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4556 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4561 /************************************************************************
4562 MD5, SHA-1, and SHA-2
4563 ************************************************************************/
4570 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4573 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4577 EMACS_INT start_char
= 0, end_char
= 0;
4578 ptrdiff_t start_byte
, end_byte
;
4579 register EMACS_INT b
, e
;
4580 register struct buffer
*bp
;
4583 void *(*hash_func
) (const char *, size_t, void *);
4586 CHECK_SYMBOL (algorithm
);
4588 if (STRINGP (object
))
4590 if (NILP (coding_system
))
4592 /* Decide the coding-system to encode the data with. */
4594 if (STRING_MULTIBYTE (object
))
4595 /* use default, we can't guess correct value */
4596 coding_system
= preferred_coding_system ();
4598 coding_system
= Qraw_text
;
4601 if (NILP (Fcoding_system_p (coding_system
)))
4603 /* Invalid coding system. */
4605 if (!NILP (noerror
))
4606 coding_system
= Qraw_text
;
4608 xsignal1 (Qcoding_system_error
, coding_system
);
4611 if (STRING_MULTIBYTE (object
))
4612 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4614 size
= SCHARS (object
);
4616 if (!validate_substring (start
, end
, size
, &start_char
, &end_char
))
4617 args_out_of_range_3 (object
, make_number (start_char
),
4618 make_number (end_char
));
4620 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4622 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4626 struct buffer
*prev
= current_buffer
;
4628 record_unwind_current_buffer ();
4630 CHECK_BUFFER (object
);
4632 bp
= XBUFFER (object
);
4633 set_buffer_internal (bp
);
4639 CHECK_NUMBER_COERCE_MARKER (start
);
4647 CHECK_NUMBER_COERCE_MARKER (end
);
4652 temp
= b
, b
= e
, e
= temp
;
4654 if (!(BEGV
<= b
&& e
<= ZV
))
4655 args_out_of_range (start
, end
);
4657 if (NILP (coding_system
))
4659 /* Decide the coding-system to encode the data with.
4660 See fileio.c:Fwrite-region */
4662 if (!NILP (Vcoding_system_for_write
))
4663 coding_system
= Vcoding_system_for_write
;
4666 bool force_raw_text
= 0;
4668 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4669 if (NILP (coding_system
)
4670 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4672 coding_system
= Qnil
;
4673 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4677 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4679 /* Check file-coding-system-alist. */
4680 Lisp_Object args
[4], val
;
4682 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4683 args
[3] = Fbuffer_file_name (object
);
4684 val
= Ffind_operation_coding_system (4, args
);
4685 if (CONSP (val
) && !NILP (XCDR (val
)))
4686 coding_system
= XCDR (val
);
4689 if (NILP (coding_system
)
4690 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4692 /* If we still have not decided a coding system, use the
4693 default value of buffer-file-coding-system. */
4694 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4698 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4699 /* Confirm that VAL can surely encode the current region. */
4700 coding_system
= call4 (Vselect_safe_coding_system_function
,
4701 make_number (b
), make_number (e
),
4702 coding_system
, Qnil
);
4705 coding_system
= Qraw_text
;
4708 if (NILP (Fcoding_system_p (coding_system
)))
4710 /* Invalid coding system. */
4712 if (!NILP (noerror
))
4713 coding_system
= Qraw_text
;
4715 xsignal1 (Qcoding_system_error
, coding_system
);
4719 object
= make_buffer_string (b
, e
, 0);
4720 set_buffer_internal (prev
);
4721 /* Discard the unwind protect for recovering the current
4725 if (STRING_MULTIBYTE (object
))
4726 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4728 end_byte
= SBYTES (object
);
4731 if (EQ (algorithm
, Qmd5
))
4733 digest_size
= MD5_DIGEST_SIZE
;
4734 hash_func
= md5_buffer
;
4736 else if (EQ (algorithm
, Qsha1
))
4738 digest_size
= SHA1_DIGEST_SIZE
;
4739 hash_func
= sha1_buffer
;
4741 else if (EQ (algorithm
, Qsha224
))
4743 digest_size
= SHA224_DIGEST_SIZE
;
4744 hash_func
= sha224_buffer
;
4746 else if (EQ (algorithm
, Qsha256
))
4748 digest_size
= SHA256_DIGEST_SIZE
;
4749 hash_func
= sha256_buffer
;
4751 else if (EQ (algorithm
, Qsha384
))
4753 digest_size
= SHA384_DIGEST_SIZE
;
4754 hash_func
= sha384_buffer
;
4756 else if (EQ (algorithm
, Qsha512
))
4758 digest_size
= SHA512_DIGEST_SIZE
;
4759 hash_func
= sha512_buffer
;
4762 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4764 /* allocate 2 x digest_size so that it can be re-used to hold the
4766 digest
= make_uninit_string (digest_size
* 2);
4768 hash_func (SSDATA (object
) + start_byte
,
4769 end_byte
- start_byte
,
4774 unsigned char *p
= SDATA (digest
);
4775 for (i
= digest_size
- 1; i
>= 0; i
--)
4777 static char const hexdigit
[16] = "0123456789abcdef";
4779 p
[2 * i
] = hexdigit
[p_i
>> 4];
4780 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4785 return make_unibyte_string (SSDATA (digest
), digest_size
);
4788 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4789 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4791 A message digest is a cryptographic checksum of a document, and the
4792 algorithm to calculate it is defined in RFC 1321.
4794 The two optional arguments START and END are character positions
4795 specifying for which part of OBJECT the message digest should be
4796 computed. If nil or omitted, the digest is computed for the whole
4799 The MD5 message digest is computed from the result of encoding the
4800 text in a coding system, not directly from the internal Emacs form of
4801 the text. The optional fourth argument CODING-SYSTEM specifies which
4802 coding system to encode the text with. It should be the same coding
4803 system that you used or will use when actually writing the text into a
4806 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4807 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4808 system would be chosen by default for writing this text into a file.
4810 If OBJECT is a string, the most preferred coding system (see the
4811 command `prefer-coding-system') is used.
4813 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4814 guesswork fails. Normally, an error is signaled in such case. */)
4815 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4817 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4820 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4821 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4822 ALGORITHM is a symbol specifying the hash to use:
4823 md5, sha1, sha224, sha256, sha384 or sha512.
4825 The two optional arguments START and END are positions specifying for
4826 which part of OBJECT to compute the hash. If nil or omitted, uses the
4829 If BINARY is non-nil, returns a string in binary form. */)
4830 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4832 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4838 DEFSYM (Qmd5
, "md5");
4839 DEFSYM (Qsha1
, "sha1");
4840 DEFSYM (Qsha224
, "sha224");
4841 DEFSYM (Qsha256
, "sha256");
4842 DEFSYM (Qsha384
, "sha384");
4843 DEFSYM (Qsha512
, "sha512");
4845 /* Hash table stuff. */
4846 DEFSYM (Qhash_table_p
, "hash-table-p");
4848 DEFSYM (Qeql
, "eql");
4849 DEFSYM (Qequal
, "equal");
4850 DEFSYM (QCtest
, ":test");
4851 DEFSYM (QCsize
, ":size");
4852 DEFSYM (QCrehash_size
, ":rehash-size");
4853 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4854 DEFSYM (QCweakness
, ":weakness");
4855 DEFSYM (Qkey
, "key");
4856 DEFSYM (Qvalue
, "value");
4857 DEFSYM (Qhash_table_test
, "hash-table-test");
4858 DEFSYM (Qkey_or_value
, "key-or-value");
4859 DEFSYM (Qkey_and_value
, "key-and-value");
4862 defsubr (&Smake_hash_table
);
4863 defsubr (&Scopy_hash_table
);
4864 defsubr (&Shash_table_count
);
4865 defsubr (&Shash_table_rehash_size
);
4866 defsubr (&Shash_table_rehash_threshold
);
4867 defsubr (&Shash_table_size
);
4868 defsubr (&Shash_table_test
);
4869 defsubr (&Shash_table_weakness
);
4870 defsubr (&Shash_table_p
);
4871 defsubr (&Sclrhash
);
4872 defsubr (&Sgethash
);
4873 defsubr (&Sputhash
);
4874 defsubr (&Sremhash
);
4875 defsubr (&Smaphash
);
4876 defsubr (&Sdefine_hash_table_test
);
4878 DEFSYM (Qstring_lessp
, "string-lessp");
4879 DEFSYM (Qprovide
, "provide");
4880 DEFSYM (Qrequire
, "require");
4881 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4882 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4883 DEFSYM (Qwidget_type
, "widget-type");
4885 staticpro (&string_char_byte_cache_string
);
4886 string_char_byte_cache_string
= Qnil
;
4888 require_nesting_list
= Qnil
;
4889 staticpro (&require_nesting_list
);
4891 Fset (Qyes_or_no_p_history
, Qnil
);
4893 DEFVAR_LISP ("features", Vfeatures
,
4894 doc
: /* A list of symbols which are the features of the executing Emacs.
4895 Used by `featurep' and `require', and altered by `provide'. */);
4896 Vfeatures
= list1 (intern_c_string ("emacs"));
4897 DEFSYM (Qsubfeatures
, "subfeatures");
4898 DEFSYM (Qfuncall
, "funcall");
4900 #ifdef HAVE_LANGINFO_CODESET
4901 DEFSYM (Qcodeset
, "codeset");
4902 DEFSYM (Qdays
, "days");
4903 DEFSYM (Qmonths
, "months");
4904 DEFSYM (Qpaper
, "paper");
4905 #endif /* HAVE_LANGINFO_CODESET */
4907 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4908 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4909 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4910 invoked by mouse clicks and mouse menu items.
4912 On some platforms, file selection dialogs are also enabled if this is
4916 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4917 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4918 This applies to commands from menus and tool bar buttons even when
4919 they are initiated from the keyboard. If `use-dialog-box' is nil,
4920 that disables the use of a file dialog, regardless of the value of
4922 use_file_dialog
= 1;
4924 defsubr (&Sidentity
);
4927 defsubr (&Ssafe_length
);
4928 defsubr (&Sstring_bytes
);
4929 defsubr (&Sstring_equal
);
4930 defsubr (&Scompare_strings
);
4931 defsubr (&Sstring_lessp
);
4934 defsubr (&Svconcat
);
4935 defsubr (&Scopy_sequence
);
4936 defsubr (&Sstring_make_multibyte
);
4937 defsubr (&Sstring_make_unibyte
);
4938 defsubr (&Sstring_as_multibyte
);
4939 defsubr (&Sstring_as_unibyte
);
4940 defsubr (&Sstring_to_multibyte
);
4941 defsubr (&Sstring_to_unibyte
);
4942 defsubr (&Scopy_alist
);
4943 defsubr (&Ssubstring
);
4944 defsubr (&Ssubstring_no_properties
);
4957 defsubr (&Snreverse
);
4958 defsubr (&Sreverse
);
4960 defsubr (&Splist_get
);
4962 defsubr (&Splist_put
);
4964 defsubr (&Slax_plist_get
);
4965 defsubr (&Slax_plist_put
);
4968 defsubr (&Sequal_including_properties
);
4969 defsubr (&Sfillarray
);
4970 defsubr (&Sclear_string
);
4974 defsubr (&Smapconcat
);
4975 defsubr (&Syes_or_no_p
);
4976 defsubr (&Sload_average
);
4977 defsubr (&Sfeaturep
);
4978 defsubr (&Srequire
);
4979 defsubr (&Sprovide
);
4980 defsubr (&Splist_member
);
4981 defsubr (&Swidget_put
);
4982 defsubr (&Swidget_get
);
4983 defsubr (&Swidget_apply
);
4984 defsubr (&Sbase64_encode_region
);
4985 defsubr (&Sbase64_decode_region
);
4986 defsubr (&Sbase64_encode_string
);
4987 defsubr (&Sbase64_decode_string
);
4989 defsubr (&Ssecure_hash
);
4990 defsubr (&Slocale_info
);
4992 hashtest_eq
.name
= Qeq
;
4993 hashtest_eq
.user_hash_function
= Qnil
;
4994 hashtest_eq
.user_cmp_function
= Qnil
;
4995 hashtest_eq
.cmpfn
= 0;
4996 hashtest_eq
.hashfn
= hashfn_eq
;
4998 hashtest_eql
.name
= Qeql
;
4999 hashtest_eql
.user_hash_function
= Qnil
;
5000 hashtest_eql
.user_cmp_function
= Qnil
;
5001 hashtest_eql
.cmpfn
= cmpfn_eql
;
5002 hashtest_eql
.hashfn
= hashfn_eql
;
5004 hashtest_equal
.name
= Qequal
;
5005 hashtest_equal
.user_hash_function
= Qnil
;
5006 hashtest_equal
.user_cmp_function
= Qnil
;
5007 hashtest_equal
.cmpfn
= cmpfn_equal
;
5008 hashtest_equal
.hashfn
= hashfn_equal
;