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 /* Check that ARRAY can have a valid subarray [FROM..TO),
1131 given that its size is SIZE.
1132 If FROM is nil, use 0; if TO is nil, use SIZE.
1133 Count negative values backwards from the end.
1134 Set *IFROM and *ITO to the two indexes used. */
1137 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1138 ptrdiff_t size
, EMACS_INT
*ifrom
, EMACS_INT
*ito
)
1142 if (INTEGERP (from
))
1148 else if (NILP (from
))
1151 wrong_type_argument (Qintegerp
, from
);
1162 wrong_type_argument (Qintegerp
, to
);
1164 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1165 args_out_of_range_3 (array
, from
, to
);
1171 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1172 doc
: /* Return a new string whose contents are a substring of STRING.
1173 The returned string consists of the characters between index FROM
1174 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1175 zero-indexed: 0 means the first character of STRING. Negative values
1176 are counted from the end of STRING. If TO is nil, the substring runs
1177 to the end of STRING.
1179 The STRING argument may also be a vector. In that case, the return
1180 value is a new vector that contains the elements between index FROM
1181 \(inclusive) and index TO (exclusive) of that vector argument.
1183 With one argument, just copy STRING (with properties, if any). */)
1184 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1188 EMACS_INT ifrom
, ito
;
1190 if (STRINGP (string
))
1191 size
= SCHARS (string
);
1192 else if (VECTORP (string
))
1193 size
= ASIZE (string
);
1195 wrong_type_argument (Qarrayp
, string
);
1197 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1199 if (STRINGP (string
))
1202 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1204 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1205 res
= make_specified_string (SSDATA (string
) + from_byte
,
1206 ito
- ifrom
, to_byte
- from_byte
,
1207 STRING_MULTIBYTE (string
));
1208 copy_text_properties (make_number (ifrom
), make_number (ito
),
1209 string
, make_number (0), res
, Qnil
);
1212 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1218 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1219 doc
: /* Return a substring of STRING, without text properties.
1220 It starts at index FROM and ends before TO.
1221 TO may be nil or omitted; then the substring runs to the end of STRING.
1222 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1223 If FROM or TO is negative, it counts from the end.
1225 With one argument, just copy STRING without its properties. */)
1226 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1229 EMACS_INT from_char
, to_char
;
1230 ptrdiff_t from_byte
, to_byte
;
1232 CHECK_STRING (string
);
1234 size
= SCHARS (string
);
1235 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1237 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1239 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1240 return make_specified_string (SSDATA (string
) + from_byte
,
1241 to_char
- from_char
, to_byte
- from_byte
,
1242 STRING_MULTIBYTE (string
));
1245 /* Extract a substring of STRING, giving start and end positions
1246 both in characters and in bytes. */
1249 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1250 ptrdiff_t to
, ptrdiff_t to_byte
)
1255 CHECK_VECTOR_OR_STRING (string
);
1257 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1259 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1260 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1262 if (STRINGP (string
))
1264 res
= make_specified_string (SSDATA (string
) + from_byte
,
1265 to
- from
, to_byte
- from_byte
,
1266 STRING_MULTIBYTE (string
));
1267 copy_text_properties (make_number (from
), make_number (to
),
1268 string
, make_number (0), res
, Qnil
);
1271 res
= Fvector (to
- from
, aref_addr (string
, from
));
1276 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1277 doc
: /* Take cdr N times on LIST, return the result. */)
1278 (Lisp_Object n
, Lisp_Object list
)
1283 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1286 CHECK_LIST_CONS (list
, list
);
1292 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1293 doc
: /* Return the Nth element of LIST.
1294 N counts from zero. If LIST is not that long, nil is returned. */)
1295 (Lisp_Object n
, Lisp_Object list
)
1297 return Fcar (Fnthcdr (n
, list
));
1300 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1301 doc
: /* Return element of SEQUENCE at index N. */)
1302 (register Lisp_Object sequence
, Lisp_Object n
)
1305 if (CONSP (sequence
) || NILP (sequence
))
1306 return Fcar (Fnthcdr (n
, sequence
));
1308 /* Faref signals a "not array" error, so check here. */
1309 CHECK_ARRAY (sequence
, Qsequencep
);
1310 return Faref (sequence
, n
);
1313 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1314 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1315 The value is actually the tail of LIST whose car is ELT. */)
1316 (register Lisp_Object elt
, Lisp_Object list
)
1318 register Lisp_Object tail
;
1319 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1321 register Lisp_Object tem
;
1322 CHECK_LIST_CONS (tail
, list
);
1324 if (! NILP (Fequal (elt
, tem
)))
1331 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1332 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1333 The value is actually the tail of LIST whose car is ELT. */)
1334 (register Lisp_Object elt
, Lisp_Object list
)
1338 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1342 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1346 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1358 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1359 The value is actually the tail of LIST whose car is ELT. */)
1360 (register Lisp_Object elt
, Lisp_Object list
)
1362 register Lisp_Object tail
;
1365 return Fmemq (elt
, list
);
1367 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1369 register Lisp_Object tem
;
1370 CHECK_LIST_CONS (tail
, list
);
1372 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1379 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1380 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1381 The value is actually the first element of LIST whose car is KEY.
1382 Elements of LIST that are not conses are ignored. */)
1383 (Lisp_Object key
, Lisp_Object list
)
1388 || (CONSP (XCAR (list
))
1389 && EQ (XCAR (XCAR (list
)), key
)))
1394 || (CONSP (XCAR (list
))
1395 && EQ (XCAR (XCAR (list
)), key
)))
1400 || (CONSP (XCAR (list
))
1401 && EQ (XCAR (XCAR (list
)), key
)))
1411 /* Like Fassq but never report an error and do not allow quits.
1412 Use only on lists known never to be circular. */
1415 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1418 && (!CONSP (XCAR (list
))
1419 || !EQ (XCAR (XCAR (list
)), key
)))
1422 return CAR_SAFE (list
);
1425 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1426 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1427 The value is actually the first element of LIST whose car equals KEY. */)
1428 (Lisp_Object key
, Lisp_Object list
)
1435 || (CONSP (XCAR (list
))
1436 && (car
= XCAR (XCAR (list
)),
1437 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1442 || (CONSP (XCAR (list
))
1443 && (car
= XCAR (XCAR (list
)),
1444 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1449 || (CONSP (XCAR (list
))
1450 && (car
= XCAR (XCAR (list
)),
1451 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1461 /* Like Fassoc but never report an error and do not allow quits.
1462 Use only on lists known never to be circular. */
1465 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1468 && (!CONSP (XCAR (list
))
1469 || (!EQ (XCAR (XCAR (list
)), key
)
1470 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1473 return CONSP (list
) ? XCAR (list
) : Qnil
;
1476 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1477 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1478 The value is actually the first element of LIST whose cdr is KEY. */)
1479 (register Lisp_Object key
, Lisp_Object list
)
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCDR (XCAR (list
)), key
)))
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCDR (XCAR (list
)), key
)))
1496 || (CONSP (XCAR (list
))
1497 && EQ (XCDR (XCAR (list
)), key
)))
1507 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1508 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1509 The value is actually the first element of LIST whose cdr equals KEY. */)
1510 (Lisp_Object key
, Lisp_Object list
)
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1531 || (CONSP (XCAR (list
))
1532 && (cdr
= XCDR (XCAR (list
)),
1533 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1543 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1544 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1545 More precisely, this function skips any members `eq' to ELT at the
1546 front of LIST, then removes members `eq' to ELT from the remaining
1547 sublist by modifying its list structure, then returns the resulting
1550 Write `(setq foo (delq element foo))' to be sure of correctly changing
1551 the value of a list `foo'. */)
1552 (register Lisp_Object elt
, Lisp_Object list
)
1554 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1557 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1559 Lisp_Object tem
= XCAR (tail
);
1565 Fsetcdr (prev
, XCDR (tail
));
1573 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1574 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1575 SEQ must be a sequence (i.e. a list, a vector, or a string).
1576 The return value is a sequence of the same type.
1578 If SEQ is a list, this behaves like `delq', except that it compares
1579 with `equal' instead of `eq'. In particular, it may remove elements
1580 by altering the list structure.
1582 If SEQ is not a list, deletion is never performed destructively;
1583 instead this function creates and returns a new vector or string.
1585 Write `(setq foo (delete element foo))' to be sure of correctly
1586 changing the value of a sequence `foo'. */)
1587 (Lisp_Object elt
, Lisp_Object seq
)
1593 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1594 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1597 if (n
!= ASIZE (seq
))
1599 struct Lisp_Vector
*p
= allocate_vector (n
);
1601 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1602 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1603 p
->contents
[n
++] = AREF (seq
, i
);
1605 XSETVECTOR (seq
, p
);
1608 else if (STRINGP (seq
))
1610 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1613 for (i
= nchars
= nbytes
= ibyte
= 0;
1615 ++i
, ibyte
+= cbytes
)
1617 if (STRING_MULTIBYTE (seq
))
1619 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1620 cbytes
= CHAR_BYTES (c
);
1628 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1635 if (nchars
!= SCHARS (seq
))
1639 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1640 if (!STRING_MULTIBYTE (seq
))
1641 STRING_SET_UNIBYTE (tem
);
1643 for (i
= nchars
= nbytes
= ibyte
= 0;
1645 ++i
, ibyte
+= cbytes
)
1647 if (STRING_MULTIBYTE (seq
))
1649 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1650 cbytes
= CHAR_BYTES (c
);
1658 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1660 unsigned char *from
= SDATA (seq
) + ibyte
;
1661 unsigned char *to
= SDATA (tem
) + nbytes
;
1667 for (n
= cbytes
; n
--; )
1677 Lisp_Object tail
, prev
;
1679 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1681 CHECK_LIST_CONS (tail
, seq
);
1683 if (!NILP (Fequal (elt
, XCAR (tail
))))
1688 Fsetcdr (prev
, XCDR (tail
));
1699 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1700 doc
: /* Reverse LIST by modifying cdr pointers.
1701 Return the reversed list. Expects a properly nil-terminated list. */)
1704 register Lisp_Object prev
, tail
, next
;
1706 if (NILP (list
)) return list
;
1709 while (!NILP (tail
))
1712 CHECK_LIST_CONS (tail
, tail
);
1714 Fsetcdr (tail
, prev
);
1721 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1722 doc
: /* Reverse LIST, copying. Return the reversed list.
1723 See also the function `nreverse', which is used more often. */)
1728 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1731 new = Fcons (XCAR (list
), new);
1733 CHECK_LIST_END (list
, list
);
1737 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1738 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1739 Returns the sorted list. LIST is modified by side effects.
1740 PREDICATE is called with two elements of LIST, and should return non-nil
1741 if the first element should sort before the second. */)
1742 (Lisp_Object list
, Lisp_Object predicate
)
1744 Lisp_Object front
, back
;
1745 register Lisp_Object len
, tem
;
1746 struct gcpro gcpro1
, gcpro2
;
1750 len
= Flength (list
);
1751 length
= XINT (len
);
1755 XSETINT (len
, (length
/ 2) - 1);
1756 tem
= Fnthcdr (len
, list
);
1758 Fsetcdr (tem
, Qnil
);
1760 GCPRO2 (front
, back
);
1761 front
= Fsort (front
, predicate
);
1762 back
= Fsort (back
, predicate
);
1764 return merge (front
, back
, predicate
);
1768 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1771 register Lisp_Object tail
;
1773 register Lisp_Object l1
, l2
;
1774 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1781 /* It is sufficient to protect org_l1 and org_l2.
1782 When l1 and l2 are updated, we copy the new values
1783 back into the org_ vars. */
1784 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1804 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1820 Fsetcdr (tail
, tem
);
1826 /* This does not check for quits. That is safe since it must terminate. */
1828 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1829 doc
: /* Extract a value from a property list.
1830 PLIST is a property list, which is a list of the form
1831 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1832 corresponding to the given PROP, or nil if PROP is not one of the
1833 properties on the list. This function never signals an error. */)
1834 (Lisp_Object plist
, Lisp_Object prop
)
1836 Lisp_Object tail
, halftail
;
1838 /* halftail is used to detect circular lists. */
1839 tail
= halftail
= plist
;
1840 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1842 if (EQ (prop
, XCAR (tail
)))
1843 return XCAR (XCDR (tail
));
1845 tail
= XCDR (XCDR (tail
));
1846 halftail
= XCDR (halftail
);
1847 if (EQ (tail
, halftail
))
1854 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1855 doc
: /* Return the value of SYMBOL's PROPNAME property.
1856 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1857 (Lisp_Object symbol
, Lisp_Object propname
)
1859 CHECK_SYMBOL (symbol
);
1860 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1863 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1864 doc
: /* Change value in PLIST of PROP to VAL.
1865 PLIST is a property list, which is a list of the form
1866 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1867 If PROP is already a property on the list, its value is set to VAL,
1868 otherwise the new PROP VAL pair is added. The new plist is returned;
1869 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1870 The PLIST is modified by side effects. */)
1871 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1873 register Lisp_Object tail
, prev
;
1874 Lisp_Object newcell
;
1876 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1877 tail
= XCDR (XCDR (tail
)))
1879 if (EQ (prop
, XCAR (tail
)))
1881 Fsetcar (XCDR (tail
), val
);
1888 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1892 Fsetcdr (XCDR (prev
), newcell
);
1896 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1897 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1898 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1899 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1901 CHECK_SYMBOL (symbol
);
1903 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1907 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1908 doc
: /* Extract a value from a property list, comparing with `equal'.
1909 PLIST is a property list, which is a list of the form
1910 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1911 corresponding to the given PROP, or nil if PROP is not
1912 one of the properties on the list. */)
1913 (Lisp_Object plist
, Lisp_Object prop
)
1918 CONSP (tail
) && CONSP (XCDR (tail
));
1919 tail
= XCDR (XCDR (tail
)))
1921 if (! NILP (Fequal (prop
, XCAR (tail
))))
1922 return XCAR (XCDR (tail
));
1927 CHECK_LIST_END (tail
, prop
);
1932 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1933 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1934 PLIST is a property list, which is a list of the form
1935 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1936 If PROP is already a property on the list, its value is set to VAL,
1937 otherwise the new PROP VAL pair is added. The new plist is returned;
1938 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1939 The PLIST is modified by side effects. */)
1940 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1942 register Lisp_Object tail
, prev
;
1943 Lisp_Object newcell
;
1945 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1946 tail
= XCDR (XCDR (tail
)))
1948 if (! NILP (Fequal (prop
, XCAR (tail
))))
1950 Fsetcar (XCDR (tail
), val
);
1957 newcell
= list2 (prop
, val
);
1961 Fsetcdr (XCDR (prev
), newcell
);
1965 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1966 doc
: /* Return t if the two args are the same Lisp object.
1967 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1968 (Lisp_Object obj1
, Lisp_Object obj2
)
1971 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
1973 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1976 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1977 doc
: /* Return t if two Lisp objects have similar structure and contents.
1978 They must have the same data type.
1979 Conses are compared by comparing the cars and the cdrs.
1980 Vectors and strings are compared element by element.
1981 Numbers are compared by value, but integers cannot equal floats.
1982 (Use `=' if you want integers and floats to be able to be equal.)
1983 Symbols must match exactly. */)
1984 (register Lisp_Object o1
, Lisp_Object o2
)
1986 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
1989 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1990 doc
: /* Return t if two Lisp objects have similar structure and contents.
1991 This is like `equal' except that it compares the text properties
1992 of strings. (`equal' ignores text properties.) */)
1993 (register Lisp_Object o1
, Lisp_Object o2
)
1995 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
1998 /* DEPTH is current depth of recursion. Signal an error if it
2000 PROPS means compare string text properties too. */
2003 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2009 error ("Stack overflow in equal");
2012 Lisp_Object args
[2];
2015 ht
= Fmake_hash_table (2, args
);
2019 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2021 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2023 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2025 { /* `o1' was seen already. */
2026 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2027 if (!NILP (Fmemq (o2
, o2s
)))
2030 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2033 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2043 if (XTYPE (o1
) != XTYPE (o2
))
2052 d1
= extract_float (o1
);
2053 d2
= extract_float (o2
);
2054 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2055 though they are not =. */
2056 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2060 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2064 /* FIXME: This inf-loops in a circular list! */
2068 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2072 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2073 depth
+ 1, props
, ht
)
2074 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2075 depth
+ 1, props
, ht
))
2077 o1
= XOVERLAY (o1
)->plist
;
2078 o2
= XOVERLAY (o2
)->plist
;
2083 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2084 && (XMARKER (o1
)->buffer
== 0
2085 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2089 case Lisp_Vectorlike
:
2092 ptrdiff_t size
= ASIZE (o1
);
2093 /* Pseudovectors have the type encoded in the size field, so this test
2094 actually checks that the objects have the same type as well as the
2096 if (ASIZE (o2
) != size
)
2098 /* Boolvectors are compared much like strings. */
2099 if (BOOL_VECTOR_P (o1
))
2101 EMACS_INT size
= bool_vector_size (o1
);
2102 if (size
!= bool_vector_size (o2
))
2104 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2105 bool_vector_bytes (size
)))
2109 if (WINDOW_CONFIGURATIONP (o1
))
2110 return compare_window_configurations (o1
, o2
, 0);
2112 /* Aside from them, only true vectors, char-tables, compiled
2113 functions, and fonts (font-spec, font-entity, font-object)
2114 are sensible to compare, so eliminate the others now. */
2115 if (size
& PSEUDOVECTOR_FLAG
)
2117 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2120 size
&= PSEUDOVECTOR_SIZE_MASK
;
2122 for (i
= 0; i
< size
; i
++)
2127 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2135 if (SCHARS (o1
) != SCHARS (o2
))
2137 if (SBYTES (o1
) != SBYTES (o2
))
2139 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2141 if (props
&& !compare_string_intervals (o1
, o2
))
2153 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2154 doc
: /* Store each element of ARRAY with ITEM.
2155 ARRAY is a vector, string, char-table, or bool-vector. */)
2156 (Lisp_Object array
, Lisp_Object item
)
2158 register ptrdiff_t size
, idx
;
2160 if (VECTORP (array
))
2161 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2162 ASET (array
, idx
, item
);
2163 else if (CHAR_TABLE_P (array
))
2167 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2168 set_char_table_contents (array
, i
, item
);
2169 set_char_table_defalt (array
, item
);
2171 else if (STRINGP (array
))
2173 register unsigned char *p
= SDATA (array
);
2175 CHECK_CHARACTER (item
);
2176 charval
= XFASTINT (item
);
2177 size
= SCHARS (array
);
2178 if (STRING_MULTIBYTE (array
))
2180 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2181 int len
= CHAR_STRING (charval
, str
);
2182 ptrdiff_t size_byte
= SBYTES (array
);
2184 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2185 || SCHARS (array
) * len
!= size_byte
)
2186 error ("Attempt to change byte length of a string");
2187 for (idx
= 0; idx
< size_byte
; idx
++)
2188 *p
++ = str
[idx
% len
];
2191 for (idx
= 0; idx
< size
; idx
++)
2194 else if (BOOL_VECTOR_P (array
))
2195 return bool_vector_fill (array
, item
);
2197 wrong_type_argument (Qarrayp
, array
);
2201 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2203 doc
: /* Clear the contents of STRING.
2204 This makes STRING unibyte and may change its length. */)
2205 (Lisp_Object string
)
2208 CHECK_STRING (string
);
2209 len
= SBYTES (string
);
2210 memset (SDATA (string
), 0, len
);
2211 STRING_SET_CHARS (string
, len
);
2212 STRING_SET_UNIBYTE (string
);
2218 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2220 Lisp_Object args
[2];
2223 return Fnconc (2, args
);
2226 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2227 doc
: /* Concatenate any number of lists by altering them.
2228 Only the last argument is not altered, and need not be a list.
2229 usage: (nconc &rest LISTS) */)
2230 (ptrdiff_t nargs
, Lisp_Object
*args
)
2233 register Lisp_Object tail
, tem
, val
;
2237 for (argnum
= 0; argnum
< nargs
; argnum
++)
2240 if (NILP (tem
)) continue;
2245 if (argnum
+ 1 == nargs
) break;
2247 CHECK_LIST_CONS (tem
, tem
);
2256 tem
= args
[argnum
+ 1];
2257 Fsetcdr (tail
, tem
);
2259 args
[argnum
+ 1] = tail
;
2265 /* This is the guts of all mapping functions.
2266 Apply FN to each element of SEQ, one by one,
2267 storing the results into elements of VALS, a C vector of Lisp_Objects.
2268 LENI is the length of VALS, which should also be the length of SEQ. */
2271 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2273 register Lisp_Object tail
;
2275 register EMACS_INT i
;
2276 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2280 /* Don't let vals contain any garbage when GC happens. */
2281 for (i
= 0; i
< leni
; i
++)
2284 GCPRO3 (dummy
, fn
, seq
);
2286 gcpro1
.nvars
= leni
;
2290 /* We need not explicitly protect `tail' because it is used only on lists, and
2291 1) lists are not relocated and 2) the list is marked via `seq' so will not
2294 if (VECTORP (seq
) || COMPILEDP (seq
))
2296 for (i
= 0; i
< leni
; i
++)
2298 dummy
= call1 (fn
, AREF (seq
, i
));
2303 else if (BOOL_VECTOR_P (seq
))
2305 for (i
= 0; i
< leni
; i
++)
2307 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2312 else if (STRINGP (seq
))
2316 for (i
= 0, i_byte
= 0; i
< leni
;)
2319 ptrdiff_t i_before
= i
;
2321 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2322 XSETFASTINT (dummy
, c
);
2323 dummy
= call1 (fn
, dummy
);
2325 vals
[i_before
] = dummy
;
2328 else /* Must be a list, since Flength did not get an error */
2331 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2333 dummy
= call1 (fn
, XCAR (tail
));
2343 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2344 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2345 In between each pair of results, stick in SEPARATOR. Thus, " " as
2346 SEPARATOR results in spaces between the values returned by FUNCTION.
2347 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2348 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2351 register EMACS_INT leni
;
2354 register Lisp_Object
*args
;
2355 struct gcpro gcpro1
;
2359 len
= Flength (sequence
);
2360 if (CHAR_TABLE_P (sequence
))
2361 wrong_type_argument (Qlistp
, sequence
);
2363 nargs
= leni
+ leni
- 1;
2364 if (nargs
< 0) return empty_unibyte_string
;
2366 SAFE_ALLOCA_LISP (args
, nargs
);
2369 mapcar1 (leni
, args
, function
, sequence
);
2372 for (i
= leni
- 1; i
> 0; i
--)
2373 args
[i
+ i
] = args
[i
];
2375 for (i
= 1; i
< nargs
; i
+= 2)
2376 args
[i
] = separator
;
2378 ret
= Fconcat (nargs
, args
);
2384 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2385 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2386 The result is a list just as long as SEQUENCE.
2387 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2388 (Lisp_Object function
, Lisp_Object sequence
)
2390 register Lisp_Object len
;
2391 register EMACS_INT leni
;
2392 register Lisp_Object
*args
;
2396 len
= Flength (sequence
);
2397 if (CHAR_TABLE_P (sequence
))
2398 wrong_type_argument (Qlistp
, sequence
);
2399 leni
= XFASTINT (len
);
2401 SAFE_ALLOCA_LISP (args
, leni
);
2403 mapcar1 (leni
, args
, function
, sequence
);
2405 ret
= Flist (leni
, args
);
2411 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2412 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2413 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2414 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2415 (Lisp_Object function
, Lisp_Object sequence
)
2417 register EMACS_INT leni
;
2419 leni
= XFASTINT (Flength (sequence
));
2420 if (CHAR_TABLE_P (sequence
))
2421 wrong_type_argument (Qlistp
, sequence
);
2422 mapcar1 (leni
, 0, function
, sequence
);
2427 /* This is how C code calls `yes-or-no-p' and allows the user
2430 Anything that calls this function must protect from GC! */
2433 do_yes_or_no_p (Lisp_Object prompt
)
2435 return call1 (intern ("yes-or-no-p"), prompt
);
2438 /* Anything that calls this function must protect from GC! */
2440 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2441 doc
: /* Ask user a yes-or-no question.
2442 Return t if answer is yes, and nil if the answer is no.
2443 PROMPT is the string to display to ask the question. It should end in
2444 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2446 The user must confirm the answer with RET, and can edit it until it
2449 If dialog boxes are supported, a dialog box will be used
2450 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2451 (Lisp_Object prompt
)
2453 register Lisp_Object ans
;
2454 Lisp_Object args
[2];
2455 struct gcpro gcpro1
;
2457 CHECK_STRING (prompt
);
2459 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2462 Lisp_Object pane
, menu
, obj
;
2463 redisplay_preserve_echo_area (4);
2464 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2465 Fcons (build_string ("No"), Qnil
));
2467 menu
= Fcons (prompt
, pane
);
2468 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2474 args
[1] = build_string ("(yes or no) ");
2475 prompt
= Fconcat (2, args
);
2481 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2482 Qyes_or_no_p_history
, Qnil
,
2484 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2489 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2497 message1 ("Please answer yes or no.");
2498 Fsleep_for (make_number (2), Qnil
);
2502 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2503 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2505 Each of the three load averages is multiplied by 100, then converted
2508 When USE-FLOATS is non-nil, floats will be used instead of integers.
2509 These floats are not multiplied by 100.
2511 If the 5-minute or 15-minute load averages are not available, return a
2512 shortened list, containing only those averages which are available.
2514 An error is thrown if the load average can't be obtained. In some
2515 cases making it work would require Emacs being installed setuid or
2516 setgid so that it can read kernel information, and that usually isn't
2518 (Lisp_Object use_floats
)
2521 int loads
= getloadavg (load_ave
, 3);
2522 Lisp_Object ret
= Qnil
;
2525 error ("load-average not implemented for this operating system");
2529 Lisp_Object load
= (NILP (use_floats
)
2530 ? make_number (100.0 * load_ave
[loads
])
2531 : make_float (load_ave
[loads
]));
2532 ret
= Fcons (load
, ret
);
2538 static Lisp_Object Qsubfeatures
;
2540 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2541 doc
: /* Return t if FEATURE is present in this Emacs.
2543 Use this to conditionalize execution of lisp code based on the
2544 presence or absence of Emacs or environment extensions.
2545 Use `provide' to declare that a feature is available. This function
2546 looks at the value of the variable `features'. The optional argument
2547 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2548 (Lisp_Object feature
, Lisp_Object subfeature
)
2550 register Lisp_Object tem
;
2551 CHECK_SYMBOL (feature
);
2552 tem
= Fmemq (feature
, Vfeatures
);
2553 if (!NILP (tem
) && !NILP (subfeature
))
2554 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2555 return (NILP (tem
)) ? Qnil
: Qt
;
2558 static Lisp_Object Qfuncall
;
2560 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2561 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2562 The optional argument SUBFEATURES should be a list of symbols listing
2563 particular subfeatures supported in this version of FEATURE. */)
2564 (Lisp_Object feature
, Lisp_Object subfeatures
)
2566 register Lisp_Object tem
;
2567 CHECK_SYMBOL (feature
);
2568 CHECK_LIST (subfeatures
);
2569 if (!NILP (Vautoload_queue
))
2570 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2572 tem
= Fmemq (feature
, Vfeatures
);
2574 Vfeatures
= Fcons (feature
, Vfeatures
);
2575 if (!NILP (subfeatures
))
2576 Fput (feature
, Qsubfeatures
, subfeatures
);
2577 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2579 /* Run any load-hooks for this file. */
2580 tem
= Fassq (feature
, Vafter_load_alist
);
2582 Fmapc (Qfuncall
, XCDR (tem
));
2587 /* `require' and its subroutines. */
2589 /* List of features currently being require'd, innermost first. */
2591 static Lisp_Object require_nesting_list
;
2594 require_unwind (Lisp_Object old_value
)
2596 require_nesting_list
= old_value
;
2599 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2600 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2601 If FEATURE is not a member of the list `features', then the feature
2602 is not loaded; so load the file FILENAME.
2603 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2604 and `load' will try to load this name appended with the suffix `.elc' or
2605 `.el', in that order. The name without appended suffix will not be used.
2606 See `get-load-suffixes' for the complete list of suffixes.
2607 If the optional third argument NOERROR is non-nil,
2608 then return nil if the file is not found instead of signaling an error.
2609 Normally the return value is FEATURE.
2610 The normal messages at start and end of loading FILENAME are suppressed. */)
2611 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2614 struct gcpro gcpro1
, gcpro2
;
2615 bool from_file
= load_in_progress
;
2617 CHECK_SYMBOL (feature
);
2619 /* Record the presence of `require' in this file
2620 even if the feature specified is already loaded.
2621 But not more than once in any file,
2622 and not when we aren't loading or reading from a file. */
2624 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2625 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2630 tem
= Fcons (Qrequire
, feature
);
2631 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2632 LOADHIST_ATTACH (tem
);
2634 tem
= Fmemq (feature
, Vfeatures
);
2638 ptrdiff_t count
= SPECPDL_INDEX ();
2641 /* This is to make sure that loadup.el gives a clear picture
2642 of what files are preloaded and when. */
2643 if (! NILP (Vpurify_flag
))
2644 error ("(require %s) while preparing to dump",
2645 SDATA (SYMBOL_NAME (feature
)));
2647 /* A certain amount of recursive `require' is legitimate,
2648 but if we require the same feature recursively 3 times,
2650 tem
= require_nesting_list
;
2651 while (! NILP (tem
))
2653 if (! NILP (Fequal (feature
, XCAR (tem
))))
2658 error ("Recursive `require' for feature `%s'",
2659 SDATA (SYMBOL_NAME (feature
)));
2661 /* Update the list for any nested `require's that occur. */
2662 record_unwind_protect (require_unwind
, require_nesting_list
);
2663 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2665 /* Value saved here is to be restored into Vautoload_queue */
2666 record_unwind_protect (un_autoload
, Vautoload_queue
);
2667 Vautoload_queue
= Qt
;
2669 /* Load the file. */
2670 GCPRO2 (feature
, filename
);
2671 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2672 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2675 /* If load failed entirely, return nil. */
2677 return unbind_to (count
, Qnil
);
2679 tem
= Fmemq (feature
, Vfeatures
);
2681 error ("Required feature `%s' was not provided",
2682 SDATA (SYMBOL_NAME (feature
)));
2684 /* Once loading finishes, don't undo it. */
2685 Vautoload_queue
= Qt
;
2686 feature
= unbind_to (count
, feature
);
2692 /* Primitives for work of the "widget" library.
2693 In an ideal world, this section would not have been necessary.
2694 However, lisp function calls being as slow as they are, it turns
2695 out that some functions in the widget library (wid-edit.el) are the
2696 bottleneck of Widget operation. Here is their translation to C,
2697 for the sole reason of efficiency. */
2699 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2700 doc
: /* Return non-nil if PLIST has the property PROP.
2701 PLIST is a property list, which is a list of the form
2702 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2703 Unlike `plist-get', this allows you to distinguish between a missing
2704 property and a property with the value nil.
2705 The value is actually the tail of PLIST whose car is PROP. */)
2706 (Lisp_Object plist
, Lisp_Object prop
)
2708 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2711 plist
= XCDR (plist
);
2712 plist
= CDR (plist
);
2717 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2718 doc
: /* In WIDGET, set PROPERTY to VALUE.
2719 The value can later be retrieved with `widget-get'. */)
2720 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2722 CHECK_CONS (widget
);
2723 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2727 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2728 doc
: /* In WIDGET, get the value of PROPERTY.
2729 The value could either be specified when the widget was created, or
2730 later with `widget-put'. */)
2731 (Lisp_Object widget
, Lisp_Object property
)
2739 CHECK_CONS (widget
);
2740 tmp
= Fplist_member (XCDR (widget
), property
);
2746 tmp
= XCAR (widget
);
2749 widget
= Fget (tmp
, Qwidget_type
);
2753 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2754 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2755 ARGS are passed as extra arguments to the function.
2756 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2757 (ptrdiff_t nargs
, Lisp_Object
*args
)
2759 /* This function can GC. */
2760 Lisp_Object newargs
[3];
2761 struct gcpro gcpro1
, gcpro2
;
2764 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2765 newargs
[1] = args
[0];
2766 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2767 GCPRO2 (newargs
[0], newargs
[2]);
2768 result
= Fapply (3, newargs
);
2773 #ifdef HAVE_LANGINFO_CODESET
2774 #include <langinfo.h>
2777 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2778 doc
: /* Access locale data ITEM for the current C locale, if available.
2779 ITEM should be one of the following:
2781 `codeset', returning the character set as a string (locale item CODESET);
2783 `days', returning a 7-element vector of day names (locale items DAY_n);
2785 `months', returning a 12-element vector of month names (locale items MON_n);
2787 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2788 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2790 If the system can't provide such information through a call to
2791 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2793 See also Info node `(libc)Locales'.
2795 The data read from the system are decoded using `locale-coding-system'. */)
2799 #ifdef HAVE_LANGINFO_CODESET
2801 if (EQ (item
, Qcodeset
))
2803 str
= nl_langinfo (CODESET
);
2804 return build_string (str
);
2807 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2809 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2810 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2812 struct gcpro gcpro1
;
2814 synchronize_system_time_locale ();
2815 for (i
= 0; i
< 7; i
++)
2817 str
= nl_langinfo (days
[i
]);
2818 val
= build_unibyte_string (str
);
2819 /* Fixme: Is this coding system necessarily right, even if
2820 it is consistent with CODESET? If not, what to do? */
2821 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2829 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2831 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2832 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2833 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2835 struct gcpro gcpro1
;
2837 synchronize_system_time_locale ();
2838 for (i
= 0; i
< 12; i
++)
2840 str
= nl_langinfo (months
[i
]);
2841 val
= build_unibyte_string (str
);
2842 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2849 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2850 but is in the locale files. This could be used by ps-print. */
2852 else if (EQ (item
, Qpaper
))
2853 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2854 #endif /* PAPER_WIDTH */
2855 #endif /* HAVE_LANGINFO_CODESET*/
2859 /* base64 encode/decode functions (RFC 2045).
2860 Based on code from GNU recode. */
2862 #define MIME_LINE_LENGTH 76
2864 #define IS_ASCII(Character) \
2866 #define IS_BASE64(Character) \
2867 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2868 #define IS_BASE64_IGNORABLE(Character) \
2869 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2870 || (Character) == '\f' || (Character) == '\r')
2872 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2873 character or return retval if there are no characters left to
2875 #define READ_QUADRUPLET_BYTE(retval) \
2880 if (nchars_return) \
2881 *nchars_return = nchars; \
2886 while (IS_BASE64_IGNORABLE (c))
2888 /* Table of characters coding the 64 values. */
2889 static const char base64_value_to_char
[64] =
2891 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2892 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2893 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2894 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2895 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2896 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2897 '8', '9', '+', '/' /* 60-63 */
2900 /* Table of base64 values for first 128 characters. */
2901 static const short base64_char_to_value
[128] =
2903 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2904 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2905 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2906 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2907 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2908 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2909 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2910 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2911 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2912 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2913 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2914 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2915 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2918 /* The following diagram shows the logical steps by which three octets
2919 get transformed into four base64 characters.
2921 .--------. .--------. .--------.
2922 |aaaaaabb| |bbbbcccc| |ccdddddd|
2923 `--------' `--------' `--------'
2925 .--------+--------+--------+--------.
2926 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2927 `--------+--------+--------+--------'
2929 .--------+--------+--------+--------.
2930 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2931 `--------+--------+--------+--------'
2933 The octets are divided into 6 bit chunks, which are then encoded into
2934 base64 characters. */
2937 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2938 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2941 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2943 doc
: /* Base64-encode the region between BEG and END.
2944 Return the length of the encoded text.
2945 Optional third argument NO-LINE-BREAK means do not break long lines
2946 into shorter lines. */)
2947 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2950 ptrdiff_t allength
, length
;
2951 ptrdiff_t ibeg
, iend
, encoded_length
;
2952 ptrdiff_t old_pos
= PT
;
2955 validate_region (&beg
, &end
);
2957 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2958 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2959 move_gap_both (XFASTINT (beg
), ibeg
);
2961 /* We need to allocate enough room for encoding the text.
2962 We need 33 1/3% more space, plus a newline every 76
2963 characters, and then we round up. */
2964 length
= iend
- ibeg
;
2965 allength
= length
+ length
/3 + 1;
2966 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2968 encoded
= SAFE_ALLOCA (allength
);
2969 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2970 encoded
, length
, NILP (no_line_break
),
2971 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2972 if (encoded_length
> allength
)
2975 if (encoded_length
< 0)
2977 /* The encoding wasn't possible. */
2979 error ("Multibyte character in data for base64 encoding");
2982 /* Now we have encoded the region, so we insert the new contents
2983 and delete the old. (Insert first in order to preserve markers.) */
2984 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2985 insert (encoded
, encoded_length
);
2987 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2989 /* If point was outside of the region, restore it exactly; else just
2990 move to the beginning of the region. */
2991 if (old_pos
>= XFASTINT (end
))
2992 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2993 else if (old_pos
> XFASTINT (beg
))
2994 old_pos
= XFASTINT (beg
);
2997 /* We return the length of the encoded text. */
2998 return make_number (encoded_length
);
3001 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3003 doc
: /* Base64-encode STRING and return the result.
3004 Optional second argument NO-LINE-BREAK means do not break long lines
3005 into shorter lines. */)
3006 (Lisp_Object string
, Lisp_Object no_line_break
)
3008 ptrdiff_t allength
, length
, encoded_length
;
3010 Lisp_Object encoded_string
;
3013 CHECK_STRING (string
);
3015 /* We need to allocate enough room for encoding the text.
3016 We need 33 1/3% more space, plus a newline every 76
3017 characters, and then we round up. */
3018 length
= SBYTES (string
);
3019 allength
= length
+ length
/3 + 1;
3020 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3022 /* We need to allocate enough room for decoding the text. */
3023 encoded
= SAFE_ALLOCA (allength
);
3025 encoded_length
= base64_encode_1 (SSDATA (string
),
3026 encoded
, length
, NILP (no_line_break
),
3027 STRING_MULTIBYTE (string
));
3028 if (encoded_length
> allength
)
3031 if (encoded_length
< 0)
3033 /* The encoding wasn't possible. */
3035 error ("Multibyte character in data for base64 encoding");
3038 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3041 return encoded_string
;
3045 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3046 bool line_break
, bool multibyte
)
3059 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3060 if (CHAR_BYTE8_P (c
))
3061 c
= CHAR_TO_BYTE8 (c
);
3069 /* Wrap line every 76 characters. */
3073 if (counter
< MIME_LINE_LENGTH
/ 4)
3082 /* Process first byte of a triplet. */
3084 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3085 value
= (0x03 & c
) << 4;
3087 /* Process second byte of a triplet. */
3091 *e
++ = base64_value_to_char
[value
];
3099 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3100 if (CHAR_BYTE8_P (c
))
3101 c
= CHAR_TO_BYTE8 (c
);
3109 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3110 value
= (0x0f & c
) << 2;
3112 /* Process third byte of a triplet. */
3116 *e
++ = base64_value_to_char
[value
];
3123 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3124 if (CHAR_BYTE8_P (c
))
3125 c
= CHAR_TO_BYTE8 (c
);
3133 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3134 *e
++ = base64_value_to_char
[0x3f & c
];
3141 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3143 doc
: /* Base64-decode the region between BEG and END.
3144 Return the length of the decoded text.
3145 If the region can't be decoded, signal an error and don't modify the buffer. */)
3146 (Lisp_Object beg
, Lisp_Object end
)
3148 ptrdiff_t ibeg
, iend
, length
, allength
;
3150 ptrdiff_t old_pos
= PT
;
3151 ptrdiff_t decoded_length
;
3152 ptrdiff_t inserted_chars
;
3153 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3156 validate_region (&beg
, &end
);
3158 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3159 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3161 length
= iend
- ibeg
;
3163 /* We need to allocate enough room for decoding the text. If we are
3164 working on a multibyte buffer, each decoded code may occupy at
3166 allength
= multibyte
? length
* 2 : length
;
3167 decoded
= SAFE_ALLOCA (allength
);
3169 move_gap_both (XFASTINT (beg
), ibeg
);
3170 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3172 multibyte
, &inserted_chars
);
3173 if (decoded_length
> allength
)
3176 if (decoded_length
< 0)
3178 /* The decoding wasn't possible. */
3180 error ("Invalid base64 data");
3183 /* Now we have decoded the region, so we insert the new contents
3184 and delete the old. (Insert first in order to preserve markers.) */
3185 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3186 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3189 /* Delete the original text. */
3190 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3191 iend
+ decoded_length
, 1);
3193 /* If point was outside of the region, restore it exactly; else just
3194 move to the beginning of the region. */
3195 if (old_pos
>= XFASTINT (end
))
3196 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3197 else if (old_pos
> XFASTINT (beg
))
3198 old_pos
= XFASTINT (beg
);
3199 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3201 return make_number (inserted_chars
);
3204 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3206 doc
: /* Base64-decode STRING and return the result. */)
3207 (Lisp_Object string
)
3210 ptrdiff_t length
, decoded_length
;
3211 Lisp_Object decoded_string
;
3214 CHECK_STRING (string
);
3216 length
= SBYTES (string
);
3217 /* We need to allocate enough room for decoding the text. */
3218 decoded
= SAFE_ALLOCA (length
);
3220 /* The decoded result should be unibyte. */
3221 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3223 if (decoded_length
> length
)
3225 else if (decoded_length
>= 0)
3226 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3228 decoded_string
= Qnil
;
3231 if (!STRINGP (decoded_string
))
3232 error ("Invalid base64 data");
3234 return decoded_string
;
3237 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3238 MULTIBYTE, the decoded result should be in multibyte
3239 form. If NCHARS_RETURN is not NULL, store the number of produced
3240 characters in *NCHARS_RETURN. */
3243 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3244 bool multibyte
, ptrdiff_t *nchars_return
)
3246 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3249 unsigned long value
;
3250 ptrdiff_t nchars
= 0;
3254 /* Process first byte of a quadruplet. */
3256 READ_QUADRUPLET_BYTE (e
-to
);
3260 value
= base64_char_to_value
[c
] << 18;
3262 /* Process second byte of a quadruplet. */
3264 READ_QUADRUPLET_BYTE (-1);
3268 value
|= base64_char_to_value
[c
] << 12;
3270 c
= (unsigned char) (value
>> 16);
3271 if (multibyte
&& c
>= 128)
3272 e
+= BYTE8_STRING (c
, e
);
3277 /* Process third byte of a quadruplet. */
3279 READ_QUADRUPLET_BYTE (-1);
3283 READ_QUADRUPLET_BYTE (-1);
3292 value
|= base64_char_to_value
[c
] << 6;
3294 c
= (unsigned char) (0xff & value
>> 8);
3295 if (multibyte
&& c
>= 128)
3296 e
+= BYTE8_STRING (c
, e
);
3301 /* Process fourth byte of a quadruplet. */
3303 READ_QUADRUPLET_BYTE (-1);
3310 value
|= base64_char_to_value
[c
];
3312 c
= (unsigned char) (0xff & value
);
3313 if (multibyte
&& c
>= 128)
3314 e
+= BYTE8_STRING (c
, e
);
3323 /***********************************************************************
3325 ***** Hash Tables *****
3327 ***********************************************************************/
3329 /* Implemented by gerd@gnu.org. This hash table implementation was
3330 inspired by CMUCL hash tables. */
3334 1. For small tables, association lists are probably faster than
3335 hash tables because they have lower overhead.
3337 For uses of hash tables where the O(1) behavior of table
3338 operations is not a requirement, it might therefore be a good idea
3339 not to hash. Instead, we could just do a linear search in the
3340 key_and_value vector of the hash table. This could be done
3341 if a `:linear-search t' argument is given to make-hash-table. */
3344 /* The list of all weak hash tables. Don't staticpro this one. */
3346 static struct Lisp_Hash_Table
*weak_hash_tables
;
3348 /* Various symbols. */
3350 static Lisp_Object Qhash_table_p
;
3351 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3352 Lisp_Object Qeq
, Qequal
;
3353 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3354 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3357 /***********************************************************************
3359 ***********************************************************************/
3362 CHECK_HASH_TABLE (Lisp_Object x
)
3364 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3368 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3370 h
->key_and_value
= key_and_value
;
3373 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3378 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3380 gc_aset (h
->next
, idx
, val
);
3383 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3388 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3390 gc_aset (h
->hash
, idx
, val
);
3393 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3398 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3400 gc_aset (h
->index
, idx
, val
);
3403 /* If OBJ is a Lisp hash table, return a pointer to its struct
3404 Lisp_Hash_Table. Otherwise, signal an error. */
3406 static struct Lisp_Hash_Table
*
3407 check_hash_table (Lisp_Object obj
)
3409 CHECK_HASH_TABLE (obj
);
3410 return XHASH_TABLE (obj
);
3414 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3415 number. A number is "almost" a prime number if it is not divisible
3416 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3419 next_almost_prime (EMACS_INT n
)
3421 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3422 for (n
|= 1; ; n
+= 2)
3423 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3428 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3429 which USED[I] is non-zero. If found at index I in ARGS, set
3430 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3431 0. This function is used to extract a keyword/argument pair from
3432 a DEFUN parameter list. */
3435 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3439 for (i
= 1; i
< nargs
; i
++)
3440 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3451 /* Return a Lisp vector which has the same contents as VEC but has
3452 at least INCR_MIN more entries, where INCR_MIN is positive.
3453 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3454 than NITEMS_MAX. Entries in the resulting
3455 vector that are not copied from VEC are set to nil. */
3458 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3460 struct Lisp_Vector
*v
;
3461 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3462 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3463 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3464 ? nitems_max
: C_language_max
);
3465 eassert (VECTORP (vec
));
3466 eassert (0 < incr_min
&& -1 <= nitems_max
);
3467 old_size
= ASIZE (vec
);
3468 incr_max
= n_max
- old_size
;
3469 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3470 if (incr_max
< incr
)
3471 memory_full (SIZE_MAX
);
3472 new_size
= old_size
+ incr
;
3473 v
= allocate_vector (new_size
);
3474 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3475 for (i
= old_size
; i
< new_size
; ++i
)
3476 v
->contents
[i
] = Qnil
;
3477 XSETVECTOR (vec
, v
);
3482 /***********************************************************************
3484 ***********************************************************************/
3486 static struct hash_table_test hashtest_eq
;
3487 struct hash_table_test hashtest_eql
, hashtest_equal
;
3489 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3490 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3491 KEY2 are the same. */
3494 cmpfn_eql (struct hash_table_test
*ht
,
3498 return (FLOATP (key1
)
3500 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3504 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3505 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3506 KEY2 are the same. */
3509 cmpfn_equal (struct hash_table_test
*ht
,
3513 return !NILP (Fequal (key1
, key2
));
3517 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3518 HASH2 in hash table H using H->user_cmp_function. Value is true
3519 if KEY1 and KEY2 are the same. */
3522 cmpfn_user_defined (struct hash_table_test
*ht
,
3526 Lisp_Object args
[3];
3528 args
[0] = ht
->user_cmp_function
;
3531 return !NILP (Ffuncall (3, args
));
3535 /* Value is a hash code for KEY for use in hash table H which uses
3536 `eq' to compare keys. The hash code returned is guaranteed to fit
3537 in a Lisp integer. */
3540 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3542 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3546 /* Value is a hash code for KEY for use in hash table H which uses
3547 `eql' to compare keys. The hash code returned is guaranteed to fit
3548 in a Lisp integer. */
3551 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3555 hash
= sxhash (key
, 0);
3557 hash
= XHASH (key
) ^ XTYPE (key
);
3561 /* Value is a hash code for KEY for use in hash table H which uses
3562 `equal' to compare keys. The hash code returned is guaranteed to fit
3563 in a Lisp integer. */
3566 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3568 EMACS_UINT hash
= sxhash (key
, 0);
3572 /* Value is a hash code for KEY for use in hash table H which uses as
3573 user-defined function to compare keys. The hash code returned is
3574 guaranteed to fit in a Lisp integer. */
3577 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3579 Lisp_Object args
[2], hash
;
3581 args
[0] = ht
->user_hash_function
;
3583 hash
= Ffuncall (2, args
);
3584 return hashfn_eq (ht
, hash
);
3587 /* An upper bound on the size of a hash table index. It must fit in
3588 ptrdiff_t and be a valid Emacs fixnum. */
3589 #define INDEX_SIZE_BOUND \
3590 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3592 /* Create and initialize a new hash table.
3594 TEST specifies the test the hash table will use to compare keys.
3595 It must be either one of the predefined tests `eq', `eql' or
3596 `equal' or a symbol denoting a user-defined test named TEST with
3597 test and hash functions USER_TEST and USER_HASH.
3599 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3601 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3602 new size when it becomes full is computed by adding REHASH_SIZE to
3603 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3604 table's new size is computed by multiplying its old size with
3607 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3608 be resized when the ratio of (number of entries in the table) /
3609 (table size) is >= REHASH_THRESHOLD.
3611 WEAK specifies the weakness of the table. If non-nil, it must be
3612 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3615 make_hash_table (struct hash_table_test test
,
3616 Lisp_Object size
, Lisp_Object rehash_size
,
3617 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3619 struct Lisp_Hash_Table
*h
;
3621 EMACS_INT index_size
, sz
;
3625 /* Preconditions. */
3626 eassert (SYMBOLP (test
.name
));
3627 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3628 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3629 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3630 eassert (FLOATP (rehash_threshold
)
3631 && 0 < XFLOAT_DATA (rehash_threshold
)
3632 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3634 if (XFASTINT (size
) == 0)
3635 size
= make_number (1);
3637 sz
= XFASTINT (size
);
3638 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3639 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3640 ? next_almost_prime (index_float
)
3641 : INDEX_SIZE_BOUND
+ 1);
3642 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3643 error ("Hash table too large");
3645 /* Allocate a table and initialize it. */
3646 h
= allocate_hash_table ();
3648 /* Initialize hash table slots. */
3651 h
->rehash_threshold
= rehash_threshold
;
3652 h
->rehash_size
= rehash_size
;
3654 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3655 h
->hash
= Fmake_vector (size
, Qnil
);
3656 h
->next
= Fmake_vector (size
, Qnil
);
3657 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3659 /* Set up the free list. */
3660 for (i
= 0; i
< sz
- 1; ++i
)
3661 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3662 h
->next_free
= make_number (0);
3664 XSET_HASH_TABLE (table
, h
);
3665 eassert (HASH_TABLE_P (table
));
3666 eassert (XHASH_TABLE (table
) == h
);
3668 /* Maybe add this hash table to the list of all weak hash tables. */
3670 h
->next_weak
= NULL
;
3673 h
->next_weak
= weak_hash_tables
;
3674 weak_hash_tables
= h
;
3681 /* Return a copy of hash table H1. Keys and values are not copied,
3682 only the table itself is. */
3685 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3688 struct Lisp_Hash_Table
*h2
;
3690 h2
= allocate_hash_table ();
3692 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3693 h2
->hash
= Fcopy_sequence (h1
->hash
);
3694 h2
->next
= Fcopy_sequence (h1
->next
);
3695 h2
->index
= Fcopy_sequence (h1
->index
);
3696 XSET_HASH_TABLE (table
, h2
);
3698 /* Maybe add this hash table to the list of all weak hash tables. */
3699 if (!NILP (h2
->weak
))
3701 h2
->next_weak
= weak_hash_tables
;
3702 weak_hash_tables
= h2
;
3709 /* Resize hash table H if it's too full. If H cannot be resized
3710 because it's already too large, throw an error. */
3713 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3715 if (NILP (h
->next_free
))
3717 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3718 EMACS_INT new_size
, index_size
, nsize
;
3722 if (INTEGERP (h
->rehash_size
))
3723 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3726 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3727 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3729 new_size
= float_new_size
;
3730 if (new_size
<= old_size
)
3731 new_size
= old_size
+ 1;
3734 new_size
= INDEX_SIZE_BOUND
+ 1;
3736 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3737 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3738 ? next_almost_prime (index_float
)
3739 : INDEX_SIZE_BOUND
+ 1);
3740 nsize
= max (index_size
, 2 * new_size
);
3741 if (INDEX_SIZE_BOUND
< nsize
)
3742 error ("Hash table too large to resize");
3744 #ifdef ENABLE_CHECKING
3745 if (HASH_TABLE_P (Vpurify_flag
)
3746 && XHASH_TABLE (Vpurify_flag
) == h
)
3748 Lisp_Object args
[2];
3749 args
[0] = build_string ("Growing hash table to: %d");
3750 args
[1] = make_number (new_size
);
3755 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3756 2 * (new_size
- old_size
), -1));
3757 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3758 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3759 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3761 /* Update the free list. Do it so that new entries are added at
3762 the end of the free list. This makes some operations like
3764 for (i
= old_size
; i
< new_size
- 1; ++i
)
3765 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3767 if (!NILP (h
->next_free
))
3769 Lisp_Object last
, next
;
3771 last
= h
->next_free
;
3772 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3776 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3779 XSETFASTINT (h
->next_free
, old_size
);
3782 for (i
= 0; i
< old_size
; ++i
)
3783 if (!NILP (HASH_HASH (h
, i
)))
3785 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3786 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3787 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3788 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3794 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3795 the hash code of KEY. Value is the index of the entry in H
3796 matching KEY, or -1 if not found. */
3799 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3801 EMACS_UINT hash_code
;
3802 ptrdiff_t start_of_bucket
;
3805 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3806 eassert ((hash_code
& ~INTMASK
) == 0);
3810 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3811 idx
= HASH_INDEX (h
, start_of_bucket
);
3813 /* We need not gcpro idx since it's either an integer or nil. */
3816 ptrdiff_t i
= XFASTINT (idx
);
3817 if (EQ (key
, HASH_KEY (h
, i
))
3819 && hash_code
== XUINT (HASH_HASH (h
, i
))
3820 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3822 idx
= HASH_NEXT (h
, i
);
3825 return NILP (idx
) ? -1 : XFASTINT (idx
);
3829 /* Put an entry into hash table H that associates KEY with VALUE.
3830 HASH is a previously computed hash code of KEY.
3831 Value is the index of the entry in H matching KEY. */
3834 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3837 ptrdiff_t start_of_bucket
, i
;
3839 eassert ((hash
& ~INTMASK
) == 0);
3841 /* Increment count after resizing because resizing may fail. */
3842 maybe_resize_hash_table (h
);
3845 /* Store key/value in the key_and_value vector. */
3846 i
= XFASTINT (h
->next_free
);
3847 h
->next_free
= HASH_NEXT (h
, i
);
3848 set_hash_key_slot (h
, i
, key
);
3849 set_hash_value_slot (h
, i
, value
);
3851 /* Remember its hash code. */
3852 set_hash_hash_slot (h
, i
, make_number (hash
));
3854 /* Add new entry to its collision chain. */
3855 start_of_bucket
= hash
% ASIZE (h
->index
);
3856 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3857 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3862 /* Remove the entry matching KEY from hash table H, if there is one. */
3865 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3867 EMACS_UINT hash_code
;
3868 ptrdiff_t start_of_bucket
;
3869 Lisp_Object idx
, prev
;
3871 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3872 eassert ((hash_code
& ~INTMASK
) == 0);
3873 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3874 idx
= HASH_INDEX (h
, start_of_bucket
);
3877 /* We need not gcpro idx, prev since they're either integers or nil. */
3880 ptrdiff_t i
= XFASTINT (idx
);
3882 if (EQ (key
, HASH_KEY (h
, i
))
3884 && hash_code
== XUINT (HASH_HASH (h
, i
))
3885 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3887 /* Take entry out of collision chain. */
3889 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3891 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3893 /* Clear slots in key_and_value and add the slots to
3895 set_hash_key_slot (h
, i
, Qnil
);
3896 set_hash_value_slot (h
, i
, Qnil
);
3897 set_hash_hash_slot (h
, i
, Qnil
);
3898 set_hash_next_slot (h
, i
, h
->next_free
);
3899 h
->next_free
= make_number (i
);
3901 eassert (h
->count
>= 0);
3907 idx
= HASH_NEXT (h
, i
);
3913 /* Clear hash table H. */
3916 hash_clear (struct Lisp_Hash_Table
*h
)
3920 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3922 for (i
= 0; i
< size
; ++i
)
3924 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3925 set_hash_key_slot (h
, i
, Qnil
);
3926 set_hash_value_slot (h
, i
, Qnil
);
3927 set_hash_hash_slot (h
, i
, Qnil
);
3930 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3931 ASET (h
->index
, i
, Qnil
);
3933 h
->next_free
= make_number (0);
3940 /************************************************************************
3942 ************************************************************************/
3944 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3945 entries from the table that don't survive the current GC.
3946 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3947 true if anything was marked. */
3950 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3952 ptrdiff_t bucket
, n
;
3955 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3958 for (bucket
= 0; bucket
< n
; ++bucket
)
3960 Lisp_Object idx
, next
, prev
;
3962 /* Follow collision chain, removing entries that
3963 don't survive this garbage collection. */
3965 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3967 ptrdiff_t i
= XFASTINT (idx
);
3968 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3969 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3972 if (EQ (h
->weak
, Qkey
))
3973 remove_p
= !key_known_to_survive_p
;
3974 else if (EQ (h
->weak
, Qvalue
))
3975 remove_p
= !value_known_to_survive_p
;
3976 else if (EQ (h
->weak
, Qkey_or_value
))
3977 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3978 else if (EQ (h
->weak
, Qkey_and_value
))
3979 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3983 next
= HASH_NEXT (h
, i
);
3985 if (remove_entries_p
)
3989 /* Take out of collision chain. */
3991 set_hash_index_slot (h
, bucket
, next
);
3993 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3995 /* Add to free list. */
3996 set_hash_next_slot (h
, i
, h
->next_free
);
3999 /* Clear key, value, and hash. */
4000 set_hash_key_slot (h
, i
, Qnil
);
4001 set_hash_value_slot (h
, i
, Qnil
);
4002 set_hash_hash_slot (h
, i
, Qnil
);
4015 /* Make sure key and value survive. */
4016 if (!key_known_to_survive_p
)
4018 mark_object (HASH_KEY (h
, i
));
4022 if (!value_known_to_survive_p
)
4024 mark_object (HASH_VALUE (h
, i
));
4035 /* Remove elements from weak hash tables that don't survive the
4036 current garbage collection. Remove weak tables that don't survive
4037 from Vweak_hash_tables. Called from gc_sweep. */
4039 NO_INLINE
/* For better stack traces */
4041 sweep_weak_hash_tables (void)
4043 struct Lisp_Hash_Table
*h
, *used
, *next
;
4046 /* Mark all keys and values that are in use. Keep on marking until
4047 there is no more change. This is necessary for cases like
4048 value-weak table A containing an entry X -> Y, where Y is used in a
4049 key-weak table B, Z -> Y. If B comes after A in the list of weak
4050 tables, X -> Y might be removed from A, although when looking at B
4051 one finds that it shouldn't. */
4055 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4057 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4058 marked
|= sweep_weak_table (h
, 0);
4063 /* Remove tables and entries that aren't used. */
4064 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4066 next
= h
->next_weak
;
4068 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4070 /* TABLE is marked as used. Sweep its contents. */
4072 sweep_weak_table (h
, 1);
4074 /* Add table to the list of used weak hash tables. */
4075 h
->next_weak
= used
;
4080 weak_hash_tables
= used
;
4085 /***********************************************************************
4086 Hash Code Computation
4087 ***********************************************************************/
4089 /* Maximum depth up to which to dive into Lisp structures. */
4091 #define SXHASH_MAX_DEPTH 3
4093 /* Maximum length up to which to take list and vector elements into
4096 #define SXHASH_MAX_LEN 7
4098 /* Return a hash for string PTR which has length LEN. The hash value
4099 can be any EMACS_UINT value. */
4102 hash_string (char const *ptr
, ptrdiff_t len
)
4104 char const *p
= ptr
;
4105 char const *end
= p
+ len
;
4107 EMACS_UINT hash
= 0;
4112 hash
= sxhash_combine (hash
, c
);
4118 /* Return a hash for string PTR which has length LEN. The hash
4119 code returned is guaranteed to fit in a Lisp integer. */
4122 sxhash_string (char const *ptr
, ptrdiff_t len
)
4124 EMACS_UINT hash
= hash_string (ptr
, len
);
4125 return SXHASH_REDUCE (hash
);
4128 /* Return a hash for the floating point value VAL. */
4131 sxhash_float (double val
)
4133 EMACS_UINT hash
= 0;
4135 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4136 + (sizeof val
% sizeof hash
!= 0))
4140 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4144 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4145 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4146 hash
= sxhash_combine (hash
, u
.word
[i
]);
4147 return SXHASH_REDUCE (hash
);
4150 /* Return a hash for list LIST. DEPTH is the current depth in the
4151 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4154 sxhash_list (Lisp_Object list
, int depth
)
4156 EMACS_UINT hash
= 0;
4159 if (depth
< SXHASH_MAX_DEPTH
)
4161 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4162 list
= XCDR (list
), ++i
)
4164 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4165 hash
= sxhash_combine (hash
, hash2
);
4170 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4171 hash
= sxhash_combine (hash
, hash2
);
4174 return SXHASH_REDUCE (hash
);
4178 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4179 the Lisp structure. */
4182 sxhash_vector (Lisp_Object vec
, int depth
)
4184 EMACS_UINT hash
= ASIZE (vec
);
4187 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4188 for (i
= 0; i
< n
; ++i
)
4190 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4191 hash
= sxhash_combine (hash
, hash2
);
4194 return SXHASH_REDUCE (hash
);
4197 /* Return a hash for bool-vector VECTOR. */
4200 sxhash_bool_vector (Lisp_Object vec
)
4202 EMACS_INT size
= bool_vector_size (vec
);
4203 EMACS_UINT hash
= size
;
4206 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4207 for (i
= 0; i
< n
; ++i
)
4208 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4210 return SXHASH_REDUCE (hash
);
4214 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4215 structure. Value is an unsigned integer clipped to INTMASK. */
4218 sxhash (Lisp_Object obj
, int depth
)
4222 if (depth
> SXHASH_MAX_DEPTH
)
4225 switch (XTYPE (obj
))
4236 obj
= SYMBOL_NAME (obj
);
4240 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4243 /* This can be everything from a vector to an overlay. */
4244 case Lisp_Vectorlike
:
4246 /* According to the CL HyperSpec, two arrays are equal only if
4247 they are `eq', except for strings and bit-vectors. In
4248 Emacs, this works differently. We have to compare element
4250 hash
= sxhash_vector (obj
, depth
);
4251 else if (BOOL_VECTOR_P (obj
))
4252 hash
= sxhash_bool_vector (obj
);
4254 /* Others are `equal' if they are `eq', so let's take their
4260 hash
= sxhash_list (obj
, depth
);
4264 hash
= sxhash_float (XFLOAT_DATA (obj
));
4276 /***********************************************************************
4278 ***********************************************************************/
4281 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4282 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4285 EMACS_UINT hash
= sxhash (obj
, 0);
4286 return make_number (hash
);
4290 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4291 doc
: /* Create and return a new hash table.
4293 Arguments are specified as keyword/argument pairs. The following
4294 arguments are defined:
4296 :test TEST -- TEST must be a symbol that specifies how to compare
4297 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4298 `equal'. User-supplied test and hash functions can be specified via
4299 `define-hash-table-test'.
4301 :size SIZE -- A hint as to how many elements will be put in the table.
4304 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4305 fills up. If REHASH-SIZE is an integer, increase the size by that
4306 amount. If it is a float, it must be > 1.0, and the new size is the
4307 old size multiplied by that factor. Default is 1.5.
4309 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4310 Resize the hash table when the ratio (number of entries / table size)
4311 is greater than or equal to THRESHOLD. Default is 0.8.
4313 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4314 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4315 returned is a weak table. Key/value pairs are removed from a weak
4316 hash table when there are no non-weak references pointing to their
4317 key, value, one of key or value, or both key and value, depending on
4318 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4321 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4322 (ptrdiff_t nargs
, Lisp_Object
*args
)
4324 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4325 struct hash_table_test testdesc
;
4329 /* The vector `used' is used to keep track of arguments that
4330 have been consumed. */
4331 used
= alloca (nargs
* sizeof *used
);
4332 memset (used
, 0, nargs
* sizeof *used
);
4334 /* See if there's a `:test TEST' among the arguments. */
4335 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4336 test
= i
? args
[i
] : Qeql
;
4338 testdesc
= hashtest_eq
;
4339 else if (EQ (test
, Qeql
))
4340 testdesc
= hashtest_eql
;
4341 else if (EQ (test
, Qequal
))
4342 testdesc
= hashtest_equal
;
4345 /* See if it is a user-defined test. */
4348 prop
= Fget (test
, Qhash_table_test
);
4349 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4350 signal_error ("Invalid hash table test", test
);
4351 testdesc
.name
= test
;
4352 testdesc
.user_cmp_function
= XCAR (prop
);
4353 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4354 testdesc
.hashfn
= hashfn_user_defined
;
4355 testdesc
.cmpfn
= cmpfn_user_defined
;
4358 /* See if there's a `:size SIZE' argument. */
4359 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4360 size
= i
? args
[i
] : Qnil
;
4362 size
= make_number (DEFAULT_HASH_SIZE
);
4363 else if (!INTEGERP (size
) || XINT (size
) < 0)
4364 signal_error ("Invalid hash table size", size
);
4366 /* Look for `:rehash-size SIZE'. */
4367 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4368 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4369 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4370 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4371 signal_error ("Invalid hash table rehash size", rehash_size
);
4373 /* Look for `:rehash-threshold THRESHOLD'. */
4374 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4375 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4376 if (! (FLOATP (rehash_threshold
)
4377 && 0 < XFLOAT_DATA (rehash_threshold
)
4378 && XFLOAT_DATA (rehash_threshold
) <= 1))
4379 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4381 /* Look for `:weakness WEAK'. */
4382 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4383 weak
= i
? args
[i
] : Qnil
;
4385 weak
= Qkey_and_value
;
4388 && !EQ (weak
, Qvalue
)
4389 && !EQ (weak
, Qkey_or_value
)
4390 && !EQ (weak
, Qkey_and_value
))
4391 signal_error ("Invalid hash table weakness", weak
);
4393 /* Now, all args should have been used up, or there's a problem. */
4394 for (i
= 0; i
< nargs
; ++i
)
4396 signal_error ("Invalid argument list", args
[i
]);
4398 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4402 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4403 doc
: /* Return a copy of hash table TABLE. */)
4406 return copy_hash_table (check_hash_table (table
));
4410 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4411 doc
: /* Return the number of elements in TABLE. */)
4414 return make_number (check_hash_table (table
)->count
);
4418 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4419 Shash_table_rehash_size
, 1, 1, 0,
4420 doc
: /* Return the current rehash size of TABLE. */)
4423 return check_hash_table (table
)->rehash_size
;
4427 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4428 Shash_table_rehash_threshold
, 1, 1, 0,
4429 doc
: /* Return the current rehash threshold of TABLE. */)
4432 return check_hash_table (table
)->rehash_threshold
;
4436 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4437 doc
: /* Return the size of TABLE.
4438 The size can be used as an argument to `make-hash-table' to create
4439 a hash table than can hold as many elements as TABLE holds
4440 without need for resizing. */)
4443 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4444 return make_number (HASH_TABLE_SIZE (h
));
4448 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4449 doc
: /* Return the test TABLE uses. */)
4452 return check_hash_table (table
)->test
.name
;
4456 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4458 doc
: /* Return the weakness of TABLE. */)
4461 return check_hash_table (table
)->weak
;
4465 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4466 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4469 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4473 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4474 doc
: /* Clear hash table TABLE and return it. */)
4477 hash_clear (check_hash_table (table
));
4478 /* Be compatible with XEmacs. */
4483 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4484 doc
: /* Look up KEY in TABLE and return its associated value.
4485 If KEY is not found, return DFLT which defaults to nil. */)
4486 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4488 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4489 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4490 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4494 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4495 doc
: /* Associate KEY with VALUE in hash table TABLE.
4496 If KEY is already present in table, replace its current value with
4497 VALUE. In any case, return VALUE. */)
4498 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4500 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4504 i
= hash_lookup (h
, key
, &hash
);
4506 set_hash_value_slot (h
, i
, value
);
4508 hash_put (h
, key
, value
, hash
);
4514 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4515 doc
: /* Remove KEY from TABLE. */)
4516 (Lisp_Object key
, Lisp_Object table
)
4518 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4519 hash_remove_from_table (h
, key
);
4524 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4525 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4526 FUNCTION is called with two arguments, KEY and VALUE.
4527 `maphash' always returns nil. */)
4528 (Lisp_Object function
, Lisp_Object table
)
4530 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4531 Lisp_Object args
[3];
4534 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4535 if (!NILP (HASH_HASH (h
, i
)))
4538 args
[1] = HASH_KEY (h
, i
);
4539 args
[2] = HASH_VALUE (h
, i
);
4547 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4548 Sdefine_hash_table_test
, 3, 3, 0,
4549 doc
: /* Define a new hash table test with name NAME, a symbol.
4551 In hash tables created with NAME specified as test, use TEST to
4552 compare keys, and HASH for computing hash codes of keys.
4554 TEST must be a function taking two arguments and returning non-nil if
4555 both arguments are the same. HASH must be a function taking one
4556 argument and returning an object that is the hash code of the argument.
4557 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4558 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4559 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4561 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4566 /************************************************************************
4567 MD5, SHA-1, and SHA-2
4568 ************************************************************************/
4575 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4578 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4582 EMACS_INT start_char
= 0, end_char
= 0;
4583 ptrdiff_t start_byte
, end_byte
;
4584 register EMACS_INT b
, e
;
4585 register struct buffer
*bp
;
4588 void *(*hash_func
) (const char *, size_t, void *);
4591 CHECK_SYMBOL (algorithm
);
4593 if (STRINGP (object
))
4595 if (NILP (coding_system
))
4597 /* Decide the coding-system to encode the data with. */
4599 if (STRING_MULTIBYTE (object
))
4600 /* use default, we can't guess correct value */
4601 coding_system
= preferred_coding_system ();
4603 coding_system
= Qraw_text
;
4606 if (NILP (Fcoding_system_p (coding_system
)))
4608 /* Invalid coding system. */
4610 if (!NILP (noerror
))
4611 coding_system
= Qraw_text
;
4613 xsignal1 (Qcoding_system_error
, coding_system
);
4616 if (STRING_MULTIBYTE (object
))
4617 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4619 size
= SCHARS (object
);
4620 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4622 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4623 end_byte
= (end_char
== size
4625 : string_char_to_byte (object
, end_char
));
4629 struct buffer
*prev
= current_buffer
;
4631 record_unwind_current_buffer ();
4633 CHECK_BUFFER (object
);
4635 bp
= XBUFFER (object
);
4636 set_buffer_internal (bp
);
4642 CHECK_NUMBER_COERCE_MARKER (start
);
4650 CHECK_NUMBER_COERCE_MARKER (end
);
4655 temp
= b
, b
= e
, e
= temp
;
4657 if (!(BEGV
<= b
&& e
<= ZV
))
4658 args_out_of_range (start
, end
);
4660 if (NILP (coding_system
))
4662 /* Decide the coding-system to encode the data with.
4663 See fileio.c:Fwrite-region */
4665 if (!NILP (Vcoding_system_for_write
))
4666 coding_system
= Vcoding_system_for_write
;
4669 bool force_raw_text
= 0;
4671 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4672 if (NILP (coding_system
)
4673 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4675 coding_system
= Qnil
;
4676 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4680 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4682 /* Check file-coding-system-alist. */
4683 Lisp_Object args
[4], val
;
4685 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4686 args
[3] = Fbuffer_file_name (object
);
4687 val
= Ffind_operation_coding_system (4, args
);
4688 if (CONSP (val
) && !NILP (XCDR (val
)))
4689 coding_system
= XCDR (val
);
4692 if (NILP (coding_system
)
4693 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4695 /* If we still have not decided a coding system, use the
4696 default value of buffer-file-coding-system. */
4697 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4701 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4702 /* Confirm that VAL can surely encode the current region. */
4703 coding_system
= call4 (Vselect_safe_coding_system_function
,
4704 make_number (b
), make_number (e
),
4705 coding_system
, Qnil
);
4708 coding_system
= Qraw_text
;
4711 if (NILP (Fcoding_system_p (coding_system
)))
4713 /* Invalid coding system. */
4715 if (!NILP (noerror
))
4716 coding_system
= Qraw_text
;
4718 xsignal1 (Qcoding_system_error
, coding_system
);
4722 object
= make_buffer_string (b
, e
, 0);
4723 set_buffer_internal (prev
);
4724 /* Discard the unwind protect for recovering the current
4728 if (STRING_MULTIBYTE (object
))
4729 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4731 end_byte
= SBYTES (object
);
4734 if (EQ (algorithm
, Qmd5
))
4736 digest_size
= MD5_DIGEST_SIZE
;
4737 hash_func
= md5_buffer
;
4739 else if (EQ (algorithm
, Qsha1
))
4741 digest_size
= SHA1_DIGEST_SIZE
;
4742 hash_func
= sha1_buffer
;
4744 else if (EQ (algorithm
, Qsha224
))
4746 digest_size
= SHA224_DIGEST_SIZE
;
4747 hash_func
= sha224_buffer
;
4749 else if (EQ (algorithm
, Qsha256
))
4751 digest_size
= SHA256_DIGEST_SIZE
;
4752 hash_func
= sha256_buffer
;
4754 else if (EQ (algorithm
, Qsha384
))
4756 digest_size
= SHA384_DIGEST_SIZE
;
4757 hash_func
= sha384_buffer
;
4759 else if (EQ (algorithm
, Qsha512
))
4761 digest_size
= SHA512_DIGEST_SIZE
;
4762 hash_func
= sha512_buffer
;
4765 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4767 /* allocate 2 x digest_size so that it can be re-used to hold the
4769 digest
= make_uninit_string (digest_size
* 2);
4771 hash_func (SSDATA (object
) + start_byte
,
4772 end_byte
- start_byte
,
4777 unsigned char *p
= SDATA (digest
);
4778 for (i
= digest_size
- 1; i
>= 0; i
--)
4780 static char const hexdigit
[16] = "0123456789abcdef";
4782 p
[2 * i
] = hexdigit
[p_i
>> 4];
4783 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4788 return make_unibyte_string (SSDATA (digest
), digest_size
);
4791 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4792 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4794 A message digest is a cryptographic checksum of a document, and the
4795 algorithm to calculate it is defined in RFC 1321.
4797 The two optional arguments START and END are character positions
4798 specifying for which part of OBJECT the message digest should be
4799 computed. If nil or omitted, the digest is computed for the whole
4802 The MD5 message digest is computed from the result of encoding the
4803 text in a coding system, not directly from the internal Emacs form of
4804 the text. The optional fourth argument CODING-SYSTEM specifies which
4805 coding system to encode the text with. It should be the same coding
4806 system that you used or will use when actually writing the text into a
4809 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4810 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4811 system would be chosen by default for writing this text into a file.
4813 If OBJECT is a string, the most preferred coding system (see the
4814 command `prefer-coding-system') is used.
4816 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4817 guesswork fails. Normally, an error is signaled in such case. */)
4818 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4820 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4823 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4824 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4825 ALGORITHM is a symbol specifying the hash to use:
4826 md5, sha1, sha224, sha256, sha384 or sha512.
4828 The two optional arguments START and END are positions specifying for
4829 which part of OBJECT to compute the hash. If nil or omitted, uses the
4832 If BINARY is non-nil, returns a string in binary form. */)
4833 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4835 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4841 DEFSYM (Qmd5
, "md5");
4842 DEFSYM (Qsha1
, "sha1");
4843 DEFSYM (Qsha224
, "sha224");
4844 DEFSYM (Qsha256
, "sha256");
4845 DEFSYM (Qsha384
, "sha384");
4846 DEFSYM (Qsha512
, "sha512");
4848 /* Hash table stuff. */
4849 DEFSYM (Qhash_table_p
, "hash-table-p");
4851 DEFSYM (Qeql
, "eql");
4852 DEFSYM (Qequal
, "equal");
4853 DEFSYM (QCtest
, ":test");
4854 DEFSYM (QCsize
, ":size");
4855 DEFSYM (QCrehash_size
, ":rehash-size");
4856 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4857 DEFSYM (QCweakness
, ":weakness");
4858 DEFSYM (Qkey
, "key");
4859 DEFSYM (Qvalue
, "value");
4860 DEFSYM (Qhash_table_test
, "hash-table-test");
4861 DEFSYM (Qkey_or_value
, "key-or-value");
4862 DEFSYM (Qkey_and_value
, "key-and-value");
4865 defsubr (&Smake_hash_table
);
4866 defsubr (&Scopy_hash_table
);
4867 defsubr (&Shash_table_count
);
4868 defsubr (&Shash_table_rehash_size
);
4869 defsubr (&Shash_table_rehash_threshold
);
4870 defsubr (&Shash_table_size
);
4871 defsubr (&Shash_table_test
);
4872 defsubr (&Shash_table_weakness
);
4873 defsubr (&Shash_table_p
);
4874 defsubr (&Sclrhash
);
4875 defsubr (&Sgethash
);
4876 defsubr (&Sputhash
);
4877 defsubr (&Sremhash
);
4878 defsubr (&Smaphash
);
4879 defsubr (&Sdefine_hash_table_test
);
4881 DEFSYM (Qstring_lessp
, "string-lessp");
4882 DEFSYM (Qprovide
, "provide");
4883 DEFSYM (Qrequire
, "require");
4884 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4885 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4886 DEFSYM (Qwidget_type
, "widget-type");
4888 staticpro (&string_char_byte_cache_string
);
4889 string_char_byte_cache_string
= Qnil
;
4891 require_nesting_list
= Qnil
;
4892 staticpro (&require_nesting_list
);
4894 Fset (Qyes_or_no_p_history
, Qnil
);
4896 DEFVAR_LISP ("features", Vfeatures
,
4897 doc
: /* A list of symbols which are the features of the executing Emacs.
4898 Used by `featurep' and `require', and altered by `provide'. */);
4899 Vfeatures
= list1 (intern_c_string ("emacs"));
4900 DEFSYM (Qsubfeatures
, "subfeatures");
4901 DEFSYM (Qfuncall
, "funcall");
4903 #ifdef HAVE_LANGINFO_CODESET
4904 DEFSYM (Qcodeset
, "codeset");
4905 DEFSYM (Qdays
, "days");
4906 DEFSYM (Qmonths
, "months");
4907 DEFSYM (Qpaper
, "paper");
4908 #endif /* HAVE_LANGINFO_CODESET */
4910 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4911 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4912 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4913 invoked by mouse clicks and mouse menu items.
4915 On some platforms, file selection dialogs are also enabled if this is
4919 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4920 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4921 This applies to commands from menus and tool bar buttons even when
4922 they are initiated from the keyboard. If `use-dialog-box' is nil,
4923 that disables the use of a file dialog, regardless of the value of
4925 use_file_dialog
= 1;
4927 defsubr (&Sidentity
);
4930 defsubr (&Ssafe_length
);
4931 defsubr (&Sstring_bytes
);
4932 defsubr (&Sstring_equal
);
4933 defsubr (&Scompare_strings
);
4934 defsubr (&Sstring_lessp
);
4937 defsubr (&Svconcat
);
4938 defsubr (&Scopy_sequence
);
4939 defsubr (&Sstring_make_multibyte
);
4940 defsubr (&Sstring_make_unibyte
);
4941 defsubr (&Sstring_as_multibyte
);
4942 defsubr (&Sstring_as_unibyte
);
4943 defsubr (&Sstring_to_multibyte
);
4944 defsubr (&Sstring_to_unibyte
);
4945 defsubr (&Scopy_alist
);
4946 defsubr (&Ssubstring
);
4947 defsubr (&Ssubstring_no_properties
);
4960 defsubr (&Snreverse
);
4961 defsubr (&Sreverse
);
4963 defsubr (&Splist_get
);
4965 defsubr (&Splist_put
);
4967 defsubr (&Slax_plist_get
);
4968 defsubr (&Slax_plist_put
);
4971 defsubr (&Sequal_including_properties
);
4972 defsubr (&Sfillarray
);
4973 defsubr (&Sclear_string
);
4977 defsubr (&Smapconcat
);
4978 defsubr (&Syes_or_no_p
);
4979 defsubr (&Sload_average
);
4980 defsubr (&Sfeaturep
);
4981 defsubr (&Srequire
);
4982 defsubr (&Sprovide
);
4983 defsubr (&Splist_member
);
4984 defsubr (&Swidget_put
);
4985 defsubr (&Swidget_get
);
4986 defsubr (&Swidget_apply
);
4987 defsubr (&Sbase64_encode_region
);
4988 defsubr (&Sbase64_decode_region
);
4989 defsubr (&Sbase64_encode_string
);
4990 defsubr (&Sbase64_decode_string
);
4992 defsubr (&Ssecure_hash
);
4993 defsubr (&Slocale_info
);
4995 hashtest_eq
.name
= Qeq
;
4996 hashtest_eq
.user_hash_function
= Qnil
;
4997 hashtest_eq
.user_cmp_function
= Qnil
;
4998 hashtest_eq
.cmpfn
= 0;
4999 hashtest_eq
.hashfn
= hashfn_eq
;
5001 hashtest_eql
.name
= Qeql
;
5002 hashtest_eql
.user_hash_function
= Qnil
;
5003 hashtest_eql
.user_cmp_function
= Qnil
;
5004 hashtest_eql
.cmpfn
= cmpfn_eql
;
5005 hashtest_eql
.hashfn
= hashfn_eql
;
5007 hashtest_equal
.name
= Qequal
;
5008 hashtest_equal
.user_hash_function
= Qnil
;
5009 hashtest_equal
.user_cmp_function
= Qnil
;
5010 hashtest_equal
.cmpfn
= cmpfn_equal
;
5011 hashtest_equal
.hashfn
= hashfn_equal
;