1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2012
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
43 #endif /* HAVE_MENUS */
45 Lisp_Object Qstring_lessp
;
46 static Lisp_Object Qprovide
, Qrequire
;
47 static Lisp_Object Qyes_or_no_p_history
;
48 Lisp_Object Qcursor_in_echo_area
;
49 static Lisp_Object Qwidget_type
;
50 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
52 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
54 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool);
56 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
57 doc
: /* Return the argument unchanged. */)
63 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
64 doc
: /* Return a pseudo-random number.
65 All integers representable in Lisp are equally likely.
66 On most systems, this is 29 bits' worth.
67 With positive integer LIMIT, return random number in interval [0,LIMIT).
68 With argument t, set the random number seed from the current time and pid.
69 Other values of LIMIT are ignored. */)
76 else if (STRINGP (limit
))
77 seed_random (SSDATA (limit
), SBYTES (limit
));
80 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
81 val
%= XFASTINT (limit
);
82 return make_number (val
);
85 /* Heuristic on how many iterations of a tight loop can be safely done
86 before it's time to do a QUIT. This must be a power of 2. */
87 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
89 /* Random data-structure functions */
91 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
92 doc
: /* Return the length of vector, list or string SEQUENCE.
93 A byte-code function object is also allowed.
94 If the string contains multibyte characters, this is not necessarily
95 the number of bytes in the string; it is the number of characters.
96 To get the number of bytes, use `string-bytes'. */)
97 (register Lisp_Object sequence
)
99 register Lisp_Object val
;
101 if (STRINGP (sequence
))
102 XSETFASTINT (val
, SCHARS (sequence
));
103 else if (VECTORP (sequence
))
104 XSETFASTINT (val
, ASIZE (sequence
));
105 else if (CHAR_TABLE_P (sequence
))
106 XSETFASTINT (val
, MAX_CHAR
);
107 else if (BOOL_VECTOR_P (sequence
))
108 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
109 else if (COMPILEDP (sequence
))
110 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
111 else if (CONSP (sequence
))
118 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
120 if (MOST_POSITIVE_FIXNUM
< i
)
121 error ("List too long");
124 sequence
= XCDR (sequence
);
126 while (CONSP (sequence
));
128 CHECK_LIST_END (sequence
, sequence
);
130 val
= make_number (i
);
132 else if (NILP (sequence
))
133 XSETFASTINT (val
, 0);
135 wrong_type_argument (Qsequencep
, sequence
);
140 /* This does not check for quits. That is safe since it must terminate. */
142 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
143 doc
: /* Return the length of a list, but avoid error or infinite loop.
144 This function never gets an error. If LIST is not really a list,
145 it returns 0. If LIST is circular, it returns a finite value
146 which is at least the number of distinct elements. */)
149 Lisp_Object tail
, halftail
;
154 return make_number (0);
156 /* halftail is used to detect circular lists. */
157 for (tail
= halftail
= list
; ; )
162 if (EQ (tail
, halftail
))
165 if ((lolen
& 1) == 0)
167 halftail
= XCDR (halftail
);
168 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
172 hilen
+= UINTMAX_MAX
+ 1.0;
177 /* If the length does not fit into a fixnum, return a float.
178 On all known practical machines this returns an upper bound on
180 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
183 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
184 doc
: /* Return the number of bytes in STRING.
185 If STRING is multibyte, this may be greater than the length of STRING. */)
188 CHECK_STRING (string
);
189 return make_number (SBYTES (string
));
192 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
193 doc
: /* Return t if two strings have identical contents.
194 Case is significant, but text properties are ignored.
195 Symbols are also allowed; their print names are used instead. */)
196 (register Lisp_Object s1
, Lisp_Object s2
)
199 s1
= SYMBOL_NAME (s1
);
201 s2
= SYMBOL_NAME (s2
);
205 if (SCHARS (s1
) != SCHARS (s2
)
206 || SBYTES (s1
) != SBYTES (s2
)
207 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
212 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
213 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
214 In string STR1, skip the first START1 characters and stop at END1.
215 In string STR2, skip the first START2 characters and stop at END2.
216 END1 and END2 default to the full lengths of the respective strings.
218 Case is significant in this comparison if IGNORE-CASE is nil.
219 Unibyte strings are converted to multibyte for comparison.
221 The value is t if the strings (or specified portions) match.
222 If string STR1 is less, the value is a negative number N;
223 - 1 - N is the number of characters that match at the beginning.
224 If string STR1 is greater, the value is a positive number N;
225 N - 1 is the number of characters that match at the beginning. */)
226 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
228 register ptrdiff_t end1_char
, end2_char
;
229 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
234 start1
= make_number (0);
236 start2
= make_number (0);
237 CHECK_NATNUM (start1
);
238 CHECK_NATNUM (start2
);
244 end1_char
= SCHARS (str1
);
245 if (! NILP (end1
) && end1_char
> XINT (end1
))
246 end1_char
= XINT (end1
);
247 if (end1_char
< XINT (start1
))
248 args_out_of_range (str1
, start1
);
250 end2_char
= SCHARS (str2
);
251 if (! NILP (end2
) && end2_char
> XINT (end2
))
252 end2_char
= XINT (end2
);
253 if (end2_char
< XINT (start2
))
254 args_out_of_range (str2
, start2
);
259 i1_byte
= string_char_to_byte (str1
, i1
);
260 i2_byte
= string_char_to_byte (str2
, i2
);
262 while (i1
< end1_char
&& i2
< end2_char
)
264 /* When we find a mismatch, we must compare the
265 characters, not just the bytes. */
268 if (STRING_MULTIBYTE (str1
))
269 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
272 c1
= SREF (str1
, i1
++);
273 MAKE_CHAR_MULTIBYTE (c1
);
276 if (STRING_MULTIBYTE (str2
))
277 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
280 c2
= SREF (str2
, i2
++);
281 MAKE_CHAR_MULTIBYTE (c2
);
287 if (! NILP (ignore_case
))
291 tem
= Fupcase (make_number (c1
));
293 tem
= Fupcase (make_number (c2
));
300 /* Note that I1 has already been incremented
301 past the character that we are comparing;
302 hence we don't add or subtract 1 here. */
304 return make_number (- i1
+ XINT (start1
));
306 return make_number (i1
- XINT (start1
));
310 return make_number (i1
- XINT (start1
) + 1);
312 return make_number (- i1
+ XINT (start1
) - 1);
317 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
318 doc
: /* Return t if first arg string is less than second in lexicographic order.
320 Symbols are also allowed; their print names are used instead. */)
321 (register Lisp_Object s1
, Lisp_Object s2
)
323 register ptrdiff_t end
;
324 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
327 s1
= SYMBOL_NAME (s1
);
329 s2
= SYMBOL_NAME (s2
);
333 i1
= i1_byte
= i2
= i2_byte
= 0;
336 if (end
> SCHARS (s2
))
341 /* When we find a mismatch, we must compare the
342 characters, not just the bytes. */
345 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
346 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
349 return c1
< c2
? Qt
: Qnil
;
351 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
354 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
355 enum Lisp_Type target_type
, bool last_special
);
359 concat2 (Lisp_Object s1
, Lisp_Object s2
)
364 return concat (2, args
, Lisp_String
, 0);
369 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
375 return concat (3, args
, Lisp_String
, 0);
378 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
379 doc
: /* Concatenate all the arguments and make the result a list.
380 The result is a list whose elements are the elements of all the arguments.
381 Each argument may be a list, vector or string.
382 The last argument is not copied, just used as the tail of the new list.
383 usage: (append &rest SEQUENCES) */)
384 (ptrdiff_t nargs
, Lisp_Object
*args
)
386 return concat (nargs
, args
, Lisp_Cons
, 1);
389 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
390 doc
: /* Concatenate all the arguments and make the result a string.
391 The result is a string whose elements are the elements of all the arguments.
392 Each argument may be a string or a list or vector of characters (integers).
393 usage: (concat &rest SEQUENCES) */)
394 (ptrdiff_t nargs
, Lisp_Object
*args
)
396 return concat (nargs
, args
, Lisp_String
, 0);
399 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
400 doc
: /* Concatenate all the arguments and make the result a vector.
401 The result is a vector whose elements are the elements of all the arguments.
402 Each argument may be a list, vector or string.
403 usage: (vconcat &rest SEQUENCES) */)
404 (ptrdiff_t nargs
, Lisp_Object
*args
)
406 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
410 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
411 doc
: /* Return a copy of a list, vector, string or char-table.
412 The elements of a list or vector are not copied; they are shared
413 with the original. */)
416 if (NILP (arg
)) return arg
;
418 if (CHAR_TABLE_P (arg
))
420 return copy_char_table (arg
);
423 if (BOOL_VECTOR_P (arg
))
426 ptrdiff_t size_in_chars
427 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
428 / BOOL_VECTOR_BITS_PER_CHAR
);
430 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
431 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
436 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
437 wrong_type_argument (Qsequencep
, arg
);
439 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
442 /* This structure holds information of an argument of `concat' that is
443 a string and has text properties to be copied. */
446 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
447 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
448 ptrdiff_t to
; /* refer to VAL (the target string) */
452 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
453 enum Lisp_Type target_type
, bool last_special
)
459 ptrdiff_t toindex_byte
= 0;
460 EMACS_INT result_len
;
461 EMACS_INT result_len_byte
;
463 Lisp_Object last_tail
;
466 /* When we make a multibyte string, we can't copy text properties
467 while concatenating each string because the length of resulting
468 string can't be decided until we finish the whole concatenation.
469 So, we record strings that have text properties to be copied
470 here, and copy the text properties after the concatenation. */
471 struct textprop_rec
*textprops
= NULL
;
472 /* Number of elements in textprops. */
473 ptrdiff_t num_textprops
= 0;
478 /* In append, the last arg isn't treated like the others */
479 if (last_special
&& nargs
> 0)
482 last_tail
= args
[nargs
];
487 /* Check each argument. */
488 for (argnum
= 0; argnum
< nargs
; argnum
++)
491 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
492 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
493 wrong_type_argument (Qsequencep
, this);
496 /* Compute total length in chars of arguments in RESULT_LEN.
497 If desired output is a string, also compute length in bytes
498 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
499 whether the result should be a multibyte string. */
503 for (argnum
= 0; argnum
< nargs
; argnum
++)
507 len
= XFASTINT (Flength (this));
508 if (target_type
== Lisp_String
)
510 /* We must count the number of bytes needed in the string
511 as well as the number of characters. */
515 ptrdiff_t this_len_byte
;
517 if (VECTORP (this) || COMPILEDP (this))
518 for (i
= 0; i
< len
; i
++)
521 CHECK_CHARACTER (ch
);
523 this_len_byte
= CHAR_BYTES (c
);
524 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
526 result_len_byte
+= this_len_byte
;
527 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
530 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
531 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
532 else if (CONSP (this))
533 for (; CONSP (this); this = XCDR (this))
536 CHECK_CHARACTER (ch
);
538 this_len_byte
= CHAR_BYTES (c
);
539 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
541 result_len_byte
+= this_len_byte
;
542 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
545 else if (STRINGP (this))
547 if (STRING_MULTIBYTE (this))
550 this_len_byte
= SBYTES (this);
553 this_len_byte
= count_size_as_multibyte (SDATA (this),
555 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
557 result_len_byte
+= this_len_byte
;
562 if (MOST_POSITIVE_FIXNUM
< result_len
)
563 memory_full (SIZE_MAX
);
566 if (! some_multibyte
)
567 result_len_byte
= result_len
;
569 /* Create the output object. */
570 if (target_type
== Lisp_Cons
)
571 val
= Fmake_list (make_number (result_len
), Qnil
);
572 else if (target_type
== Lisp_Vectorlike
)
573 val
= Fmake_vector (make_number (result_len
), Qnil
);
574 else if (some_multibyte
)
575 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
577 val
= make_uninit_string (result_len
);
579 /* In `append', if all but last arg are nil, return last arg. */
580 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
583 /* Copy the contents of the args into the result. */
585 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
587 toindex
= 0, toindex_byte
= 0;
591 SAFE_NALLOCA (textprops
, 1, nargs
);
593 for (argnum
= 0; argnum
< nargs
; argnum
++)
596 ptrdiff_t thisleni
= 0;
597 register ptrdiff_t thisindex
= 0;
598 register ptrdiff_t thisindex_byte
= 0;
602 thislen
= Flength (this), thisleni
= XINT (thislen
);
604 /* Between strings of the same kind, copy fast. */
605 if (STRINGP (this) && STRINGP (val
)
606 && STRING_MULTIBYTE (this) == some_multibyte
)
608 ptrdiff_t thislen_byte
= SBYTES (this);
610 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
611 if (string_intervals (this))
613 textprops
[num_textprops
].argnum
= argnum
;
614 textprops
[num_textprops
].from
= 0;
615 textprops
[num_textprops
++].to
= toindex
;
617 toindex_byte
+= thislen_byte
;
620 /* Copy a single-byte string to a multibyte string. */
621 else if (STRINGP (this) && STRINGP (val
))
623 if (string_intervals (this))
625 textprops
[num_textprops
].argnum
= argnum
;
626 textprops
[num_textprops
].from
= 0;
627 textprops
[num_textprops
++].to
= toindex
;
629 toindex_byte
+= copy_text (SDATA (this),
630 SDATA (val
) + toindex_byte
,
631 SCHARS (this), 0, 1);
635 /* Copy element by element. */
638 register Lisp_Object elt
;
640 /* Fetch next element of `this' arg into `elt', or break if
641 `this' is exhausted. */
642 if (NILP (this)) break;
644 elt
= XCAR (this), this = XCDR (this);
645 else if (thisindex
>= thisleni
)
647 else if (STRINGP (this))
650 if (STRING_MULTIBYTE (this))
651 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
656 c
= SREF (this, thisindex
); thisindex
++;
657 if (some_multibyte
&& !ASCII_CHAR_P (c
))
658 c
= BYTE8_TO_CHAR (c
);
660 XSETFASTINT (elt
, c
);
662 else if (BOOL_VECTOR_P (this))
665 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
666 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
674 elt
= AREF (this, thisindex
);
678 /* Store this element into the result. */
685 else if (VECTORP (val
))
687 ASET (val
, toindex
, elt
);
693 CHECK_CHARACTER (elt
);
696 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
698 SSET (val
, toindex_byte
++, c
);
704 XSETCDR (prev
, last_tail
);
706 if (num_textprops
> 0)
709 ptrdiff_t last_to_end
= -1;
711 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
713 this = args
[textprops
[argnum
].argnum
];
714 props
= text_property_list (this,
716 make_number (SCHARS (this)),
718 /* If successive arguments have properties, be sure that the
719 value of `composition' property be the copy. */
720 if (last_to_end
== textprops
[argnum
].to
)
721 make_composition_value_copy (props
);
722 add_text_properties_from_list (val
, props
,
723 make_number (textprops
[argnum
].to
));
724 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
732 static Lisp_Object string_char_byte_cache_string
;
733 static ptrdiff_t string_char_byte_cache_charpos
;
734 static ptrdiff_t string_char_byte_cache_bytepos
;
737 clear_string_char_byte_cache (void)
739 string_char_byte_cache_string
= Qnil
;
742 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
745 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
748 ptrdiff_t best_below
, best_below_byte
;
749 ptrdiff_t best_above
, best_above_byte
;
751 best_below
= best_below_byte
= 0;
752 best_above
= SCHARS (string
);
753 best_above_byte
= SBYTES (string
);
754 if (best_above
== best_above_byte
)
757 if (EQ (string
, string_char_byte_cache_string
))
759 if (string_char_byte_cache_charpos
< char_index
)
761 best_below
= string_char_byte_cache_charpos
;
762 best_below_byte
= string_char_byte_cache_bytepos
;
766 best_above
= string_char_byte_cache_charpos
;
767 best_above_byte
= string_char_byte_cache_bytepos
;
771 if (char_index
- best_below
< best_above
- char_index
)
773 unsigned char *p
= SDATA (string
) + best_below_byte
;
775 while (best_below
< char_index
)
777 p
+= BYTES_BY_CHAR_HEAD (*p
);
780 i_byte
= p
- SDATA (string
);
784 unsigned char *p
= SDATA (string
) + best_above_byte
;
786 while (best_above
> char_index
)
789 while (!CHAR_HEAD_P (*p
)) p
--;
792 i_byte
= p
- SDATA (string
);
795 string_char_byte_cache_bytepos
= i_byte
;
796 string_char_byte_cache_charpos
= char_index
;
797 string_char_byte_cache_string
= string
;
802 /* Return the character index corresponding to BYTE_INDEX in STRING. */
805 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
808 ptrdiff_t best_below
, best_below_byte
;
809 ptrdiff_t best_above
, best_above_byte
;
811 best_below
= best_below_byte
= 0;
812 best_above
= SCHARS (string
);
813 best_above_byte
= SBYTES (string
);
814 if (best_above
== best_above_byte
)
817 if (EQ (string
, string_char_byte_cache_string
))
819 if (string_char_byte_cache_bytepos
< byte_index
)
821 best_below
= string_char_byte_cache_charpos
;
822 best_below_byte
= string_char_byte_cache_bytepos
;
826 best_above
= string_char_byte_cache_charpos
;
827 best_above_byte
= string_char_byte_cache_bytepos
;
831 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
833 unsigned char *p
= SDATA (string
) + best_below_byte
;
834 unsigned char *pend
= SDATA (string
) + byte_index
;
838 p
+= BYTES_BY_CHAR_HEAD (*p
);
842 i_byte
= p
- SDATA (string
);
846 unsigned char *p
= SDATA (string
) + best_above_byte
;
847 unsigned char *pbeg
= SDATA (string
) + byte_index
;
852 while (!CHAR_HEAD_P (*p
)) p
--;
856 i_byte
= p
- SDATA (string
);
859 string_char_byte_cache_bytepos
= i_byte
;
860 string_char_byte_cache_charpos
= i
;
861 string_char_byte_cache_string
= string
;
866 /* Convert STRING to a multibyte string. */
869 string_make_multibyte (Lisp_Object string
)
876 if (STRING_MULTIBYTE (string
))
879 nbytes
= count_size_as_multibyte (SDATA (string
),
881 /* If all the chars are ASCII, they won't need any more bytes
882 once converted. In that case, we can return STRING itself. */
883 if (nbytes
== SBYTES (string
))
886 buf
= SAFE_ALLOCA (nbytes
);
887 copy_text (SDATA (string
), buf
, SBYTES (string
),
890 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
897 /* Convert STRING (if unibyte) to a multibyte string without changing
898 the number of characters. Characters 0200 trough 0237 are
899 converted to eight-bit characters. */
902 string_to_multibyte (Lisp_Object string
)
909 if (STRING_MULTIBYTE (string
))
912 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
913 /* If all the chars are ASCII, they won't need any more bytes once
915 if (nbytes
== SBYTES (string
))
916 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
918 buf
= SAFE_ALLOCA (nbytes
);
919 memcpy (buf
, SDATA (string
), SBYTES (string
));
920 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
922 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
929 /* Convert STRING to a single-byte string. */
932 string_make_unibyte (Lisp_Object string
)
939 if (! STRING_MULTIBYTE (string
))
942 nchars
= SCHARS (string
);
944 buf
= SAFE_ALLOCA (nchars
);
945 copy_text (SDATA (string
), buf
, SBYTES (string
),
948 ret
= make_unibyte_string ((char *) buf
, nchars
);
954 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
956 doc
: /* Return the multibyte equivalent of STRING.
957 If STRING is unibyte and contains non-ASCII characters, the function
958 `unibyte-char-to-multibyte' is used to convert each unibyte character
959 to a multibyte character. In this case, the returned string is a
960 newly created string with no text properties. If STRING is multibyte
961 or entirely ASCII, it is returned unchanged. In particular, when
962 STRING is unibyte and entirely ASCII, the returned string is unibyte.
963 \(When the characters are all ASCII, Emacs primitives will treat the
964 string the same way whether it is unibyte or multibyte.) */)
967 CHECK_STRING (string
);
969 return string_make_multibyte (string
);
972 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
974 doc
: /* Return the unibyte equivalent of STRING.
975 Multibyte character codes are converted to unibyte according to
976 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
977 If the lookup in the translation table fails, this function takes just
978 the low 8 bits of each character. */)
981 CHECK_STRING (string
);
983 return string_make_unibyte (string
);
986 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
988 doc
: /* Return a unibyte string with the same individual bytes as STRING.
989 If STRING is unibyte, the result is STRING itself.
990 Otherwise it is a newly created string, with no text properties.
991 If STRING is multibyte and contains a character of charset
992 `eight-bit', it is converted to the corresponding single byte. */)
995 CHECK_STRING (string
);
997 if (STRING_MULTIBYTE (string
))
999 ptrdiff_t bytes
= SBYTES (string
);
1000 unsigned char *str
= xmalloc (bytes
);
1002 memcpy (str
, SDATA (string
), bytes
);
1003 bytes
= str_as_unibyte (str
, bytes
);
1004 string
= make_unibyte_string ((char *) str
, bytes
);
1010 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1012 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1013 If STRING is multibyte, the result is STRING itself.
1014 Otherwise it is a newly created string, with no text properties.
1016 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1017 part of a correct utf-8 sequence), it is converted to the corresponding
1018 multibyte character of charset `eight-bit'.
1019 See also `string-to-multibyte'.
1021 Beware, this often doesn't really do what you think it does.
1022 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1023 If you're not sure, whether to use `string-as-multibyte' or
1024 `string-to-multibyte', use `string-to-multibyte'. */)
1025 (Lisp_Object string
)
1027 CHECK_STRING (string
);
1029 if (! STRING_MULTIBYTE (string
))
1031 Lisp_Object new_string
;
1032 ptrdiff_t nchars
, nbytes
;
1034 parse_str_as_multibyte (SDATA (string
),
1037 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1038 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1039 if (nbytes
!= SBYTES (string
))
1040 str_as_multibyte (SDATA (new_string
), nbytes
,
1041 SBYTES (string
), NULL
);
1042 string
= new_string
;
1043 set_string_intervals (string
, NULL
);
1048 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1050 doc
: /* Return a multibyte string with the same individual chars as STRING.
1051 If STRING is multibyte, the result is STRING itself.
1052 Otherwise it is a newly created string, with no text properties.
1054 If STRING is unibyte and contains an 8-bit byte, it is converted to
1055 the corresponding multibyte character of charset `eight-bit'.
1057 This differs from `string-as-multibyte' by converting each byte of a correct
1058 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1059 correct sequence. */)
1060 (Lisp_Object string
)
1062 CHECK_STRING (string
);
1064 return string_to_multibyte (string
);
1067 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1069 doc
: /* Return a unibyte string with the same individual chars as STRING.
1070 If STRING is unibyte, the result is STRING itself.
1071 Otherwise it is a newly created string, with no text properties,
1072 where each `eight-bit' character is converted to the corresponding byte.
1073 If STRING contains a non-ASCII, non-`eight-bit' character,
1074 an error is signaled. */)
1075 (Lisp_Object string
)
1077 CHECK_STRING (string
);
1079 if (STRING_MULTIBYTE (string
))
1081 ptrdiff_t chars
= SCHARS (string
);
1082 unsigned char *str
= xmalloc (chars
);
1083 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1085 if (converted
< chars
)
1086 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1087 string
= make_unibyte_string ((char *) str
, chars
);
1094 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1095 doc
: /* Return a copy of ALIST.
1096 This is an alist which represents the same mapping from objects to objects,
1097 but does not share the alist structure with ALIST.
1098 The objects mapped (cars and cdrs of elements of the alist)
1099 are shared, however.
1100 Elements of ALIST that are not conses are also shared. */)
1103 register Lisp_Object tem
;
1108 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1109 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1111 register Lisp_Object car
;
1115 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1120 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1121 doc
: /* Return a new string whose contents are a substring of STRING.
1122 The returned string consists of the characters between index FROM
1123 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1124 zero-indexed: 0 means the first character of STRING. Negative values
1125 are counted from the end of STRING. If TO is nil, the substring runs
1126 to the end of STRING.
1128 The STRING argument may also be a vector. In that case, the return
1129 value is a new vector that contains the elements between index FROM
1130 \(inclusive) and index TO (exclusive) of that vector argument. */)
1131 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1135 EMACS_INT from_char
, to_char
;
1137 CHECK_VECTOR_OR_STRING (string
);
1138 CHECK_NUMBER (from
);
1140 if (STRINGP (string
))
1141 size
= SCHARS (string
);
1143 size
= ASIZE (string
);
1151 to_char
= XINT (to
);
1156 from_char
= XINT (from
);
1159 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1160 args_out_of_range_3 (string
, make_number (from_char
),
1161 make_number (to_char
));
1163 if (STRINGP (string
))
1166 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1167 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1168 res
= make_specified_string (SSDATA (string
) + from_byte
,
1169 to_char
- from_char
, to_byte
- from_byte
,
1170 STRING_MULTIBYTE (string
));
1171 copy_text_properties (make_number (from_char
), make_number (to_char
),
1172 string
, make_number (0), res
, Qnil
);
1175 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1181 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1182 doc
: /* Return a substring of STRING, without text properties.
1183 It starts at index FROM and ends before TO.
1184 TO may be nil or omitted; then the substring runs to the end of STRING.
1185 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1186 If FROM or TO is negative, it counts from the end.
1188 With one argument, just copy STRING without its properties. */)
1189 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1192 EMACS_INT from_char
, to_char
;
1193 ptrdiff_t from_byte
, to_byte
;
1195 CHECK_STRING (string
);
1197 size
= SCHARS (string
);
1203 CHECK_NUMBER (from
);
1204 from_char
= XINT (from
);
1214 to_char
= XINT (to
);
1219 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1220 args_out_of_range_3 (string
, make_number (from_char
),
1221 make_number (to_char
));
1223 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1225 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1226 return make_specified_string (SSDATA (string
) + from_byte
,
1227 to_char
- from_char
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1231 /* Extract a substring of STRING, giving start and end positions
1232 both in characters and in bytes. */
1235 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1236 ptrdiff_t to
, ptrdiff_t to_byte
)
1241 CHECK_VECTOR_OR_STRING (string
);
1243 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1245 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1246 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1248 if (STRINGP (string
))
1250 res
= make_specified_string (SSDATA (string
) + from_byte
,
1251 to
- from
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1253 copy_text_properties (make_number (from
), make_number (to
),
1254 string
, make_number (0), res
, Qnil
);
1257 res
= Fvector (to
- from
, aref_addr (string
, from
));
1262 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1263 doc
: /* Take cdr N times on LIST, return the result. */)
1264 (Lisp_Object n
, Lisp_Object list
)
1269 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1272 CHECK_LIST_CONS (list
, list
);
1278 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1279 doc
: /* Return the Nth element of LIST.
1280 N counts from zero. If LIST is not that long, nil is returned. */)
1281 (Lisp_Object n
, Lisp_Object list
)
1283 return Fcar (Fnthcdr (n
, list
));
1286 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1287 doc
: /* Return element of SEQUENCE at index N. */)
1288 (register Lisp_Object sequence
, Lisp_Object n
)
1291 if (CONSP (sequence
) || NILP (sequence
))
1292 return Fcar (Fnthcdr (n
, sequence
));
1294 /* Faref signals a "not array" error, so check here. */
1295 CHECK_ARRAY (sequence
, Qsequencep
);
1296 return Faref (sequence
, n
);
1299 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1300 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1301 The value is actually the tail of LIST whose car is ELT. */)
1302 (register Lisp_Object elt
, Lisp_Object list
)
1304 register Lisp_Object tail
;
1305 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1307 register Lisp_Object tem
;
1308 CHECK_LIST_CONS (tail
, list
);
1310 if (! NILP (Fequal (elt
, tem
)))
1317 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1318 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1319 The value is actually the tail of LIST whose car is ELT. */)
1320 (register Lisp_Object elt
, Lisp_Object list
)
1324 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1328 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1332 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1343 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1344 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1345 The value is actually the tail of LIST whose car is ELT. */)
1346 (register Lisp_Object elt
, Lisp_Object list
)
1348 register Lisp_Object tail
;
1351 return Fmemq (elt
, list
);
1353 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1355 register Lisp_Object tem
;
1356 CHECK_LIST_CONS (tail
, list
);
1358 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1365 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1366 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1367 The value is actually the first element of LIST whose car is KEY.
1368 Elements of LIST that are not conses are ignored. */)
1369 (Lisp_Object key
, Lisp_Object list
)
1374 || (CONSP (XCAR (list
))
1375 && EQ (XCAR (XCAR (list
)), key
)))
1380 || (CONSP (XCAR (list
))
1381 && EQ (XCAR (XCAR (list
)), key
)))
1386 || (CONSP (XCAR (list
))
1387 && EQ (XCAR (XCAR (list
)), key
)))
1397 /* Like Fassq but never report an error and do not allow quits.
1398 Use only on lists known never to be circular. */
1401 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1404 && (!CONSP (XCAR (list
))
1405 || !EQ (XCAR (XCAR (list
)), key
)))
1408 return CAR_SAFE (list
);
1411 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1412 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1413 The value is actually the first element of LIST whose car equals KEY. */)
1414 (Lisp_Object key
, Lisp_Object list
)
1421 || (CONSP (XCAR (list
))
1422 && (car
= XCAR (XCAR (list
)),
1423 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1428 || (CONSP (XCAR (list
))
1429 && (car
= XCAR (XCAR (list
)),
1430 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1435 || (CONSP (XCAR (list
))
1436 && (car
= XCAR (XCAR (list
)),
1437 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1447 /* Like Fassoc but never report an error and do not allow quits.
1448 Use only on lists known never to be circular. */
1451 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1454 && (!CONSP (XCAR (list
))
1455 || (!EQ (XCAR (XCAR (list
)), key
)
1456 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1459 return CONSP (list
) ? XCAR (list
) : Qnil
;
1462 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1463 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1464 The value is actually the first element of LIST whose cdr is KEY. */)
1465 (register Lisp_Object key
, Lisp_Object list
)
1470 || (CONSP (XCAR (list
))
1471 && EQ (XCDR (XCAR (list
)), key
)))
1476 || (CONSP (XCAR (list
))
1477 && EQ (XCDR (XCAR (list
)), key
)))
1482 || (CONSP (XCAR (list
))
1483 && EQ (XCDR (XCAR (list
)), key
)))
1493 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1495 The value is actually the first element of LIST whose cdr equals KEY. */)
1496 (Lisp_Object key
, Lisp_Object list
)
1503 || (CONSP (XCAR (list
))
1504 && (cdr
= XCDR (XCAR (list
)),
1505 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1510 || (CONSP (XCAR (list
))
1511 && (cdr
= XCDR (XCAR (list
)),
1512 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1529 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1530 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1531 More precisely, this function skips any members `eq' to ELT at the
1532 front of LIST, then removes members `eq' to ELT from the remaining
1533 sublist by modifying its list structure, then returns the resulting
1536 Write `(setq foo (delq element foo))' to be sure of correctly changing
1537 the value of a list `foo'. */)
1538 (register Lisp_Object elt
, Lisp_Object list
)
1540 register Lisp_Object tail
, prev
;
1541 register Lisp_Object tem
;
1545 while (!NILP (tail
))
1547 CHECK_LIST_CONS (tail
, list
);
1554 Fsetcdr (prev
, XCDR (tail
));
1564 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1565 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1566 SEQ must be a sequence (i.e. a list, a vector, or a string).
1567 The return value is a sequence of the same type.
1569 If SEQ is a list, this behaves like `delq', except that it compares
1570 with `equal' instead of `eq'. In particular, it may remove elements
1571 by altering the list structure.
1573 If SEQ is not a list, deletion is never performed destructively;
1574 instead this function creates and returns a new vector or string.
1576 Write `(setq foo (delete element foo))' to be sure of correctly
1577 changing the value of a sequence `foo'. */)
1578 (Lisp_Object elt
, Lisp_Object seq
)
1584 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1585 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1588 if (n
!= ASIZE (seq
))
1590 struct Lisp_Vector
*p
= allocate_vector (n
);
1592 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1593 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1594 p
->contents
[n
++] = AREF (seq
, i
);
1596 XSETVECTOR (seq
, p
);
1599 else if (STRINGP (seq
))
1601 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1604 for (i
= nchars
= nbytes
= ibyte
= 0;
1606 ++i
, ibyte
+= cbytes
)
1608 if (STRING_MULTIBYTE (seq
))
1610 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1611 cbytes
= CHAR_BYTES (c
);
1619 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1626 if (nchars
!= SCHARS (seq
))
1630 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1631 if (!STRING_MULTIBYTE (seq
))
1632 STRING_SET_UNIBYTE (tem
);
1634 for (i
= nchars
= nbytes
= ibyte
= 0;
1636 ++i
, ibyte
+= cbytes
)
1638 if (STRING_MULTIBYTE (seq
))
1640 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1641 cbytes
= CHAR_BYTES (c
);
1649 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1651 unsigned char *from
= SDATA (seq
) + ibyte
;
1652 unsigned char *to
= SDATA (tem
) + nbytes
;
1658 for (n
= cbytes
; n
--; )
1668 Lisp_Object tail
, prev
;
1670 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1672 CHECK_LIST_CONS (tail
, seq
);
1674 if (!NILP (Fequal (elt
, XCAR (tail
))))
1679 Fsetcdr (prev
, XCDR (tail
));
1690 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1691 doc
: /* Reverse LIST by modifying cdr pointers.
1692 Return the reversed list. */)
1695 register Lisp_Object prev
, tail
, next
;
1697 if (NILP (list
)) return list
;
1700 while (!NILP (tail
))
1703 CHECK_LIST_CONS (tail
, list
);
1705 Fsetcdr (tail
, prev
);
1712 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1713 doc
: /* Reverse LIST, copying. Return the reversed list.
1714 See also the function `nreverse', which is used more often. */)
1719 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1722 new = Fcons (XCAR (list
), new);
1724 CHECK_LIST_END (list
, list
);
1728 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1730 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1731 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1732 Returns the sorted list. LIST is modified by side effects.
1733 PREDICATE is called with two elements of LIST, and should return non-nil
1734 if the first element should sort before the second. */)
1735 (Lisp_Object list
, Lisp_Object predicate
)
1737 Lisp_Object front
, back
;
1738 register Lisp_Object len
, tem
;
1739 struct gcpro gcpro1
, gcpro2
;
1743 len
= Flength (list
);
1744 length
= XINT (len
);
1748 XSETINT (len
, (length
/ 2) - 1);
1749 tem
= Fnthcdr (len
, list
);
1751 Fsetcdr (tem
, Qnil
);
1753 GCPRO2 (front
, back
);
1754 front
= Fsort (front
, predicate
);
1755 back
= Fsort (back
, predicate
);
1757 return merge (front
, back
, predicate
);
1761 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1764 register Lisp_Object tail
;
1766 register Lisp_Object l1
, l2
;
1767 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1774 /* It is sufficient to protect org_l1 and org_l2.
1775 When l1 and l2 are updated, we copy the new values
1776 back into the org_ vars. */
1777 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1797 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1813 Fsetcdr (tail
, tem
);
1819 /* This does not check for quits. That is safe since it must terminate. */
1821 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1822 doc
: /* Extract a value from a property list.
1823 PLIST is a property list, which is a list of the form
1824 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1825 corresponding to the given PROP, or nil if PROP is not one of the
1826 properties on the list. This function never signals an error. */)
1827 (Lisp_Object plist
, Lisp_Object prop
)
1829 Lisp_Object tail
, halftail
;
1831 /* halftail is used to detect circular lists. */
1832 tail
= halftail
= plist
;
1833 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1835 if (EQ (prop
, XCAR (tail
)))
1836 return XCAR (XCDR (tail
));
1838 tail
= XCDR (XCDR (tail
));
1839 halftail
= XCDR (halftail
);
1840 if (EQ (tail
, halftail
))
1843 #if 0 /* Unsafe version. */
1844 /* This function can be called asynchronously
1845 (setup_coding_system). Don't QUIT in that case. */
1846 if (!interrupt_input_blocked
)
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
= Fcons (prop
, Fcons (val
, Qnil
));
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) ? 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) ? 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) ? 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
)
2006 error ("Stack overflow in equal");
2012 if (XTYPE (o1
) != XTYPE (o2
))
2021 d1
= extract_float (o1
);
2022 d2
= extract_float (o2
);
2023 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2024 though they are not =. */
2025 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2029 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2036 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2040 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2042 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2045 o1
= XOVERLAY (o1
)->plist
;
2046 o2
= XOVERLAY (o2
)->plist
;
2051 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2052 && (XMARKER (o1
)->buffer
== 0
2053 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2057 case Lisp_Vectorlike
:
2060 ptrdiff_t size
= ASIZE (o1
);
2061 /* Pseudovectors have the type encoded in the size field, so this test
2062 actually checks that the objects have the same type as well as the
2064 if (ASIZE (o2
) != size
)
2066 /* Boolvectors are compared much like strings. */
2067 if (BOOL_VECTOR_P (o1
))
2069 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2071 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2072 ((XBOOL_VECTOR (o1
)->size
2073 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2074 / BOOL_VECTOR_BITS_PER_CHAR
)))
2078 if (WINDOW_CONFIGURATIONP (o1
))
2079 return compare_window_configurations (o1
, o2
, 0);
2081 /* Aside from them, only true vectors, char-tables, compiled
2082 functions, and fonts (font-spec, font-entity, font-object)
2083 are sensible to compare, so eliminate the others now. */
2084 if (size
& PSEUDOVECTOR_FLAG
)
2086 if (!(size
& ((PVEC_COMPILED
| PVEC_CHAR_TABLE
2087 | PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)
2088 << PSEUDOVECTOR_SIZE_BITS
)))
2090 size
&= PSEUDOVECTOR_SIZE_MASK
;
2092 for (i
= 0; i
< size
; i
++)
2097 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2105 if (SCHARS (o1
) != SCHARS (o2
))
2107 if (SBYTES (o1
) != SBYTES (o2
))
2109 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2111 if (props
&& !compare_string_intervals (o1
, o2
))
2123 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2124 doc
: /* Store each element of ARRAY with ITEM.
2125 ARRAY is a vector, string, char-table, or bool-vector. */)
2126 (Lisp_Object array
, Lisp_Object item
)
2128 register ptrdiff_t size
, idx
;
2130 if (VECTORP (array
))
2131 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2132 ASET (array
, idx
, item
);
2133 else if (CHAR_TABLE_P (array
))
2137 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2138 set_char_table_contents (array
, i
, item
);
2139 set_char_table_defalt (array
, item
);
2141 else if (STRINGP (array
))
2143 register unsigned char *p
= SDATA (array
);
2145 CHECK_CHARACTER (item
);
2146 charval
= XFASTINT (item
);
2147 size
= SCHARS (array
);
2148 if (STRING_MULTIBYTE (array
))
2150 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2151 int len
= CHAR_STRING (charval
, str
);
2152 ptrdiff_t size_byte
= SBYTES (array
);
2154 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2155 || SCHARS (array
) * len
!= size_byte
)
2156 error ("Attempt to change byte length of a string");
2157 for (idx
= 0; idx
< size_byte
; idx
++)
2158 *p
++ = str
[idx
% len
];
2161 for (idx
= 0; idx
< size
; idx
++)
2164 else if (BOOL_VECTOR_P (array
))
2166 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2168 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2169 / BOOL_VECTOR_BITS_PER_CHAR
);
2173 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2175 /* Clear any extraneous bits in the last byte. */
2176 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2180 wrong_type_argument (Qarrayp
, array
);
2184 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2186 doc
: /* Clear the contents of STRING.
2187 This makes STRING unibyte and may change its length. */)
2188 (Lisp_Object string
)
2191 CHECK_STRING (string
);
2192 len
= SBYTES (string
);
2193 memset (SDATA (string
), 0, len
);
2194 STRING_SET_CHARS (string
, len
);
2195 STRING_SET_UNIBYTE (string
);
2201 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2203 Lisp_Object args
[2];
2206 return Fnconc (2, args
);
2209 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2210 doc
: /* Concatenate any number of lists by altering them.
2211 Only the last argument is not altered, and need not be a list.
2212 usage: (nconc &rest LISTS) */)
2213 (ptrdiff_t nargs
, Lisp_Object
*args
)
2216 register Lisp_Object tail
, tem
, val
;
2220 for (argnum
= 0; argnum
< nargs
; argnum
++)
2223 if (NILP (tem
)) continue;
2228 if (argnum
+ 1 == nargs
) break;
2230 CHECK_LIST_CONS (tem
, tem
);
2239 tem
= args
[argnum
+ 1];
2240 Fsetcdr (tail
, tem
);
2242 args
[argnum
+ 1] = tail
;
2248 /* This is the guts of all mapping functions.
2249 Apply FN to each element of SEQ, one by one,
2250 storing the results into elements of VALS, a C vector of Lisp_Objects.
2251 LENI is the length of VALS, which should also be the length of SEQ. */
2254 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2256 register Lisp_Object tail
;
2258 register EMACS_INT i
;
2259 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2263 /* Don't let vals contain any garbage when GC happens. */
2264 for (i
= 0; i
< leni
; i
++)
2267 GCPRO3 (dummy
, fn
, seq
);
2269 gcpro1
.nvars
= leni
;
2273 /* We need not explicitly protect `tail' because it is used only on lists, and
2274 1) lists are not relocated and 2) the list is marked via `seq' so will not
2277 if (VECTORP (seq
) || COMPILEDP (seq
))
2279 for (i
= 0; i
< leni
; i
++)
2281 dummy
= call1 (fn
, AREF (seq
, i
));
2286 else if (BOOL_VECTOR_P (seq
))
2288 for (i
= 0; i
< leni
; i
++)
2291 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2292 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2293 dummy
= call1 (fn
, dummy
);
2298 else if (STRINGP (seq
))
2302 for (i
= 0, i_byte
= 0; i
< leni
;)
2305 ptrdiff_t i_before
= i
;
2307 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2308 XSETFASTINT (dummy
, c
);
2309 dummy
= call1 (fn
, dummy
);
2311 vals
[i_before
] = dummy
;
2314 else /* Must be a list, since Flength did not get an error */
2317 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2319 dummy
= call1 (fn
, XCAR (tail
));
2329 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2330 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2331 In between each pair of results, stick in SEPARATOR. Thus, " " as
2332 SEPARATOR results in spaces between the values returned by FUNCTION.
2333 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2334 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2337 register EMACS_INT leni
;
2340 register Lisp_Object
*args
;
2341 struct gcpro gcpro1
;
2345 len
= Flength (sequence
);
2346 if (CHAR_TABLE_P (sequence
))
2347 wrong_type_argument (Qlistp
, sequence
);
2349 nargs
= leni
+ leni
- 1;
2350 if (nargs
< 0) return empty_unibyte_string
;
2352 SAFE_ALLOCA_LISP (args
, nargs
);
2355 mapcar1 (leni
, args
, function
, sequence
);
2358 for (i
= leni
- 1; i
> 0; i
--)
2359 args
[i
+ i
] = args
[i
];
2361 for (i
= 1; i
< nargs
; i
+= 2)
2362 args
[i
] = separator
;
2364 ret
= Fconcat (nargs
, args
);
2370 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2371 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2372 The result is a list just as long as SEQUENCE.
2373 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2374 (Lisp_Object function
, Lisp_Object sequence
)
2376 register Lisp_Object len
;
2377 register EMACS_INT leni
;
2378 register Lisp_Object
*args
;
2382 len
= Flength (sequence
);
2383 if (CHAR_TABLE_P (sequence
))
2384 wrong_type_argument (Qlistp
, sequence
);
2385 leni
= XFASTINT (len
);
2387 SAFE_ALLOCA_LISP (args
, leni
);
2389 mapcar1 (leni
, args
, function
, sequence
);
2391 ret
= Flist (leni
, args
);
2397 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2398 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2399 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2400 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2401 (Lisp_Object function
, Lisp_Object sequence
)
2403 register EMACS_INT leni
;
2405 leni
= XFASTINT (Flength (sequence
));
2406 if (CHAR_TABLE_P (sequence
))
2407 wrong_type_argument (Qlistp
, sequence
);
2408 mapcar1 (leni
, 0, function
, sequence
);
2413 /* This is how C code calls `yes-or-no-p' and allows the user
2416 Anything that calls this function must protect from GC! */
2419 do_yes_or_no_p (Lisp_Object prompt
)
2421 return call1 (intern ("yes-or-no-p"), prompt
);
2424 /* Anything that calls this function must protect from GC! */
2426 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2427 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2428 PROMPT is the string to display to ask the question. It should end in
2429 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2431 The user must confirm the answer with RET, and can edit it until it
2434 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2435 is nil, and `use-dialog-box' is non-nil. */)
2436 (Lisp_Object prompt
)
2438 register Lisp_Object ans
;
2439 Lisp_Object args
[2];
2440 struct gcpro gcpro1
;
2442 CHECK_STRING (prompt
);
2445 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2446 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2450 Lisp_Object pane
, menu
, obj
;
2451 redisplay_preserve_echo_area (4);
2452 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2453 Fcons (Fcons (build_string ("No"), Qnil
),
2456 menu
= Fcons (prompt
, pane
);
2457 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2461 #endif /* HAVE_MENUS */
2464 args
[1] = build_string ("(yes or no) ");
2465 prompt
= Fconcat (2, args
);
2471 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2472 Qyes_or_no_p_history
, Qnil
,
2474 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2479 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2487 message ("Please answer yes or no.");
2488 Fsleep_for (make_number (2), Qnil
);
2492 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2493 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2495 Each of the three load averages is multiplied by 100, then converted
2498 When USE-FLOATS is non-nil, floats will be used instead of integers.
2499 These floats are not multiplied by 100.
2501 If the 5-minute or 15-minute load averages are not available, return a
2502 shortened list, containing only those averages which are available.
2504 An error is thrown if the load average can't be obtained. In some
2505 cases making it work would require Emacs being installed setuid or
2506 setgid so that it can read kernel information, and that usually isn't
2508 (Lisp_Object use_floats
)
2511 int loads
= getloadavg (load_ave
, 3);
2512 Lisp_Object ret
= Qnil
;
2515 error ("load-average not implemented for this operating system");
2519 Lisp_Object load
= (NILP (use_floats
)
2520 ? make_number (100.0 * load_ave
[loads
])
2521 : make_float (load_ave
[loads
]));
2522 ret
= Fcons (load
, ret
);
2528 static Lisp_Object Qsubfeatures
;
2530 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2531 doc
: /* Return t if FEATURE is present in this Emacs.
2533 Use this to conditionalize execution of lisp code based on the
2534 presence or absence of Emacs or environment extensions.
2535 Use `provide' to declare that a feature is available. This function
2536 looks at the value of the variable `features'. The optional argument
2537 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2538 (Lisp_Object feature
, Lisp_Object subfeature
)
2540 register Lisp_Object tem
;
2541 CHECK_SYMBOL (feature
);
2542 tem
= Fmemq (feature
, Vfeatures
);
2543 if (!NILP (tem
) && !NILP (subfeature
))
2544 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2545 return (NILP (tem
)) ? Qnil
: Qt
;
2548 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2549 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2550 The optional argument SUBFEATURES should be a list of symbols listing
2551 particular subfeatures supported in this version of FEATURE. */)
2552 (Lisp_Object feature
, Lisp_Object subfeatures
)
2554 register Lisp_Object tem
;
2555 CHECK_SYMBOL (feature
);
2556 CHECK_LIST (subfeatures
);
2557 if (!NILP (Vautoload_queue
))
2558 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2560 tem
= Fmemq (feature
, Vfeatures
);
2562 Vfeatures
= Fcons (feature
, Vfeatures
);
2563 if (!NILP (subfeatures
))
2564 Fput (feature
, Qsubfeatures
, subfeatures
);
2565 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2567 /* Run any load-hooks for this file. */
2568 tem
= Fassq (feature
, Vafter_load_alist
);
2570 Fprogn (XCDR (tem
));
2575 /* `require' and its subroutines. */
2577 /* List of features currently being require'd, innermost first. */
2579 static Lisp_Object require_nesting_list
;
2582 require_unwind (Lisp_Object old_value
)
2584 return require_nesting_list
= old_value
;
2587 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2588 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2589 If FEATURE is not a member of the list `features', then the feature
2590 is not loaded; so load the file FILENAME.
2591 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2592 and `load' will try to load this name appended with the suffix `.elc' or
2593 `.el', in that order. The name without appended suffix will not be used.
2594 See `get-load-suffixes' for the complete list of suffixes.
2595 If the optional third argument NOERROR is non-nil,
2596 then return nil if the file is not found instead of signaling an error.
2597 Normally the return value is FEATURE.
2598 The normal messages at start and end of loading FILENAME are suppressed. */)
2599 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2602 struct gcpro gcpro1
, gcpro2
;
2603 bool from_file
= load_in_progress
;
2605 CHECK_SYMBOL (feature
);
2607 /* Record the presence of `require' in this file
2608 even if the feature specified is already loaded.
2609 But not more than once in any file,
2610 and not when we aren't loading or reading from a file. */
2612 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2613 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2618 tem
= Fcons (Qrequire
, feature
);
2619 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2620 LOADHIST_ATTACH (tem
);
2622 tem
= Fmemq (feature
, Vfeatures
);
2626 ptrdiff_t count
= SPECPDL_INDEX ();
2629 /* This is to make sure that loadup.el gives a clear picture
2630 of what files are preloaded and when. */
2631 if (! NILP (Vpurify_flag
))
2632 error ("(require %s) while preparing to dump",
2633 SDATA (SYMBOL_NAME (feature
)));
2635 /* A certain amount of recursive `require' is legitimate,
2636 but if we require the same feature recursively 3 times,
2638 tem
= require_nesting_list
;
2639 while (! NILP (tem
))
2641 if (! NILP (Fequal (feature
, XCAR (tem
))))
2646 error ("Recursive `require' for feature `%s'",
2647 SDATA (SYMBOL_NAME (feature
)));
2649 /* Update the list for any nested `require's that occur. */
2650 record_unwind_protect (require_unwind
, require_nesting_list
);
2651 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2653 /* Value saved here is to be restored into Vautoload_queue */
2654 record_unwind_protect (un_autoload
, Vautoload_queue
);
2655 Vautoload_queue
= Qt
;
2657 /* Load the file. */
2658 GCPRO2 (feature
, filename
);
2659 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2660 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2663 /* If load failed entirely, return nil. */
2665 return unbind_to (count
, Qnil
);
2667 tem
= Fmemq (feature
, Vfeatures
);
2669 error ("Required feature `%s' was not provided",
2670 SDATA (SYMBOL_NAME (feature
)));
2672 /* Once loading finishes, don't undo it. */
2673 Vautoload_queue
= Qt
;
2674 feature
= unbind_to (count
, feature
);
2680 /* Primitives for work of the "widget" library.
2681 In an ideal world, this section would not have been necessary.
2682 However, lisp function calls being as slow as they are, it turns
2683 out that some functions in the widget library (wid-edit.el) are the
2684 bottleneck of Widget operation. Here is their translation to C,
2685 for the sole reason of efficiency. */
2687 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2688 doc
: /* Return non-nil if PLIST has the property PROP.
2689 PLIST is a property list, which is a list of the form
2690 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2691 Unlike `plist-get', this allows you to distinguish between a missing
2692 property and a property with the value nil.
2693 The value is actually the tail of PLIST whose car is PROP. */)
2694 (Lisp_Object plist
, Lisp_Object prop
)
2696 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2699 plist
= XCDR (plist
);
2700 plist
= CDR (plist
);
2705 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2706 doc
: /* In WIDGET, set PROPERTY to VALUE.
2707 The value can later be retrieved with `widget-get'. */)
2708 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2710 CHECK_CONS (widget
);
2711 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2715 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2716 doc
: /* In WIDGET, get the value of PROPERTY.
2717 The value could either be specified when the widget was created, or
2718 later with `widget-put'. */)
2719 (Lisp_Object widget
, Lisp_Object property
)
2727 CHECK_CONS (widget
);
2728 tmp
= Fplist_member (XCDR (widget
), property
);
2734 tmp
= XCAR (widget
);
2737 widget
= Fget (tmp
, Qwidget_type
);
2741 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2742 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2743 ARGS are passed as extra arguments to the function.
2744 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2745 (ptrdiff_t nargs
, Lisp_Object
*args
)
2747 /* This function can GC. */
2748 Lisp_Object newargs
[3];
2749 struct gcpro gcpro1
, gcpro2
;
2752 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2753 newargs
[1] = args
[0];
2754 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2755 GCPRO2 (newargs
[0], newargs
[2]);
2756 result
= Fapply (3, newargs
);
2761 #ifdef HAVE_LANGINFO_CODESET
2762 #include <langinfo.h>
2765 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2766 doc
: /* Access locale data ITEM for the current C locale, if available.
2767 ITEM should be one of the following:
2769 `codeset', returning the character set as a string (locale item CODESET);
2771 `days', returning a 7-element vector of day names (locale items DAY_n);
2773 `months', returning a 12-element vector of month names (locale items MON_n);
2775 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2776 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2778 If the system can't provide such information through a call to
2779 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2781 See also Info node `(libc)Locales'.
2783 The data read from the system are decoded using `locale-coding-system'. */)
2787 #ifdef HAVE_LANGINFO_CODESET
2789 if (EQ (item
, Qcodeset
))
2791 str
= nl_langinfo (CODESET
);
2792 return build_string (str
);
2795 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2797 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2798 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2800 struct gcpro gcpro1
;
2802 synchronize_system_time_locale ();
2803 for (i
= 0; i
< 7; i
++)
2805 str
= nl_langinfo (days
[i
]);
2806 val
= build_unibyte_string (str
);
2807 /* Fixme: Is this coding system necessarily right, even if
2808 it is consistent with CODESET? If not, what to do? */
2809 Faset (v
, make_number (i
),
2810 code_convert_string_norecord (val
, Vlocale_coding_system
,
2818 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2820 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2821 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2822 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2824 struct gcpro gcpro1
;
2826 synchronize_system_time_locale ();
2827 for (i
= 0; i
< 12; i
++)
2829 str
= nl_langinfo (months
[i
]);
2830 val
= build_unibyte_string (str
);
2831 Faset (v
, make_number (i
),
2832 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2838 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2839 but is in the locale files. This could be used by ps-print. */
2841 else if (EQ (item
, Qpaper
))
2843 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2844 make_number (nl_langinfo (PAPER_HEIGHT
)));
2846 #endif /* PAPER_WIDTH */
2847 #endif /* HAVE_LANGINFO_CODESET*/
2851 /* base64 encode/decode functions (RFC 2045).
2852 Based on code from GNU recode. */
2854 #define MIME_LINE_LENGTH 76
2856 #define IS_ASCII(Character) \
2858 #define IS_BASE64(Character) \
2859 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2860 #define IS_BASE64_IGNORABLE(Character) \
2861 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2862 || (Character) == '\f' || (Character) == '\r')
2864 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2865 character or return retval if there are no characters left to
2867 #define READ_QUADRUPLET_BYTE(retval) \
2872 if (nchars_return) \
2873 *nchars_return = nchars; \
2878 while (IS_BASE64_IGNORABLE (c))
2880 /* Table of characters coding the 64 values. */
2881 static const char base64_value_to_char
[64] =
2883 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2884 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2885 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2886 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2887 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2888 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2889 '8', '9', '+', '/' /* 60-63 */
2892 /* Table of base64 values for first 128 characters. */
2893 static const short base64_char_to_value
[128] =
2895 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2896 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2897 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2898 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2899 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2900 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2901 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2902 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2903 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2904 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2905 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2906 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2907 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2910 /* The following diagram shows the logical steps by which three octets
2911 get transformed into four base64 characters.
2913 .--------. .--------. .--------.
2914 |aaaaaabb| |bbbbcccc| |ccdddddd|
2915 `--------' `--------' `--------'
2917 .--------+--------+--------+--------.
2918 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2919 `--------+--------+--------+--------'
2921 .--------+--------+--------+--------.
2922 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2923 `--------+--------+--------+--------'
2925 The octets are divided into 6 bit chunks, which are then encoded into
2926 base64 characters. */
2929 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2930 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2933 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2935 doc
: /* Base64-encode the region between BEG and END.
2936 Return the length of the encoded text.
2937 Optional third argument NO-LINE-BREAK means do not break long lines
2938 into shorter lines. */)
2939 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2942 ptrdiff_t allength
, length
;
2943 ptrdiff_t ibeg
, iend
, encoded_length
;
2944 ptrdiff_t old_pos
= PT
;
2947 validate_region (&beg
, &end
);
2949 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2950 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2951 move_gap_both (XFASTINT (beg
), ibeg
);
2953 /* We need to allocate enough room for encoding the text.
2954 We need 33 1/3% more space, plus a newline every 76
2955 characters, and then we round up. */
2956 length
= iend
- ibeg
;
2957 allength
= length
+ length
/3 + 1;
2958 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2960 encoded
= SAFE_ALLOCA (allength
);
2961 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2962 encoded
, length
, NILP (no_line_break
),
2963 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2964 if (encoded_length
> allength
)
2967 if (encoded_length
< 0)
2969 /* The encoding wasn't possible. */
2971 error ("Multibyte character in data for base64 encoding");
2974 /* Now we have encoded the region, so we insert the new contents
2975 and delete the old. (Insert first in order to preserve markers.) */
2976 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2977 insert (encoded
, encoded_length
);
2979 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2981 /* If point was outside of the region, restore it exactly; else just
2982 move to the beginning of the region. */
2983 if (old_pos
>= XFASTINT (end
))
2984 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2985 else if (old_pos
> XFASTINT (beg
))
2986 old_pos
= XFASTINT (beg
);
2989 /* We return the length of the encoded text. */
2990 return make_number (encoded_length
);
2993 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2995 doc
: /* Base64-encode STRING and return the result.
2996 Optional second argument NO-LINE-BREAK means do not break long lines
2997 into shorter lines. */)
2998 (Lisp_Object string
, Lisp_Object no_line_break
)
3000 ptrdiff_t allength
, length
, encoded_length
;
3002 Lisp_Object encoded_string
;
3005 CHECK_STRING (string
);
3007 /* We need to allocate enough room for encoding the text.
3008 We need 33 1/3% more space, plus a newline every 76
3009 characters, and then we round up. */
3010 length
= SBYTES (string
);
3011 allength
= length
+ length
/3 + 1;
3012 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3014 /* We need to allocate enough room for decoding the text. */
3015 encoded
= SAFE_ALLOCA (allength
);
3017 encoded_length
= base64_encode_1 (SSDATA (string
),
3018 encoded
, length
, NILP (no_line_break
),
3019 STRING_MULTIBYTE (string
));
3020 if (encoded_length
> allength
)
3023 if (encoded_length
< 0)
3025 /* The encoding wasn't possible. */
3027 error ("Multibyte character in data for base64 encoding");
3030 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3033 return encoded_string
;
3037 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3038 bool line_break
, bool multibyte
)
3051 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3052 if (CHAR_BYTE8_P (c
))
3053 c
= CHAR_TO_BYTE8 (c
);
3061 /* Wrap line every 76 characters. */
3065 if (counter
< MIME_LINE_LENGTH
/ 4)
3074 /* Process first byte of a triplet. */
3076 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3077 value
= (0x03 & c
) << 4;
3079 /* Process second byte of a triplet. */
3083 *e
++ = base64_value_to_char
[value
];
3091 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3092 if (CHAR_BYTE8_P (c
))
3093 c
= CHAR_TO_BYTE8 (c
);
3101 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3102 value
= (0x0f & c
) << 2;
3104 /* Process third byte of a triplet. */
3108 *e
++ = base64_value_to_char
[value
];
3115 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3116 if (CHAR_BYTE8_P (c
))
3117 c
= CHAR_TO_BYTE8 (c
);
3125 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3126 *e
++ = base64_value_to_char
[0x3f & c
];
3133 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3135 doc
: /* Base64-decode the region between BEG and END.
3136 Return the length of the decoded text.
3137 If the region can't be decoded, signal an error and don't modify the buffer. */)
3138 (Lisp_Object beg
, Lisp_Object end
)
3140 ptrdiff_t ibeg
, iend
, length
, allength
;
3142 ptrdiff_t old_pos
= PT
;
3143 ptrdiff_t decoded_length
;
3144 ptrdiff_t inserted_chars
;
3145 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3148 validate_region (&beg
, &end
);
3150 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3151 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3153 length
= iend
- ibeg
;
3155 /* We need to allocate enough room for decoding the text. If we are
3156 working on a multibyte buffer, each decoded code may occupy at
3158 allength
= multibyte
? length
* 2 : length
;
3159 decoded
= SAFE_ALLOCA (allength
);
3161 move_gap_both (XFASTINT (beg
), ibeg
);
3162 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3164 multibyte
, &inserted_chars
);
3165 if (decoded_length
> allength
)
3168 if (decoded_length
< 0)
3170 /* The decoding wasn't possible. */
3172 error ("Invalid base64 data");
3175 /* Now we have decoded the region, so we insert the new contents
3176 and delete the old. (Insert first in order to preserve markers.) */
3177 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3178 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3181 /* Delete the original text. */
3182 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3183 iend
+ decoded_length
, 1);
3185 /* If point was outside of the region, restore it exactly; else just
3186 move to the beginning of the region. */
3187 if (old_pos
>= XFASTINT (end
))
3188 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3189 else if (old_pos
> XFASTINT (beg
))
3190 old_pos
= XFASTINT (beg
);
3191 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3193 return make_number (inserted_chars
);
3196 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3198 doc
: /* Base64-decode STRING and return the result. */)
3199 (Lisp_Object string
)
3202 ptrdiff_t length
, decoded_length
;
3203 Lisp_Object decoded_string
;
3206 CHECK_STRING (string
);
3208 length
= SBYTES (string
);
3209 /* We need to allocate enough room for decoding the text. */
3210 decoded
= SAFE_ALLOCA (length
);
3212 /* The decoded result should be unibyte. */
3213 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3215 if (decoded_length
> length
)
3217 else if (decoded_length
>= 0)
3218 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3220 decoded_string
= Qnil
;
3223 if (!STRINGP (decoded_string
))
3224 error ("Invalid base64 data");
3226 return decoded_string
;
3229 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3230 MULTIBYTE, the decoded result should be in multibyte
3231 form. If NCHARS_RETURN is not NULL, store the number of produced
3232 characters in *NCHARS_RETURN. */
3235 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3236 bool multibyte
, ptrdiff_t *nchars_return
)
3238 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3241 unsigned long value
;
3242 ptrdiff_t nchars
= 0;
3246 /* Process first byte of a quadruplet. */
3248 READ_QUADRUPLET_BYTE (e
-to
);
3252 value
= base64_char_to_value
[c
] << 18;
3254 /* Process second byte of a quadruplet. */
3256 READ_QUADRUPLET_BYTE (-1);
3260 value
|= base64_char_to_value
[c
] << 12;
3262 c
= (unsigned char) (value
>> 16);
3263 if (multibyte
&& c
>= 128)
3264 e
+= BYTE8_STRING (c
, e
);
3269 /* Process third byte of a quadruplet. */
3271 READ_QUADRUPLET_BYTE (-1);
3275 READ_QUADRUPLET_BYTE (-1);
3284 value
|= base64_char_to_value
[c
] << 6;
3286 c
= (unsigned char) (0xff & value
>> 8);
3287 if (multibyte
&& c
>= 128)
3288 e
+= BYTE8_STRING (c
, e
);
3293 /* Process fourth byte of a quadruplet. */
3295 READ_QUADRUPLET_BYTE (-1);
3302 value
|= base64_char_to_value
[c
];
3304 c
= (unsigned char) (0xff & value
);
3305 if (multibyte
&& c
>= 128)
3306 e
+= BYTE8_STRING (c
, e
);
3315 /***********************************************************************
3317 ***** Hash Tables *****
3319 ***********************************************************************/
3321 /* Implemented by gerd@gnu.org. This hash table implementation was
3322 inspired by CMUCL hash tables. */
3326 1. For small tables, association lists are probably faster than
3327 hash tables because they have lower overhead.
3329 For uses of hash tables where the O(1) behavior of table
3330 operations is not a requirement, it might therefore be a good idea
3331 not to hash. Instead, we could just do a linear search in the
3332 key_and_value vector of the hash table. This could be done
3333 if a `:linear-search t' argument is given to make-hash-table. */
3336 /* The list of all weak hash tables. Don't staticpro this one. */
3338 static struct Lisp_Hash_Table
*weak_hash_tables
;
3340 /* Various symbols. */
3342 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3343 Lisp_Object Qeq
, Qeql
, Qequal
;
3344 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3345 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3347 /* Function prototypes. */
3349 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3350 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3351 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3352 static bool sweep_weak_table (struct Lisp_Hash_Table
*, bool);
3356 /***********************************************************************
3358 ***********************************************************************/
3360 /* If OBJ is a Lisp hash table, return a pointer to its struct
3361 Lisp_Hash_Table. Otherwise, signal an error. */
3363 static struct Lisp_Hash_Table
*
3364 check_hash_table (Lisp_Object obj
)
3366 CHECK_HASH_TABLE (obj
);
3367 return XHASH_TABLE (obj
);
3371 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3372 number. A number is "almost" a prime number if it is not divisible
3373 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3376 next_almost_prime (EMACS_INT n
)
3378 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3379 for (n
|= 1; ; n
+= 2)
3380 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3385 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3386 which USED[I] is non-zero. If found at index I in ARGS, set
3387 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3388 0. This function is used to extract a keyword/argument pair from
3389 a DEFUN parameter list. */
3392 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3396 for (i
= 1; i
< nargs
; i
++)
3397 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3408 /* Return a Lisp vector which has the same contents as VEC but has
3409 at least INCR_MIN more entries, where INCR_MIN is positive.
3410 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3411 than NITEMS_MAX. Entries in the resulting
3412 vector that are not copied from VEC are set to nil. */
3415 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3417 struct Lisp_Vector
*v
;
3418 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3419 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3420 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3421 ? nitems_max
: C_language_max
);
3422 eassert (VECTORP (vec
));
3423 eassert (0 < incr_min
&& -1 <= nitems_max
);
3424 old_size
= ASIZE (vec
);
3425 incr_max
= n_max
- old_size
;
3426 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3427 if (incr_max
< incr
)
3428 memory_full (SIZE_MAX
);
3429 new_size
= old_size
+ incr
;
3430 v
= allocate_vector (new_size
);
3431 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3432 for (i
= old_size
; i
< new_size
; ++i
)
3433 v
->contents
[i
] = Qnil
;
3434 XSETVECTOR (vec
, v
);
3439 /***********************************************************************
3441 ***********************************************************************/
3443 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3444 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3445 KEY2 are the same. */
3448 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3449 Lisp_Object key1
, EMACS_UINT hash1
,
3450 Lisp_Object key2
, EMACS_UINT hash2
)
3452 return (FLOATP (key1
)
3454 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3458 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3459 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3460 KEY2 are the same. */
3463 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3464 Lisp_Object key1
, EMACS_UINT hash1
,
3465 Lisp_Object key2
, EMACS_UINT hash2
)
3467 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3471 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3472 HASH2 in hash table H using H->user_cmp_function. Value is true
3473 if KEY1 and KEY2 are the same. */
3476 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3477 Lisp_Object key1
, EMACS_UINT hash1
,
3478 Lisp_Object key2
, EMACS_UINT hash2
)
3482 Lisp_Object args
[3];
3484 args
[0] = h
->user_cmp_function
;
3487 return !NILP (Ffuncall (3, args
));
3494 /* Value is a hash code for KEY for use in hash table H which uses
3495 `eq' to compare keys. The hash code returned is guaranteed to fit
3496 in a Lisp integer. */
3499 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3501 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3502 eassert ((hash
& ~INTMASK
) == 0);
3507 /* Value is a hash code for KEY for use in hash table H which uses
3508 `eql' to compare keys. The hash code returned is guaranteed to fit
3509 in a Lisp integer. */
3512 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3516 hash
= sxhash (key
, 0);
3518 hash
= XUINT (key
) ^ XTYPE (key
);
3519 eassert ((hash
& ~INTMASK
) == 0);
3524 /* Value is a hash code for KEY for use in hash table H which uses
3525 `equal' to compare keys. The hash code returned is guaranteed to fit
3526 in a Lisp integer. */
3529 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3531 EMACS_UINT hash
= sxhash (key
, 0);
3532 eassert ((hash
& ~INTMASK
) == 0);
3537 /* Value is a hash code for KEY for use in hash table H which uses as
3538 user-defined function to compare keys. The hash code returned is
3539 guaranteed to fit in a Lisp integer. */
3542 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3544 Lisp_Object args
[2], hash
;
3546 args
[0] = h
->user_hash_function
;
3548 hash
= Ffuncall (2, args
);
3549 if (!INTEGERP (hash
))
3550 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3551 return XUINT (hash
);
3554 /* An upper bound on the size of a hash table index. It must fit in
3555 ptrdiff_t and be a valid Emacs fixnum. */
3556 #define INDEX_SIZE_BOUND \
3557 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3559 /* Create and initialize a new hash table.
3561 TEST specifies the test the hash table will use to compare keys.
3562 It must be either one of the predefined tests `eq', `eql' or
3563 `equal' or a symbol denoting a user-defined test named TEST with
3564 test and hash functions USER_TEST and USER_HASH.
3566 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3568 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3569 new size when it becomes full is computed by adding REHASH_SIZE to
3570 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3571 table's new size is computed by multiplying its old size with
3574 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3575 be resized when the ratio of (number of entries in the table) /
3576 (table size) is >= REHASH_THRESHOLD.
3578 WEAK specifies the weakness of the table. If non-nil, it must be
3579 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3582 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3583 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3584 Lisp_Object user_test
, Lisp_Object user_hash
)
3586 struct Lisp_Hash_Table
*h
;
3588 EMACS_INT index_size
, sz
;
3592 /* Preconditions. */
3593 eassert (SYMBOLP (test
));
3594 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3595 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3596 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3597 eassert (FLOATP (rehash_threshold
)
3598 && 0 < XFLOAT_DATA (rehash_threshold
)
3599 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3601 if (XFASTINT (size
) == 0)
3602 size
= make_number (1);
3604 sz
= XFASTINT (size
);
3605 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3606 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3607 ? next_almost_prime (index_float
)
3608 : INDEX_SIZE_BOUND
+ 1);
3609 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3610 error ("Hash table too large");
3612 /* Allocate a table and initialize it. */
3613 h
= allocate_hash_table ();
3615 /* Initialize hash table slots. */
3617 if (EQ (test
, Qeql
))
3619 h
->cmpfn
= cmpfn_eql
;
3620 h
->hashfn
= hashfn_eql
;
3622 else if (EQ (test
, Qeq
))
3625 h
->hashfn
= hashfn_eq
;
3627 else if (EQ (test
, Qequal
))
3629 h
->cmpfn
= cmpfn_equal
;
3630 h
->hashfn
= hashfn_equal
;
3634 h
->user_cmp_function
= user_test
;
3635 h
->user_hash_function
= user_hash
;
3636 h
->cmpfn
= cmpfn_user_defined
;
3637 h
->hashfn
= hashfn_user_defined
;
3641 h
->rehash_threshold
= rehash_threshold
;
3642 h
->rehash_size
= rehash_size
;
3644 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3645 h
->hash
= Fmake_vector (size
, Qnil
);
3646 h
->next
= Fmake_vector (size
, Qnil
);
3647 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3649 /* Set up the free list. */
3650 for (i
= 0; i
< sz
- 1; ++i
)
3651 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3652 h
->next_free
= make_number (0);
3654 XSET_HASH_TABLE (table
, h
);
3655 eassert (HASH_TABLE_P (table
));
3656 eassert (XHASH_TABLE (table
) == h
);
3658 /* Maybe add this hash table to the list of all weak hash tables. */
3660 h
->next_weak
= NULL
;
3663 h
->next_weak
= weak_hash_tables
;
3664 weak_hash_tables
= h
;
3671 /* Return a copy of hash table H1. Keys and values are not copied,
3672 only the table itself is. */
3675 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3678 struct Lisp_Hash_Table
*h2
;
3679 struct Lisp_Vector
*next
;
3681 h2
= allocate_hash_table ();
3682 next
= h2
->header
.next
.vector
;
3684 h2
->header
.next
.vector
= next
;
3685 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3686 h2
->hash
= Fcopy_sequence (h1
->hash
);
3687 h2
->next
= Fcopy_sequence (h1
->next
);
3688 h2
->index
= Fcopy_sequence (h1
->index
);
3689 XSET_HASH_TABLE (table
, h2
);
3691 /* Maybe add this hash table to the list of all weak hash tables. */
3692 if (!NILP (h2
->weak
))
3694 h2
->next_weak
= weak_hash_tables
;
3695 weak_hash_tables
= h2
;
3702 /* Resize hash table H if it's too full. If H cannot be resized
3703 because it's already too large, throw an error. */
3706 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3708 if (NILP (h
->next_free
))
3710 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3711 EMACS_INT new_size
, index_size
, nsize
;
3715 if (INTEGERP (h
->rehash_size
))
3716 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3719 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3720 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3722 new_size
= float_new_size
;
3723 if (new_size
<= old_size
)
3724 new_size
= old_size
+ 1;
3727 new_size
= INDEX_SIZE_BOUND
+ 1;
3729 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3730 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3731 ? next_almost_prime (index_float
)
3732 : INDEX_SIZE_BOUND
+ 1);
3733 nsize
= max (index_size
, 2 * new_size
);
3734 if (INDEX_SIZE_BOUND
< nsize
)
3735 error ("Hash table too large to resize");
3737 #ifdef ENABLE_CHECKING
3738 if (HASH_TABLE_P (Vpurify_flag
)
3739 && XHASH_TABLE (Vpurify_flag
) == h
)
3741 Lisp_Object args
[2];
3742 args
[0] = build_string ("Growing hash table to: %d");
3743 args
[1] = make_number (new_size
);
3748 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3749 2 * (new_size
- old_size
), -1));
3750 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3751 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3752 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3754 /* Update the free list. Do it so that new entries are added at
3755 the end of the free list. This makes some operations like
3757 for (i
= old_size
; i
< new_size
- 1; ++i
)
3758 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3760 if (!NILP (h
->next_free
))
3762 Lisp_Object last
, next
;
3764 last
= h
->next_free
;
3765 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3769 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3772 XSETFASTINT (h
->next_free
, old_size
);
3775 for (i
= 0; i
< old_size
; ++i
)
3776 if (!NILP (HASH_HASH (h
, i
)))
3778 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3779 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3780 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3781 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3787 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3788 the hash code of KEY. Value is the index of the entry in H
3789 matching KEY, or -1 if not found. */
3792 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3794 EMACS_UINT hash_code
;
3795 ptrdiff_t start_of_bucket
;
3798 hash_code
= h
->hashfn (h
, key
);
3802 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3803 idx
= HASH_INDEX (h
, start_of_bucket
);
3805 /* We need not gcpro idx since it's either an integer or nil. */
3808 ptrdiff_t i
= XFASTINT (idx
);
3809 if (EQ (key
, HASH_KEY (h
, i
))
3811 && h
->cmpfn (h
, key
, hash_code
,
3812 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3814 idx
= HASH_NEXT (h
, i
);
3817 return NILP (idx
) ? -1 : XFASTINT (idx
);
3821 /* Put an entry into hash table H that associates KEY with VALUE.
3822 HASH is a previously computed hash code of KEY.
3823 Value is the index of the entry in H matching KEY. */
3826 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3829 ptrdiff_t start_of_bucket
, i
;
3831 eassert ((hash
& ~INTMASK
) == 0);
3833 /* Increment count after resizing because resizing may fail. */
3834 maybe_resize_hash_table (h
);
3837 /* Store key/value in the key_and_value vector. */
3838 i
= XFASTINT (h
->next_free
);
3839 h
->next_free
= HASH_NEXT (h
, i
);
3840 set_hash_key_slot (h
, i
, key
);
3841 set_hash_value_slot (h
, i
, value
);
3843 /* Remember its hash code. */
3844 set_hash_hash_slot (h
, i
, make_number (hash
));
3846 /* Add new entry to its collision chain. */
3847 start_of_bucket
= hash
% ASIZE (h
->index
);
3848 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3849 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3854 /* Remove the entry matching KEY from hash table H, if there is one. */
3857 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3859 EMACS_UINT hash_code
;
3860 ptrdiff_t start_of_bucket
;
3861 Lisp_Object idx
, prev
;
3863 hash_code
= h
->hashfn (h
, key
);
3864 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3865 idx
= HASH_INDEX (h
, start_of_bucket
);
3868 /* We need not gcpro idx, prev since they're either integers or nil. */
3871 ptrdiff_t i
= XFASTINT (idx
);
3873 if (EQ (key
, HASH_KEY (h
, i
))
3875 && h
->cmpfn (h
, key
, hash_code
,
3876 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3878 /* Take entry out of collision chain. */
3880 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3882 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3884 /* Clear slots in key_and_value and add the slots to
3886 set_hash_key_slot (h
, i
, Qnil
);
3887 set_hash_value_slot (h
, i
, Qnil
);
3888 set_hash_hash_slot (h
, i
, Qnil
);
3889 set_hash_next_slot (h
, i
, h
->next_free
);
3890 h
->next_free
= make_number (i
);
3892 eassert (h
->count
>= 0);
3898 idx
= HASH_NEXT (h
, i
);
3904 /* Clear hash table H. */
3907 hash_clear (struct Lisp_Hash_Table
*h
)
3911 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3913 for (i
= 0; i
< size
; ++i
)
3915 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3916 set_hash_key_slot (h
, i
, Qnil
);
3917 set_hash_value_slot (h
, i
, Qnil
);
3918 set_hash_hash_slot (h
, i
, Qnil
);
3921 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3922 ASET (h
->index
, i
, Qnil
);
3924 h
->next_free
= make_number (0);
3931 /************************************************************************
3933 ************************************************************************/
3935 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3936 entries from the table that don't survive the current GC.
3937 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3938 true if anything was marked. */
3941 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3943 ptrdiff_t bucket
, n
;
3946 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3949 for (bucket
= 0; bucket
< n
; ++bucket
)
3951 Lisp_Object idx
, next
, prev
;
3953 /* Follow collision chain, removing entries that
3954 don't survive this garbage collection. */
3956 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3958 ptrdiff_t i
= XFASTINT (idx
);
3959 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3960 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3963 if (EQ (h
->weak
, Qkey
))
3964 remove_p
= !key_known_to_survive_p
;
3965 else if (EQ (h
->weak
, Qvalue
))
3966 remove_p
= !value_known_to_survive_p
;
3967 else if (EQ (h
->weak
, Qkey_or_value
))
3968 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3969 else if (EQ (h
->weak
, Qkey_and_value
))
3970 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3974 next
= HASH_NEXT (h
, i
);
3976 if (remove_entries_p
)
3980 /* Take out of collision chain. */
3982 set_hash_index_slot (h
, bucket
, next
);
3984 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3986 /* Add to free list. */
3987 set_hash_next_slot (h
, i
, h
->next_free
);
3990 /* Clear key, value, and hash. */
3991 set_hash_key_slot (h
, i
, Qnil
);
3992 set_hash_value_slot (h
, i
, Qnil
);
3993 set_hash_hash_slot (h
, i
, Qnil
);
4006 /* Make sure key and value survive. */
4007 if (!key_known_to_survive_p
)
4009 mark_object (HASH_KEY (h
, i
));
4013 if (!value_known_to_survive_p
)
4015 mark_object (HASH_VALUE (h
, i
));
4026 /* Remove elements from weak hash tables that don't survive the
4027 current garbage collection. Remove weak tables that don't survive
4028 from Vweak_hash_tables. Called from gc_sweep. */
4031 sweep_weak_hash_tables (void)
4033 struct Lisp_Hash_Table
*h
, *used
, *next
;
4036 /* Mark all keys and values that are in use. Keep on marking until
4037 there is no more change. This is necessary for cases like
4038 value-weak table A containing an entry X -> Y, where Y is used in a
4039 key-weak table B, Z -> Y. If B comes after A in the list of weak
4040 tables, X -> Y might be removed from A, although when looking at B
4041 one finds that it shouldn't. */
4045 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4047 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4048 marked
|= sweep_weak_table (h
, 0);
4053 /* Remove tables and entries that aren't used. */
4054 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4056 next
= h
->next_weak
;
4058 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4060 /* TABLE is marked as used. Sweep its contents. */
4062 sweep_weak_table (h
, 1);
4064 /* Add table to the list of used weak hash tables. */
4065 h
->next_weak
= used
;
4070 weak_hash_tables
= used
;
4075 /***********************************************************************
4076 Hash Code Computation
4077 ***********************************************************************/
4079 /* Maximum depth up to which to dive into Lisp structures. */
4081 #define SXHASH_MAX_DEPTH 3
4083 /* Maximum length up to which to take list and vector elements into
4086 #define SXHASH_MAX_LEN 7
4088 /* Combine two integers X and Y for hashing. The result might not fit
4089 into a Lisp integer. */
4091 #define SXHASH_COMBINE(X, Y) \
4092 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4095 /* Hash X, returning a value that fits into a Lisp integer. */
4096 #define SXHASH_REDUCE(X) \
4097 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4099 /* Return a hash for string PTR which has length LEN. The hash value
4100 can be any EMACS_UINT value. */
4103 hash_string (char const *ptr
, ptrdiff_t len
)
4105 char const *p
= ptr
;
4106 char const *end
= p
+ len
;
4108 EMACS_UINT hash
= 0;
4113 hash
= SXHASH_COMBINE (hash
, c
);
4119 /* Return a hash for string PTR which has length LEN. The hash
4120 code returned is guaranteed to fit in a Lisp integer. */
4123 sxhash_string (char const *ptr
, ptrdiff_t len
)
4125 EMACS_UINT hash
= hash_string (ptr
, len
);
4126 return SXHASH_REDUCE (hash
);
4129 /* Return a hash for the floating point value VAL. */
4132 sxhash_float (double val
)
4134 EMACS_UINT hash
= 0;
4136 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4137 + (sizeof val
% sizeof hash
!= 0))
4141 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4145 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4146 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4147 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4148 return SXHASH_REDUCE (hash
);
4151 /* Return a hash for list LIST. DEPTH is the current depth in the
4152 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4155 sxhash_list (Lisp_Object list
, int depth
)
4157 EMACS_UINT hash
= 0;
4160 if (depth
< SXHASH_MAX_DEPTH
)
4162 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4163 list
= XCDR (list
), ++i
)
4165 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4166 hash
= SXHASH_COMBINE (hash
, hash2
);
4171 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4172 hash
= SXHASH_COMBINE (hash
, hash2
);
4175 return SXHASH_REDUCE (hash
);
4179 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4180 the Lisp structure. */
4183 sxhash_vector (Lisp_Object vec
, int depth
)
4185 EMACS_UINT hash
= ASIZE (vec
);
4188 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4189 for (i
= 0; i
< n
; ++i
)
4191 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4192 hash
= SXHASH_COMBINE (hash
, hash2
);
4195 return SXHASH_REDUCE (hash
);
4198 /* Return a hash for bool-vector VECTOR. */
4201 sxhash_bool_vector (Lisp_Object vec
)
4203 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4206 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4207 for (i
= 0; i
< n
; ++i
)
4208 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[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 Lisp_Object user_test
, user_hash
;
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
;
4337 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4339 /* See if it is a user-defined test. */
4342 prop
= Fget (test
, Qhash_table_test
);
4343 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4344 signal_error ("Invalid hash table test", test
);
4345 user_test
= XCAR (prop
);
4346 user_hash
= XCAR (XCDR (prop
));
4349 user_test
= user_hash
= Qnil
;
4351 /* See if there's a `:size SIZE' argument. */
4352 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4353 size
= i
? args
[i
] : Qnil
;
4355 size
= make_number (DEFAULT_HASH_SIZE
);
4356 else if (!INTEGERP (size
) || XINT (size
) < 0)
4357 signal_error ("Invalid hash table size", size
);
4359 /* Look for `:rehash-size SIZE'. */
4360 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4361 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4362 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4363 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4364 signal_error ("Invalid hash table rehash size", rehash_size
);
4366 /* Look for `:rehash-threshold THRESHOLD'. */
4367 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4368 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4369 if (! (FLOATP (rehash_threshold
)
4370 && 0 < XFLOAT_DATA (rehash_threshold
)
4371 && XFLOAT_DATA (rehash_threshold
) <= 1))
4372 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4374 /* Look for `:weakness WEAK'. */
4375 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4376 weak
= i
? args
[i
] : Qnil
;
4378 weak
= Qkey_and_value
;
4381 && !EQ (weak
, Qvalue
)
4382 && !EQ (weak
, Qkey_or_value
)
4383 && !EQ (weak
, Qkey_and_value
))
4384 signal_error ("Invalid hash table weakness", weak
);
4386 /* Now, all args should have been used up, or there's a problem. */
4387 for (i
= 0; i
< nargs
; ++i
)
4389 signal_error ("Invalid argument list", args
[i
]);
4391 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4392 user_test
, user_hash
);
4396 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4397 doc
: /* Return a copy of hash table TABLE. */)
4400 return copy_hash_table (check_hash_table (table
));
4404 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4405 doc
: /* Return the number of elements in TABLE. */)
4408 return make_number (check_hash_table (table
)->count
);
4412 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4413 Shash_table_rehash_size
, 1, 1, 0,
4414 doc
: /* Return the current rehash size of TABLE. */)
4417 return check_hash_table (table
)->rehash_size
;
4421 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4422 Shash_table_rehash_threshold
, 1, 1, 0,
4423 doc
: /* Return the current rehash threshold of TABLE. */)
4426 return check_hash_table (table
)->rehash_threshold
;
4430 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4431 doc
: /* Return the size of TABLE.
4432 The size can be used as an argument to `make-hash-table' to create
4433 a hash table than can hold as many elements as TABLE holds
4434 without need for resizing. */)
4437 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4438 return make_number (HASH_TABLE_SIZE (h
));
4442 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4443 doc
: /* Return the test TABLE uses. */)
4446 return check_hash_table (table
)->test
;
4450 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4452 doc
: /* Return the weakness of TABLE. */)
4455 return check_hash_table (table
)->weak
;
4459 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4460 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4463 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4467 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4468 doc
: /* Clear hash table TABLE and return it. */)
4471 hash_clear (check_hash_table (table
));
4472 /* Be compatible with XEmacs. */
4477 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4478 doc
: /* Look up KEY in TABLE and return its associated value.
4479 If KEY is not found, return DFLT which defaults to nil. */)
4480 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4482 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4483 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4484 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4488 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4489 doc
: /* Associate KEY with VALUE in hash table TABLE.
4490 If KEY is already present in table, replace its current value with
4491 VALUE. In any case, return VALUE. */)
4492 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4494 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4498 i
= hash_lookup (h
, key
, &hash
);
4500 set_hash_value_slot (h
, i
, value
);
4502 hash_put (h
, key
, value
, hash
);
4508 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4509 doc
: /* Remove KEY from TABLE. */)
4510 (Lisp_Object key
, Lisp_Object table
)
4512 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4513 hash_remove_from_table (h
, key
);
4518 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4519 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4520 FUNCTION is called with two arguments, KEY and VALUE. */)
4521 (Lisp_Object function
, Lisp_Object table
)
4523 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4524 Lisp_Object args
[3];
4527 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4528 if (!NILP (HASH_HASH (h
, i
)))
4531 args
[1] = HASH_KEY (h
, i
);
4532 args
[2] = HASH_VALUE (h
, i
);
4540 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4541 Sdefine_hash_table_test
, 3, 3, 0,
4542 doc
: /* Define a new hash table test with name NAME, a symbol.
4544 In hash tables created with NAME specified as test, use TEST to
4545 compare keys, and HASH for computing hash codes of keys.
4547 TEST must be a function taking two arguments and returning non-nil if
4548 both arguments are the same. HASH must be a function taking one
4549 argument and return an integer that is the hash code of the argument.
4550 Hash code computation should use the whole value range of integers,
4551 including negative integers. */)
4552 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4554 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4559 /************************************************************************
4560 MD5, SHA-1, and SHA-2
4561 ************************************************************************/
4568 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4571 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4575 EMACS_INT start_char
= 0, end_char
= 0;
4576 ptrdiff_t start_byte
, end_byte
;
4577 register EMACS_INT b
, e
;
4578 register struct buffer
*bp
;
4581 void *(*hash_func
) (const char *, size_t, void *);
4584 CHECK_SYMBOL (algorithm
);
4586 if (STRINGP (object
))
4588 if (NILP (coding_system
))
4590 /* Decide the coding-system to encode the data with. */
4592 if (STRING_MULTIBYTE (object
))
4593 /* use default, we can't guess correct value */
4594 coding_system
= preferred_coding_system ();
4596 coding_system
= Qraw_text
;
4599 if (NILP (Fcoding_system_p (coding_system
)))
4601 /* Invalid coding system. */
4603 if (!NILP (noerror
))
4604 coding_system
= Qraw_text
;
4606 xsignal1 (Qcoding_system_error
, coding_system
);
4609 if (STRING_MULTIBYTE (object
))
4610 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4612 size
= SCHARS (object
);
4616 CHECK_NUMBER (start
);
4618 start_char
= XINT (start
);
4630 end_char
= XINT (end
);
4636 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4637 args_out_of_range_3 (object
, make_number (start_char
),
4638 make_number (end_char
));
4640 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4642 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4646 struct buffer
*prev
= current_buffer
;
4648 record_unwind_current_buffer ();
4650 CHECK_BUFFER (object
);
4652 bp
= XBUFFER (object
);
4653 set_buffer_internal (bp
);
4659 CHECK_NUMBER_COERCE_MARKER (start
);
4667 CHECK_NUMBER_COERCE_MARKER (end
);
4672 temp
= b
, b
= e
, e
= temp
;
4674 if (!(BEGV
<= b
&& e
<= ZV
))
4675 args_out_of_range (start
, end
);
4677 if (NILP (coding_system
))
4679 /* Decide the coding-system to encode the data with.
4680 See fileio.c:Fwrite-region */
4682 if (!NILP (Vcoding_system_for_write
))
4683 coding_system
= Vcoding_system_for_write
;
4686 bool force_raw_text
= 0;
4688 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4689 if (NILP (coding_system
)
4690 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4692 coding_system
= Qnil
;
4693 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4697 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4699 /* Check file-coding-system-alist. */
4700 Lisp_Object args
[4], val
;
4702 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4703 args
[3] = Fbuffer_file_name (object
);
4704 val
= Ffind_operation_coding_system (4, args
);
4705 if (CONSP (val
) && !NILP (XCDR (val
)))
4706 coding_system
= XCDR (val
);
4709 if (NILP (coding_system
)
4710 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4712 /* If we still have not decided a coding system, use the
4713 default value of buffer-file-coding-system. */
4714 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4718 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4719 /* Confirm that VAL can surely encode the current region. */
4720 coding_system
= call4 (Vselect_safe_coding_system_function
,
4721 make_number (b
), make_number (e
),
4722 coding_system
, Qnil
);
4725 coding_system
= Qraw_text
;
4728 if (NILP (Fcoding_system_p (coding_system
)))
4730 /* Invalid coding system. */
4732 if (!NILP (noerror
))
4733 coding_system
= Qraw_text
;
4735 xsignal1 (Qcoding_system_error
, coding_system
);
4739 object
= make_buffer_string (b
, e
, 0);
4740 set_buffer_internal (prev
);
4741 /* Discard the unwind protect for recovering the current
4745 if (STRING_MULTIBYTE (object
))
4746 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4748 end_byte
= SBYTES (object
);
4751 if (EQ (algorithm
, Qmd5
))
4753 digest_size
= MD5_DIGEST_SIZE
;
4754 hash_func
= md5_buffer
;
4756 else if (EQ (algorithm
, Qsha1
))
4758 digest_size
= SHA1_DIGEST_SIZE
;
4759 hash_func
= sha1_buffer
;
4761 else if (EQ (algorithm
, Qsha224
))
4763 digest_size
= SHA224_DIGEST_SIZE
;
4764 hash_func
= sha224_buffer
;
4766 else if (EQ (algorithm
, Qsha256
))
4768 digest_size
= SHA256_DIGEST_SIZE
;
4769 hash_func
= sha256_buffer
;
4771 else if (EQ (algorithm
, Qsha384
))
4773 digest_size
= SHA384_DIGEST_SIZE
;
4774 hash_func
= sha384_buffer
;
4776 else if (EQ (algorithm
, Qsha512
))
4778 digest_size
= SHA512_DIGEST_SIZE
;
4779 hash_func
= sha512_buffer
;
4782 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4784 /* allocate 2 x digest_size so that it can be re-used to hold the
4786 digest
= make_uninit_string (digest_size
* 2);
4788 hash_func (SSDATA (object
) + start_byte
,
4789 end_byte
- start_byte
,
4794 unsigned char *p
= SDATA (digest
);
4795 for (i
= digest_size
- 1; i
>= 0; i
--)
4797 static char const hexdigit
[16] = "0123456789abcdef";
4799 p
[2 * i
] = hexdigit
[p_i
>> 4];
4800 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4805 return make_unibyte_string (SSDATA (digest
), digest_size
);
4808 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4809 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4811 A message digest is a cryptographic checksum of a document, and the
4812 algorithm to calculate it is defined in RFC 1321.
4814 The two optional arguments START and END are character positions
4815 specifying for which part of OBJECT the message digest should be
4816 computed. If nil or omitted, the digest is computed for the whole
4819 The MD5 message digest is computed from the result of encoding the
4820 text in a coding system, not directly from the internal Emacs form of
4821 the text. The optional fourth argument CODING-SYSTEM specifies which
4822 coding system to encode the text with. It should be the same coding
4823 system that you used or will use when actually writing the text into a
4826 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4827 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4828 system would be chosen by default for writing this text into a file.
4830 If OBJECT is a string, the most preferred coding system (see the
4831 command `prefer-coding-system') is used.
4833 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4834 guesswork fails. Normally, an error is signaled in such case. */)
4835 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4837 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4840 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4841 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4842 ALGORITHM is a symbol specifying the hash to use:
4843 md5, sha1, sha224, sha256, sha384 or sha512.
4845 The two optional arguments START and END are positions specifying for
4846 which part of OBJECT to compute the hash. If nil or omitted, uses the
4849 If BINARY is non-nil, returns a string in binary form. */)
4850 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4852 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4858 DEFSYM (Qmd5
, "md5");
4859 DEFSYM (Qsha1
, "sha1");
4860 DEFSYM (Qsha224
, "sha224");
4861 DEFSYM (Qsha256
, "sha256");
4862 DEFSYM (Qsha384
, "sha384");
4863 DEFSYM (Qsha512
, "sha512");
4865 /* Hash table stuff. */
4866 DEFSYM (Qhash_table_p
, "hash-table-p");
4868 DEFSYM (Qeql
, "eql");
4869 DEFSYM (Qequal
, "equal");
4870 DEFSYM (QCtest
, ":test");
4871 DEFSYM (QCsize
, ":size");
4872 DEFSYM (QCrehash_size
, ":rehash-size");
4873 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4874 DEFSYM (QCweakness
, ":weakness");
4875 DEFSYM (Qkey
, "key");
4876 DEFSYM (Qvalue
, "value");
4877 DEFSYM (Qhash_table_test
, "hash-table-test");
4878 DEFSYM (Qkey_or_value
, "key-or-value");
4879 DEFSYM (Qkey_and_value
, "key-and-value");
4882 defsubr (&Smake_hash_table
);
4883 defsubr (&Scopy_hash_table
);
4884 defsubr (&Shash_table_count
);
4885 defsubr (&Shash_table_rehash_size
);
4886 defsubr (&Shash_table_rehash_threshold
);
4887 defsubr (&Shash_table_size
);
4888 defsubr (&Shash_table_test
);
4889 defsubr (&Shash_table_weakness
);
4890 defsubr (&Shash_table_p
);
4891 defsubr (&Sclrhash
);
4892 defsubr (&Sgethash
);
4893 defsubr (&Sputhash
);
4894 defsubr (&Sremhash
);
4895 defsubr (&Smaphash
);
4896 defsubr (&Sdefine_hash_table_test
);
4898 DEFSYM (Qstring_lessp
, "string-lessp");
4899 DEFSYM (Qprovide
, "provide");
4900 DEFSYM (Qrequire
, "require");
4901 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4902 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4903 DEFSYM (Qwidget_type
, "widget-type");
4905 staticpro (&string_char_byte_cache_string
);
4906 string_char_byte_cache_string
= Qnil
;
4908 require_nesting_list
= Qnil
;
4909 staticpro (&require_nesting_list
);
4911 Fset (Qyes_or_no_p_history
, Qnil
);
4913 DEFVAR_LISP ("features", Vfeatures
,
4914 doc
: /* A list of symbols which are the features of the executing Emacs.
4915 Used by `featurep' and `require', and altered by `provide'. */);
4916 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4917 DEFSYM (Qsubfeatures
, "subfeatures");
4919 #ifdef HAVE_LANGINFO_CODESET
4920 DEFSYM (Qcodeset
, "codeset");
4921 DEFSYM (Qdays
, "days");
4922 DEFSYM (Qmonths
, "months");
4923 DEFSYM (Qpaper
, "paper");
4924 #endif /* HAVE_LANGINFO_CODESET */
4926 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4927 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4928 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4929 invoked by mouse clicks and mouse menu items.
4931 On some platforms, file selection dialogs are also enabled if this is
4935 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4936 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4937 This applies to commands from menus and tool bar buttons even when
4938 they are initiated from the keyboard. If `use-dialog-box' is nil,
4939 that disables the use of a file dialog, regardless of the value of
4941 use_file_dialog
= 1;
4943 defsubr (&Sidentity
);
4946 defsubr (&Ssafe_length
);
4947 defsubr (&Sstring_bytes
);
4948 defsubr (&Sstring_equal
);
4949 defsubr (&Scompare_strings
);
4950 defsubr (&Sstring_lessp
);
4953 defsubr (&Svconcat
);
4954 defsubr (&Scopy_sequence
);
4955 defsubr (&Sstring_make_multibyte
);
4956 defsubr (&Sstring_make_unibyte
);
4957 defsubr (&Sstring_as_multibyte
);
4958 defsubr (&Sstring_as_unibyte
);
4959 defsubr (&Sstring_to_multibyte
);
4960 defsubr (&Sstring_to_unibyte
);
4961 defsubr (&Scopy_alist
);
4962 defsubr (&Ssubstring
);
4963 defsubr (&Ssubstring_no_properties
);
4976 defsubr (&Snreverse
);
4977 defsubr (&Sreverse
);
4979 defsubr (&Splist_get
);
4981 defsubr (&Splist_put
);
4983 defsubr (&Slax_plist_get
);
4984 defsubr (&Slax_plist_put
);
4987 defsubr (&Sequal_including_properties
);
4988 defsubr (&Sfillarray
);
4989 defsubr (&Sclear_string
);
4993 defsubr (&Smapconcat
);
4994 defsubr (&Syes_or_no_p
);
4995 defsubr (&Sload_average
);
4996 defsubr (&Sfeaturep
);
4997 defsubr (&Srequire
);
4998 defsubr (&Sprovide
);
4999 defsubr (&Splist_member
);
5000 defsubr (&Swidget_put
);
5001 defsubr (&Swidget_get
);
5002 defsubr (&Swidget_apply
);
5003 defsubr (&Sbase64_encode_region
);
5004 defsubr (&Sbase64_decode_region
);
5005 defsubr (&Sbase64_encode_string
);
5006 defsubr (&Sbase64_decode_string
);
5008 defsubr (&Ssecure_hash
);
5009 defsubr (&Slocale_info
);