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/>. */
29 #include "character.h"
34 #include "intervals.h"
37 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
42 #endif /* HAVE_MENUS */
44 Lisp_Object Qstring_lessp
;
45 static Lisp_Object Qprovide
, Qrequire
;
46 static Lisp_Object Qyes_or_no_p_history
;
47 Lisp_Object Qcursor_in_echo_area
;
48 static Lisp_Object Qwidget_type
;
49 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
51 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
53 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool);
55 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
56 doc
: /* Return the argument unchanged. */)
62 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
63 doc
: /* Return a pseudo-random number.
64 All integers representable in Lisp, i.e. between `most-negative-fixnum'
65 and `most-positive-fixnum', inclusive, are equally likely.
67 With positive integer LIMIT, return random number in interval [0,LIMIT).
68 With argument t, set the random number seed from the current time and pid.
69 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 The arguments START1, END1, START2, and END2, if non-nil, are
215 positions specifying which parts of STR1 or STR2 to compare. In
216 string STR1, compare the part between START1 (inclusive) and END1
217 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
218 the string; if END1 is nil, it defaults to the length of the string.
219 Likewise, in string STR2, compare the part between START2 and END2.
221 The strings are compared by the numeric values of their characters.
222 For instance, STR1 is "less than" STR2 if its first differing
223 character has a smaller numeric value. If IGNORE-CASE is non-nil,
224 characters are converted to lower-case before comparing them. Unibyte
225 strings are converted to multibyte for comparison.
227 The value is t if the strings (or specified portions) match.
228 If string STR1 is less, the value is a negative number N;
229 - 1 - N is the number of characters that match at the beginning.
230 If string STR1 is greater, the value is a positive number N;
231 N - 1 is the number of characters that match at the beginning. */)
232 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
234 register ptrdiff_t end1_char
, end2_char
;
235 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
240 start1
= make_number (0);
242 start2
= make_number (0);
243 CHECK_NATNUM (start1
);
244 CHECK_NATNUM (start2
);
250 end1_char
= SCHARS (str1
);
251 if (! NILP (end1
) && end1_char
> XINT (end1
))
252 end1_char
= XINT (end1
);
253 if (end1_char
< XINT (start1
))
254 args_out_of_range (str1
, start1
);
256 end2_char
= SCHARS (str2
);
257 if (! NILP (end2
) && end2_char
> XINT (end2
))
258 end2_char
= XINT (end2
);
259 if (end2_char
< XINT (start2
))
260 args_out_of_range (str2
, start2
);
265 i1_byte
= string_char_to_byte (str1
, i1
);
266 i2_byte
= string_char_to_byte (str2
, i2
);
268 while (i1
< end1_char
&& i2
< end2_char
)
270 /* When we find a mismatch, we must compare the
271 characters, not just the bytes. */
274 if (STRING_MULTIBYTE (str1
))
275 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
278 c1
= SREF (str1
, i1
++);
279 MAKE_CHAR_MULTIBYTE (c1
);
282 if (STRING_MULTIBYTE (str2
))
283 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
286 c2
= SREF (str2
, i2
++);
287 MAKE_CHAR_MULTIBYTE (c2
);
293 if (! NILP (ignore_case
))
297 tem
= Fupcase (make_number (c1
));
299 tem
= Fupcase (make_number (c2
));
306 /* Note that I1 has already been incremented
307 past the character that we are comparing;
308 hence we don't add or subtract 1 here. */
310 return make_number (- i1
+ XINT (start1
));
312 return make_number (i1
- XINT (start1
));
316 return make_number (i1
- XINT (start1
) + 1);
318 return make_number (- i1
+ XINT (start1
) - 1);
323 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
324 doc
: /* Return t if first arg string is less than second in lexicographic order.
326 Symbols are also allowed; their print names are used instead. */)
327 (register Lisp_Object s1
, Lisp_Object s2
)
329 register ptrdiff_t end
;
330 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
333 s1
= SYMBOL_NAME (s1
);
335 s2
= SYMBOL_NAME (s2
);
339 i1
= i1_byte
= i2
= i2_byte
= 0;
342 if (end
> SCHARS (s2
))
347 /* When we find a mismatch, we must compare the
348 characters, not just the bytes. */
351 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
352 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
355 return c1
< c2
? Qt
: Qnil
;
357 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
360 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
361 enum Lisp_Type target_type
, bool last_special
);
365 concat2 (Lisp_Object s1
, Lisp_Object s2
)
370 return concat (2, args
, Lisp_String
, 0);
375 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
381 return concat (3, args
, Lisp_String
, 0);
384 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
385 doc
: /* Concatenate all the arguments and make the result a list.
386 The result is a list whose elements are the elements of all the arguments.
387 Each argument may be a list, vector or string.
388 The last argument is not copied, just used as the tail of the new list.
389 usage: (append &rest SEQUENCES) */)
390 (ptrdiff_t nargs
, Lisp_Object
*args
)
392 return concat (nargs
, args
, Lisp_Cons
, 1);
395 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
396 doc
: /* Concatenate all the arguments and make the result a string.
397 The result is a string whose elements are the elements of all the arguments.
398 Each argument may be a string or a list or vector of characters (integers).
399 usage: (concat &rest SEQUENCES) */)
400 (ptrdiff_t nargs
, Lisp_Object
*args
)
402 return concat (nargs
, args
, Lisp_String
, 0);
405 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
406 doc
: /* Concatenate all the arguments and make the result a vector.
407 The result is a vector whose elements are the elements of all the arguments.
408 Each argument may be a list, vector or string.
409 usage: (vconcat &rest SEQUENCES) */)
410 (ptrdiff_t nargs
, Lisp_Object
*args
)
412 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
416 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
417 doc
: /* Return a copy of a list, vector, string or char-table.
418 The elements of a list or vector are not copied; they are shared
419 with the original. */)
422 if (NILP (arg
)) return arg
;
424 if (CHAR_TABLE_P (arg
))
426 return copy_char_table (arg
);
429 if (BOOL_VECTOR_P (arg
))
432 ptrdiff_t size_in_chars
433 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
434 / BOOL_VECTOR_BITS_PER_CHAR
);
436 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
437 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
442 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
443 wrong_type_argument (Qsequencep
, arg
);
445 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
448 /* This structure holds information of an argument of `concat' that is
449 a string and has text properties to be copied. */
452 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
453 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
454 ptrdiff_t to
; /* refer to VAL (the target string) */
458 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
459 enum Lisp_Type target_type
, bool last_special
)
465 ptrdiff_t toindex_byte
= 0;
466 EMACS_INT result_len
;
467 EMACS_INT result_len_byte
;
469 Lisp_Object last_tail
;
472 /* When we make a multibyte string, we can't copy text properties
473 while concatenating each string because the length of resulting
474 string can't be decided until we finish the whole concatenation.
475 So, we record strings that have text properties to be copied
476 here, and copy the text properties after the concatenation. */
477 struct textprop_rec
*textprops
= NULL
;
478 /* Number of elements in textprops. */
479 ptrdiff_t num_textprops
= 0;
484 /* In append, the last arg isn't treated like the others */
485 if (last_special
&& nargs
> 0)
488 last_tail
= args
[nargs
];
493 /* Check each argument. */
494 for (argnum
= 0; argnum
< nargs
; argnum
++)
497 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
498 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
499 wrong_type_argument (Qsequencep
, this);
502 /* Compute total length in chars of arguments in RESULT_LEN.
503 If desired output is a string, also compute length in bytes
504 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
505 whether the result should be a multibyte string. */
509 for (argnum
= 0; argnum
< nargs
; argnum
++)
513 len
= XFASTINT (Flength (this));
514 if (target_type
== Lisp_String
)
516 /* We must count the number of bytes needed in the string
517 as well as the number of characters. */
521 ptrdiff_t this_len_byte
;
523 if (VECTORP (this) || COMPILEDP (this))
524 for (i
= 0; i
< len
; i
++)
527 CHECK_CHARACTER (ch
);
529 this_len_byte
= CHAR_BYTES (c
);
530 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
532 result_len_byte
+= this_len_byte
;
533 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
536 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
537 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
538 else if (CONSP (this))
539 for (; CONSP (this); this = XCDR (this))
542 CHECK_CHARACTER (ch
);
544 this_len_byte
= CHAR_BYTES (c
);
545 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
547 result_len_byte
+= this_len_byte
;
548 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
551 else if (STRINGP (this))
553 if (STRING_MULTIBYTE (this))
556 this_len_byte
= SBYTES (this);
559 this_len_byte
= count_size_as_multibyte (SDATA (this),
561 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
563 result_len_byte
+= this_len_byte
;
568 if (MOST_POSITIVE_FIXNUM
< result_len
)
569 memory_full (SIZE_MAX
);
572 if (! some_multibyte
)
573 result_len_byte
= result_len
;
575 /* Create the output object. */
576 if (target_type
== Lisp_Cons
)
577 val
= Fmake_list (make_number (result_len
), Qnil
);
578 else if (target_type
== Lisp_Vectorlike
)
579 val
= Fmake_vector (make_number (result_len
), Qnil
);
580 else if (some_multibyte
)
581 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
583 val
= make_uninit_string (result_len
);
585 /* In `append', if all but last arg are nil, return last arg. */
586 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
589 /* Copy the contents of the args into the result. */
591 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
593 toindex
= 0, toindex_byte
= 0;
597 SAFE_NALLOCA (textprops
, 1, nargs
);
599 for (argnum
= 0; argnum
< nargs
; argnum
++)
602 ptrdiff_t thisleni
= 0;
603 register ptrdiff_t thisindex
= 0;
604 register ptrdiff_t thisindex_byte
= 0;
608 thislen
= Flength (this), thisleni
= XINT (thislen
);
610 /* Between strings of the same kind, copy fast. */
611 if (STRINGP (this) && STRINGP (val
)
612 && STRING_MULTIBYTE (this) == some_multibyte
)
614 ptrdiff_t thislen_byte
= SBYTES (this);
616 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
617 if (string_intervals (this))
619 textprops
[num_textprops
].argnum
= argnum
;
620 textprops
[num_textprops
].from
= 0;
621 textprops
[num_textprops
++].to
= toindex
;
623 toindex_byte
+= thislen_byte
;
626 /* Copy a single-byte string to a multibyte string. */
627 else if (STRINGP (this) && STRINGP (val
))
629 if (string_intervals (this))
631 textprops
[num_textprops
].argnum
= argnum
;
632 textprops
[num_textprops
].from
= 0;
633 textprops
[num_textprops
++].to
= toindex
;
635 toindex_byte
+= copy_text (SDATA (this),
636 SDATA (val
) + toindex_byte
,
637 SCHARS (this), 0, 1);
641 /* Copy element by element. */
644 register Lisp_Object elt
;
646 /* Fetch next element of `this' arg into `elt', or break if
647 `this' is exhausted. */
648 if (NILP (this)) break;
650 elt
= XCAR (this), this = XCDR (this);
651 else if (thisindex
>= thisleni
)
653 else if (STRINGP (this))
656 if (STRING_MULTIBYTE (this))
657 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
662 c
= SREF (this, thisindex
); thisindex
++;
663 if (some_multibyte
&& !ASCII_CHAR_P (c
))
664 c
= BYTE8_TO_CHAR (c
);
666 XSETFASTINT (elt
, c
);
668 else if (BOOL_VECTOR_P (this))
671 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
672 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
680 elt
= AREF (this, thisindex
);
684 /* Store this element into the result. */
691 else if (VECTORP (val
))
693 ASET (val
, toindex
, elt
);
699 CHECK_CHARACTER (elt
);
702 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
704 SSET (val
, toindex_byte
++, c
);
710 XSETCDR (prev
, last_tail
);
712 if (num_textprops
> 0)
715 ptrdiff_t last_to_end
= -1;
717 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
719 this = args
[textprops
[argnum
].argnum
];
720 props
= text_property_list (this,
722 make_number (SCHARS (this)),
724 /* If successive arguments have properties, be sure that the
725 value of `composition' property be the copy. */
726 if (last_to_end
== textprops
[argnum
].to
)
727 make_composition_value_copy (props
);
728 add_text_properties_from_list (val
, props
,
729 make_number (textprops
[argnum
].to
));
730 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
738 static Lisp_Object string_char_byte_cache_string
;
739 static ptrdiff_t string_char_byte_cache_charpos
;
740 static ptrdiff_t string_char_byte_cache_bytepos
;
743 clear_string_char_byte_cache (void)
745 string_char_byte_cache_string
= Qnil
;
748 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
751 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
754 ptrdiff_t best_below
, best_below_byte
;
755 ptrdiff_t best_above
, best_above_byte
;
757 best_below
= best_below_byte
= 0;
758 best_above
= SCHARS (string
);
759 best_above_byte
= SBYTES (string
);
760 if (best_above
== best_above_byte
)
763 if (EQ (string
, string_char_byte_cache_string
))
765 if (string_char_byte_cache_charpos
< char_index
)
767 best_below
= string_char_byte_cache_charpos
;
768 best_below_byte
= string_char_byte_cache_bytepos
;
772 best_above
= string_char_byte_cache_charpos
;
773 best_above_byte
= string_char_byte_cache_bytepos
;
777 if (char_index
- best_below
< best_above
- char_index
)
779 unsigned char *p
= SDATA (string
) + best_below_byte
;
781 while (best_below
< char_index
)
783 p
+= BYTES_BY_CHAR_HEAD (*p
);
786 i_byte
= p
- SDATA (string
);
790 unsigned char *p
= SDATA (string
) + best_above_byte
;
792 while (best_above
> char_index
)
795 while (!CHAR_HEAD_P (*p
)) p
--;
798 i_byte
= p
- SDATA (string
);
801 string_char_byte_cache_bytepos
= i_byte
;
802 string_char_byte_cache_charpos
= char_index
;
803 string_char_byte_cache_string
= string
;
808 /* Return the character index corresponding to BYTE_INDEX in STRING. */
811 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
814 ptrdiff_t best_below
, best_below_byte
;
815 ptrdiff_t best_above
, best_above_byte
;
817 best_below
= best_below_byte
= 0;
818 best_above
= SCHARS (string
);
819 best_above_byte
= SBYTES (string
);
820 if (best_above
== best_above_byte
)
823 if (EQ (string
, string_char_byte_cache_string
))
825 if (string_char_byte_cache_bytepos
< byte_index
)
827 best_below
= string_char_byte_cache_charpos
;
828 best_below_byte
= string_char_byte_cache_bytepos
;
832 best_above
= string_char_byte_cache_charpos
;
833 best_above_byte
= string_char_byte_cache_bytepos
;
837 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
839 unsigned char *p
= SDATA (string
) + best_below_byte
;
840 unsigned char *pend
= SDATA (string
) + byte_index
;
844 p
+= BYTES_BY_CHAR_HEAD (*p
);
848 i_byte
= p
- SDATA (string
);
852 unsigned char *p
= SDATA (string
) + best_above_byte
;
853 unsigned char *pbeg
= SDATA (string
) + byte_index
;
858 while (!CHAR_HEAD_P (*p
)) p
--;
862 i_byte
= p
- SDATA (string
);
865 string_char_byte_cache_bytepos
= i_byte
;
866 string_char_byte_cache_charpos
= i
;
867 string_char_byte_cache_string
= string
;
872 /* Convert STRING to a multibyte string. */
875 string_make_multibyte (Lisp_Object string
)
882 if (STRING_MULTIBYTE (string
))
885 nbytes
= count_size_as_multibyte (SDATA (string
),
887 /* If all the chars are ASCII, they won't need any more bytes
888 once converted. In that case, we can return STRING itself. */
889 if (nbytes
== SBYTES (string
))
892 buf
= SAFE_ALLOCA (nbytes
);
893 copy_text (SDATA (string
), buf
, SBYTES (string
),
896 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
903 /* Convert STRING (if unibyte) to a multibyte string without changing
904 the number of characters. Characters 0200 trough 0237 are
905 converted to eight-bit characters. */
908 string_to_multibyte (Lisp_Object string
)
915 if (STRING_MULTIBYTE (string
))
918 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
919 /* If all the chars are ASCII, they won't need any more bytes once
921 if (nbytes
== SBYTES (string
))
922 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
924 buf
= SAFE_ALLOCA (nbytes
);
925 memcpy (buf
, SDATA (string
), SBYTES (string
));
926 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
928 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
935 /* Convert STRING to a single-byte string. */
938 string_make_unibyte (Lisp_Object string
)
945 if (! STRING_MULTIBYTE (string
))
948 nchars
= SCHARS (string
);
950 buf
= SAFE_ALLOCA (nchars
);
951 copy_text (SDATA (string
), buf
, SBYTES (string
),
954 ret
= make_unibyte_string ((char *) buf
, nchars
);
960 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
962 doc
: /* Return the multibyte equivalent of STRING.
963 If STRING is unibyte and contains non-ASCII characters, the function
964 `unibyte-char-to-multibyte' is used to convert each unibyte character
965 to a multibyte character. In this case, the returned string is a
966 newly created string with no text properties. If STRING is multibyte
967 or entirely ASCII, it is returned unchanged. In particular, when
968 STRING is unibyte and entirely ASCII, the returned string is unibyte.
969 \(When the characters are all ASCII, Emacs primitives will treat the
970 string the same way whether it is unibyte or multibyte.) */)
973 CHECK_STRING (string
);
975 return string_make_multibyte (string
);
978 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
980 doc
: /* Return the unibyte equivalent of STRING.
981 Multibyte character codes are converted to unibyte according to
982 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
983 If the lookup in the translation table fails, this function takes just
984 the low 8 bits of each character. */)
987 CHECK_STRING (string
);
989 return string_make_unibyte (string
);
992 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
994 doc
: /* Return a unibyte string with the same individual bytes as STRING.
995 If STRING is unibyte, the result is STRING itself.
996 Otherwise it is a newly created string, with no text properties.
997 If STRING is multibyte and contains a character of charset
998 `eight-bit', it is converted to the corresponding single byte. */)
1001 CHECK_STRING (string
);
1003 if (STRING_MULTIBYTE (string
))
1005 ptrdiff_t bytes
= SBYTES (string
);
1006 unsigned char *str
= xmalloc (bytes
);
1008 memcpy (str
, SDATA (string
), bytes
);
1009 bytes
= str_as_unibyte (str
, bytes
);
1010 string
= make_unibyte_string ((char *) str
, bytes
);
1016 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1018 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1019 If STRING is multibyte, the result is STRING itself.
1020 Otherwise it is a newly created string, with no text properties.
1022 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1023 part of a correct utf-8 sequence), it is converted to the corresponding
1024 multibyte character of charset `eight-bit'.
1025 See also `string-to-multibyte'.
1027 Beware, this often doesn't really do what you think it does.
1028 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1029 If you're not sure, whether to use `string-as-multibyte' or
1030 `string-to-multibyte', use `string-to-multibyte'. */)
1031 (Lisp_Object string
)
1033 CHECK_STRING (string
);
1035 if (! STRING_MULTIBYTE (string
))
1037 Lisp_Object new_string
;
1038 ptrdiff_t nchars
, nbytes
;
1040 parse_str_as_multibyte (SDATA (string
),
1043 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1044 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1045 if (nbytes
!= SBYTES (string
))
1046 str_as_multibyte (SDATA (new_string
), nbytes
,
1047 SBYTES (string
), NULL
);
1048 string
= new_string
;
1049 set_string_intervals (string
, NULL
);
1054 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1056 doc
: /* Return a multibyte string with the same individual chars as STRING.
1057 If STRING is multibyte, the result is STRING itself.
1058 Otherwise it is a newly created string, with no text properties.
1060 If STRING is unibyte and contains an 8-bit byte, it is converted to
1061 the corresponding multibyte character of charset `eight-bit'.
1063 This differs from `string-as-multibyte' by converting each byte of a correct
1064 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1065 correct sequence. */)
1066 (Lisp_Object string
)
1068 CHECK_STRING (string
);
1070 return string_to_multibyte (string
);
1073 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1075 doc
: /* Return a unibyte string with the same individual chars as STRING.
1076 If STRING is unibyte, the result is STRING itself.
1077 Otherwise it is a newly created string, with no text properties,
1078 where each `eight-bit' character is converted to the corresponding byte.
1079 If STRING contains a non-ASCII, non-`eight-bit' character,
1080 an error is signaled. */)
1081 (Lisp_Object string
)
1083 CHECK_STRING (string
);
1085 if (STRING_MULTIBYTE (string
))
1087 ptrdiff_t chars
= SCHARS (string
);
1088 unsigned char *str
= xmalloc (chars
);
1089 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1091 if (converted
< chars
)
1092 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1093 string
= make_unibyte_string ((char *) str
, chars
);
1100 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1101 doc
: /* Return a copy of ALIST.
1102 This is an alist which represents the same mapping from objects to objects,
1103 but does not share the alist structure with ALIST.
1104 The objects mapped (cars and cdrs of elements of the alist)
1105 are shared, however.
1106 Elements of ALIST that are not conses are also shared. */)
1109 register Lisp_Object tem
;
1114 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1115 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1117 register Lisp_Object car
;
1121 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1126 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1127 doc
: /* Return a new string whose contents are a substring of STRING.
1128 The returned string consists of the characters between index FROM
1129 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1130 zero-indexed: 0 means the first character of STRING. Negative values
1131 are counted from the end of STRING. If TO is nil, the substring runs
1132 to the end of STRING.
1134 The STRING argument may also be a vector. In that case, the return
1135 value is a new vector that contains the elements between index FROM
1136 \(inclusive) and index TO (exclusive) of that vector argument. */)
1137 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1141 EMACS_INT from_char
, to_char
;
1143 CHECK_VECTOR_OR_STRING (string
);
1144 CHECK_NUMBER (from
);
1146 if (STRINGP (string
))
1147 size
= SCHARS (string
);
1149 size
= ASIZE (string
);
1157 to_char
= XINT (to
);
1162 from_char
= XINT (from
);
1165 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1166 args_out_of_range_3 (string
, make_number (from_char
),
1167 make_number (to_char
));
1169 if (STRINGP (string
))
1172 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1173 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1174 res
= make_specified_string (SSDATA (string
) + from_byte
,
1175 to_char
- from_char
, to_byte
- from_byte
,
1176 STRING_MULTIBYTE (string
));
1177 copy_text_properties (make_number (from_char
), make_number (to_char
),
1178 string
, make_number (0), res
, Qnil
);
1181 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1187 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1188 doc
: /* Return a substring of STRING, without text properties.
1189 It starts at index FROM and ends before TO.
1190 TO may be nil or omitted; then the substring runs to the end of STRING.
1191 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1192 If FROM or TO is negative, it counts from the end.
1194 With one argument, just copy STRING without its properties. */)
1195 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1198 EMACS_INT from_char
, to_char
;
1199 ptrdiff_t from_byte
, to_byte
;
1201 CHECK_STRING (string
);
1203 size
= SCHARS (string
);
1209 CHECK_NUMBER (from
);
1210 from_char
= XINT (from
);
1220 to_char
= XINT (to
);
1225 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1226 args_out_of_range_3 (string
, make_number (from_char
),
1227 make_number (to_char
));
1229 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1231 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1232 return make_specified_string (SSDATA (string
) + from_byte
,
1233 to_char
- from_char
, to_byte
- from_byte
,
1234 STRING_MULTIBYTE (string
));
1237 /* Extract a substring of STRING, giving start and end positions
1238 both in characters and in bytes. */
1241 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1242 ptrdiff_t to
, ptrdiff_t to_byte
)
1247 CHECK_VECTOR_OR_STRING (string
);
1249 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1251 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1252 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1254 if (STRINGP (string
))
1256 res
= make_specified_string (SSDATA (string
) + from_byte
,
1257 to
- from
, to_byte
- from_byte
,
1258 STRING_MULTIBYTE (string
));
1259 copy_text_properties (make_number (from
), make_number (to
),
1260 string
, make_number (0), res
, Qnil
);
1263 res
= Fvector (to
- from
, aref_addr (string
, from
));
1268 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1269 doc
: /* Take cdr N times on LIST, return the result. */)
1270 (Lisp_Object n
, Lisp_Object list
)
1275 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1278 CHECK_LIST_CONS (list
, list
);
1284 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1285 doc
: /* Return the Nth element of LIST.
1286 N counts from zero. If LIST is not that long, nil is returned. */)
1287 (Lisp_Object n
, Lisp_Object list
)
1289 return Fcar (Fnthcdr (n
, list
));
1292 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1293 doc
: /* Return element of SEQUENCE at index N. */)
1294 (register Lisp_Object sequence
, Lisp_Object n
)
1297 if (CONSP (sequence
) || NILP (sequence
))
1298 return Fcar (Fnthcdr (n
, sequence
));
1300 /* Faref signals a "not array" error, so check here. */
1301 CHECK_ARRAY (sequence
, Qsequencep
);
1302 return Faref (sequence
, n
);
1305 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1306 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1307 The value is actually the tail of LIST whose car is ELT. */)
1308 (register Lisp_Object elt
, Lisp_Object list
)
1310 register Lisp_Object tail
;
1311 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1313 register Lisp_Object tem
;
1314 CHECK_LIST_CONS (tail
, list
);
1316 if (! NILP (Fequal (elt
, tem
)))
1323 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1324 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1325 The value is actually the tail of LIST whose car is ELT. */)
1326 (register Lisp_Object elt
, Lisp_Object list
)
1330 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1334 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1338 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1349 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1350 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1351 The value is actually the tail of LIST whose car is ELT. */)
1352 (register Lisp_Object elt
, Lisp_Object list
)
1354 register Lisp_Object tail
;
1357 return Fmemq (elt
, list
);
1359 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1361 register Lisp_Object tem
;
1362 CHECK_LIST_CONS (tail
, list
);
1364 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1371 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1372 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1373 The value is actually the first element of LIST whose car is KEY.
1374 Elements of LIST that are not conses are ignored. */)
1375 (Lisp_Object key
, Lisp_Object list
)
1380 || (CONSP (XCAR (list
))
1381 && EQ (XCAR (XCAR (list
)), key
)))
1386 || (CONSP (XCAR (list
))
1387 && EQ (XCAR (XCAR (list
)), key
)))
1392 || (CONSP (XCAR (list
))
1393 && EQ (XCAR (XCAR (list
)), key
)))
1403 /* Like Fassq but never report an error and do not allow quits.
1404 Use only on lists known never to be circular. */
1407 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1410 && (!CONSP (XCAR (list
))
1411 || !EQ (XCAR (XCAR (list
)), key
)))
1414 return CAR_SAFE (list
);
1417 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1418 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1419 The value is actually the first element of LIST whose car equals KEY. */)
1420 (Lisp_Object key
, Lisp_Object list
)
1427 || (CONSP (XCAR (list
))
1428 && (car
= XCAR (XCAR (list
)),
1429 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1434 || (CONSP (XCAR (list
))
1435 && (car
= XCAR (XCAR (list
)),
1436 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1441 || (CONSP (XCAR (list
))
1442 && (car
= XCAR (XCAR (list
)),
1443 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1453 /* Like Fassoc but never report an error and do not allow quits.
1454 Use only on lists known never to be circular. */
1457 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1460 && (!CONSP (XCAR (list
))
1461 || (!EQ (XCAR (XCAR (list
)), key
)
1462 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1465 return CONSP (list
) ? XCAR (list
) : Qnil
;
1468 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1469 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1470 The value is actually the first element of LIST whose cdr is KEY. */)
1471 (register Lisp_Object key
, Lisp_Object list
)
1476 || (CONSP (XCAR (list
))
1477 && EQ (XCDR (XCAR (list
)), key
)))
1482 || (CONSP (XCAR (list
))
1483 && EQ (XCDR (XCAR (list
)), key
)))
1488 || (CONSP (XCAR (list
))
1489 && EQ (XCDR (XCAR (list
)), key
)))
1499 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1500 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1501 The value is actually the first element of LIST whose cdr equals KEY. */)
1502 (Lisp_Object key
, Lisp_Object list
)
1509 || (CONSP (XCAR (list
))
1510 && (cdr
= XCDR (XCAR (list
)),
1511 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1516 || (CONSP (XCAR (list
))
1517 && (cdr
= XCDR (XCAR (list
)),
1518 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1523 || (CONSP (XCAR (list
))
1524 && (cdr
= XCDR (XCAR (list
)),
1525 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1535 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1536 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1537 More precisely, this function skips any members `eq' to ELT at the
1538 front of LIST, then removes members `eq' to ELT from the remaining
1539 sublist by modifying its list structure, then returns the resulting
1542 Write `(setq foo (delq element foo))' to be sure of correctly changing
1543 the value of a list `foo'. */)
1544 (register Lisp_Object elt
, Lisp_Object list
)
1546 register Lisp_Object tail
, prev
;
1547 register Lisp_Object tem
;
1551 while (!NILP (tail
))
1553 CHECK_LIST_CONS (tail
, list
);
1560 Fsetcdr (prev
, XCDR (tail
));
1570 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1571 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1572 SEQ must be a sequence (i.e. a list, a vector, or a string).
1573 The return value is a sequence of the same type.
1575 If SEQ is a list, this behaves like `delq', except that it compares
1576 with `equal' instead of `eq'. In particular, it may remove elements
1577 by altering the list structure.
1579 If SEQ is not a list, deletion is never performed destructively;
1580 instead this function creates and returns a new vector or string.
1582 Write `(setq foo (delete element foo))' to be sure of correctly
1583 changing the value of a sequence `foo'. */)
1584 (Lisp_Object elt
, Lisp_Object seq
)
1590 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1591 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1594 if (n
!= ASIZE (seq
))
1596 struct Lisp_Vector
*p
= allocate_vector (n
);
1598 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1599 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1600 p
->contents
[n
++] = AREF (seq
, i
);
1602 XSETVECTOR (seq
, p
);
1605 else if (STRINGP (seq
))
1607 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1610 for (i
= nchars
= nbytes
= ibyte
= 0;
1612 ++i
, ibyte
+= cbytes
)
1614 if (STRING_MULTIBYTE (seq
))
1616 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1617 cbytes
= CHAR_BYTES (c
);
1625 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1632 if (nchars
!= SCHARS (seq
))
1636 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1637 if (!STRING_MULTIBYTE (seq
))
1638 STRING_SET_UNIBYTE (tem
);
1640 for (i
= nchars
= nbytes
= ibyte
= 0;
1642 ++i
, ibyte
+= cbytes
)
1644 if (STRING_MULTIBYTE (seq
))
1646 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1647 cbytes
= CHAR_BYTES (c
);
1655 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1657 unsigned char *from
= SDATA (seq
) + ibyte
;
1658 unsigned char *to
= SDATA (tem
) + nbytes
;
1664 for (n
= cbytes
; n
--; )
1674 Lisp_Object tail
, prev
;
1676 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1678 CHECK_LIST_CONS (tail
, seq
);
1680 if (!NILP (Fequal (elt
, XCAR (tail
))))
1685 Fsetcdr (prev
, XCDR (tail
));
1696 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1697 doc
: /* Reverse LIST by modifying cdr pointers.
1698 Return the reversed list. Expects a properly nil-terminated list. */)
1701 register Lisp_Object prev
, tail
, next
;
1703 if (NILP (list
)) return list
;
1706 while (!NILP (tail
))
1709 CHECK_LIST_CONS (tail
, tail
);
1711 Fsetcdr (tail
, prev
);
1718 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1719 doc
: /* Reverse LIST, copying. Return the reversed list.
1720 See also the function `nreverse', which is used more often. */)
1725 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1728 new = Fcons (XCAR (list
), new);
1730 CHECK_LIST_END (list
, list
);
1734 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1736 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1737 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1738 Returns the sorted list. LIST is modified by side effects.
1739 PREDICATE is called with two elements of LIST, and should return non-nil
1740 if the first element should sort before the second. */)
1741 (Lisp_Object list
, Lisp_Object predicate
)
1743 Lisp_Object front
, back
;
1744 register Lisp_Object len
, tem
;
1745 struct gcpro gcpro1
, gcpro2
;
1749 len
= Flength (list
);
1750 length
= XINT (len
);
1754 XSETINT (len
, (length
/ 2) - 1);
1755 tem
= Fnthcdr (len
, list
);
1757 Fsetcdr (tem
, Qnil
);
1759 GCPRO2 (front
, back
);
1760 front
= Fsort (front
, predicate
);
1761 back
= Fsort (back
, predicate
);
1763 return merge (front
, back
, predicate
);
1767 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1770 register Lisp_Object tail
;
1772 register Lisp_Object l1
, l2
;
1773 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1780 /* It is sufficient to protect org_l1 and org_l2.
1781 When l1 and l2 are updated, we copy the new values
1782 back into the org_ vars. */
1783 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1803 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1819 Fsetcdr (tail
, tem
);
1825 /* This does not check for quits. That is safe since it must terminate. */
1827 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1828 doc
: /* Extract a value from a property list.
1829 PLIST is a property list, which is a list of the form
1830 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1831 corresponding to the given PROP, or nil if PROP is not one of the
1832 properties on the list. This function never signals an error. */)
1833 (Lisp_Object plist
, Lisp_Object prop
)
1835 Lisp_Object tail
, halftail
;
1837 /* halftail is used to detect circular lists. */
1838 tail
= halftail
= plist
;
1839 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1841 if (EQ (prop
, XCAR (tail
)))
1842 return XCAR (XCDR (tail
));
1844 tail
= XCDR (XCDR (tail
));
1845 halftail
= XCDR (halftail
);
1846 if (EQ (tail
, halftail
))
1853 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1854 doc
: /* Return the value of SYMBOL's PROPNAME property.
1855 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1856 (Lisp_Object symbol
, Lisp_Object propname
)
1858 CHECK_SYMBOL (symbol
);
1859 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1862 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1863 doc
: /* Change value in PLIST of PROP to VAL.
1864 PLIST is a property list, which is a list of the form
1865 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1866 If PROP is already a property on the list, its value is set to VAL,
1867 otherwise the new PROP VAL pair is added. The new plist is returned;
1868 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1869 The PLIST is modified by side effects. */)
1870 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1872 register Lisp_Object tail
, prev
;
1873 Lisp_Object newcell
;
1875 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1876 tail
= XCDR (XCDR (tail
)))
1878 if (EQ (prop
, XCAR (tail
)))
1880 Fsetcar (XCDR (tail
), val
);
1887 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1891 Fsetcdr (XCDR (prev
), newcell
);
1895 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1896 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1897 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1898 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1900 CHECK_SYMBOL (symbol
);
1902 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1906 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1907 doc
: /* Extract a value from a property list, comparing with `equal'.
1908 PLIST is a property list, which is a list of the form
1909 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1910 corresponding to the given PROP, or nil if PROP is not
1911 one of the properties on the list. */)
1912 (Lisp_Object plist
, Lisp_Object prop
)
1917 CONSP (tail
) && CONSP (XCDR (tail
));
1918 tail
= XCDR (XCDR (tail
)))
1920 if (! NILP (Fequal (prop
, XCAR (tail
))))
1921 return XCAR (XCDR (tail
));
1926 CHECK_LIST_END (tail
, prop
);
1931 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1932 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1933 PLIST is a property list, which is a list of the form
1934 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1935 If PROP is already a property on the list, its value is set to VAL,
1936 otherwise the new PROP VAL pair is added. The new plist is returned;
1937 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1938 The PLIST is modified by side effects. */)
1939 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1941 register Lisp_Object tail
, prev
;
1942 Lisp_Object newcell
;
1944 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1945 tail
= XCDR (XCDR (tail
)))
1947 if (! NILP (Fequal (prop
, XCAR (tail
))))
1949 Fsetcar (XCDR (tail
), val
);
1956 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1960 Fsetcdr (XCDR (prev
), newcell
);
1964 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1965 doc
: /* Return t if the two args are the same Lisp object.
1966 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1967 (Lisp_Object obj1
, Lisp_Object obj2
)
1970 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1972 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1975 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1976 doc
: /* Return t if two Lisp objects have similar structure and contents.
1977 They must have the same data type.
1978 Conses are compared by comparing the cars and the cdrs.
1979 Vectors and strings are compared element by element.
1980 Numbers are compared by value, but integers cannot equal floats.
1981 (Use `=' if you want integers and floats to be able to be equal.)
1982 Symbols must match exactly. */)
1983 (register Lisp_Object o1
, Lisp_Object o2
)
1985 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1988 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1989 doc
: /* Return t if two Lisp objects have similar structure and contents.
1990 This is like `equal' except that it compares the text properties
1991 of strings. (`equal' ignores text properties.) */)
1992 (register Lisp_Object o1
, Lisp_Object o2
)
1994 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
1997 /* DEPTH is current depth of recursion. Signal an error if it
1999 PROPS means compare string text properties too. */
2002 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
)
2005 error ("Stack overflow in equal");
2011 if (XTYPE (o1
) != XTYPE (o2
))
2020 d1
= extract_float (o1
);
2021 d2
= extract_float (o2
);
2022 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2023 though they are not =. */
2024 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2028 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2035 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2039 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2041 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2044 o1
= XOVERLAY (o1
)->plist
;
2045 o2
= XOVERLAY (o2
)->plist
;
2050 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2051 && (XMARKER (o1
)->buffer
== 0
2052 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2056 case Lisp_Vectorlike
:
2059 ptrdiff_t size
= ASIZE (o1
);
2060 /* Pseudovectors have the type encoded in the size field, so this test
2061 actually checks that the objects have the same type as well as the
2063 if (ASIZE (o2
) != size
)
2065 /* Boolvectors are compared much like strings. */
2066 if (BOOL_VECTOR_P (o1
))
2068 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2070 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2071 ((XBOOL_VECTOR (o1
)->size
2072 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2073 / BOOL_VECTOR_BITS_PER_CHAR
)))
2077 if (WINDOW_CONFIGURATIONP (o1
))
2078 return compare_window_configurations (o1
, o2
, 0);
2080 /* Aside from them, only true vectors, char-tables, compiled
2081 functions, and fonts (font-spec, font-entity, font-object)
2082 are sensible to compare, so eliminate the others now. */
2083 if (size
& PSEUDOVECTOR_FLAG
)
2085 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2088 size
&= PSEUDOVECTOR_SIZE_MASK
;
2090 for (i
= 0; i
< size
; i
++)
2095 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2103 if (SCHARS (o1
) != SCHARS (o2
))
2105 if (SBYTES (o1
) != SBYTES (o2
))
2107 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2109 if (props
&& !compare_string_intervals (o1
, o2
))
2121 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2122 doc
: /* Store each element of ARRAY with ITEM.
2123 ARRAY is a vector, string, char-table, or bool-vector. */)
2124 (Lisp_Object array
, Lisp_Object item
)
2126 register ptrdiff_t size
, idx
;
2128 if (VECTORP (array
))
2129 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2130 ASET (array
, idx
, item
);
2131 else if (CHAR_TABLE_P (array
))
2135 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2136 set_char_table_contents (array
, i
, item
);
2137 set_char_table_defalt (array
, item
);
2139 else if (STRINGP (array
))
2141 register unsigned char *p
= SDATA (array
);
2143 CHECK_CHARACTER (item
);
2144 charval
= XFASTINT (item
);
2145 size
= SCHARS (array
);
2146 if (STRING_MULTIBYTE (array
))
2148 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2149 int len
= CHAR_STRING (charval
, str
);
2150 ptrdiff_t size_byte
= SBYTES (array
);
2152 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2153 || SCHARS (array
) * len
!= size_byte
)
2154 error ("Attempt to change byte length of a string");
2155 for (idx
= 0; idx
< size_byte
; idx
++)
2156 *p
++ = str
[idx
% len
];
2159 for (idx
= 0; idx
< size
; idx
++)
2162 else if (BOOL_VECTOR_P (array
))
2164 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2166 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2167 / BOOL_VECTOR_BITS_PER_CHAR
);
2171 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2173 /* Clear any extraneous bits in the last byte. */
2174 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2178 wrong_type_argument (Qarrayp
, array
);
2182 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2184 doc
: /* Clear the contents of STRING.
2185 This makes STRING unibyte and may change its length. */)
2186 (Lisp_Object string
)
2189 CHECK_STRING (string
);
2190 len
= SBYTES (string
);
2191 memset (SDATA (string
), 0, len
);
2192 STRING_SET_CHARS (string
, len
);
2193 STRING_SET_UNIBYTE (string
);
2199 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2201 Lisp_Object args
[2];
2204 return Fnconc (2, args
);
2207 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2208 doc
: /* Concatenate any number of lists by altering them.
2209 Only the last argument is not altered, and need not be a list.
2210 usage: (nconc &rest LISTS) */)
2211 (ptrdiff_t nargs
, Lisp_Object
*args
)
2214 register Lisp_Object tail
, tem
, val
;
2218 for (argnum
= 0; argnum
< nargs
; argnum
++)
2221 if (NILP (tem
)) continue;
2226 if (argnum
+ 1 == nargs
) break;
2228 CHECK_LIST_CONS (tem
, tem
);
2237 tem
= args
[argnum
+ 1];
2238 Fsetcdr (tail
, tem
);
2240 args
[argnum
+ 1] = tail
;
2246 /* This is the guts of all mapping functions.
2247 Apply FN to each element of SEQ, one by one,
2248 storing the results into elements of VALS, a C vector of Lisp_Objects.
2249 LENI is the length of VALS, which should also be the length of SEQ. */
2252 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2254 register Lisp_Object tail
;
2256 register EMACS_INT i
;
2257 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2261 /* Don't let vals contain any garbage when GC happens. */
2262 for (i
= 0; i
< leni
; i
++)
2265 GCPRO3 (dummy
, fn
, seq
);
2267 gcpro1
.nvars
= leni
;
2271 /* We need not explicitly protect `tail' because it is used only on lists, and
2272 1) lists are not relocated and 2) the list is marked via `seq' so will not
2275 if (VECTORP (seq
) || COMPILEDP (seq
))
2277 for (i
= 0; i
< leni
; i
++)
2279 dummy
= call1 (fn
, AREF (seq
, i
));
2284 else if (BOOL_VECTOR_P (seq
))
2286 for (i
= 0; i
< leni
; i
++)
2289 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2290 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2291 dummy
= call1 (fn
, dummy
);
2296 else if (STRINGP (seq
))
2300 for (i
= 0, i_byte
= 0; i
< leni
;)
2303 ptrdiff_t i_before
= i
;
2305 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2306 XSETFASTINT (dummy
, c
);
2307 dummy
= call1 (fn
, dummy
);
2309 vals
[i_before
] = dummy
;
2312 else /* Must be a list, since Flength did not get an error */
2315 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2317 dummy
= call1 (fn
, XCAR (tail
));
2327 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2328 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2329 In between each pair of results, stick in SEPARATOR. Thus, " " as
2330 SEPARATOR results in spaces between the values returned by FUNCTION.
2331 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2332 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2335 register EMACS_INT leni
;
2338 register Lisp_Object
*args
;
2339 struct gcpro gcpro1
;
2343 len
= Flength (sequence
);
2344 if (CHAR_TABLE_P (sequence
))
2345 wrong_type_argument (Qlistp
, sequence
);
2347 nargs
= leni
+ leni
- 1;
2348 if (nargs
< 0) return empty_unibyte_string
;
2350 SAFE_ALLOCA_LISP (args
, nargs
);
2353 mapcar1 (leni
, args
, function
, sequence
);
2356 for (i
= leni
- 1; i
> 0; i
--)
2357 args
[i
+ i
] = args
[i
];
2359 for (i
= 1; i
< nargs
; i
+= 2)
2360 args
[i
] = separator
;
2362 ret
= Fconcat (nargs
, args
);
2368 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2369 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2370 The result is a list just as long as SEQUENCE.
2371 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2372 (Lisp_Object function
, Lisp_Object sequence
)
2374 register Lisp_Object len
;
2375 register EMACS_INT leni
;
2376 register Lisp_Object
*args
;
2380 len
= Flength (sequence
);
2381 if (CHAR_TABLE_P (sequence
))
2382 wrong_type_argument (Qlistp
, sequence
);
2383 leni
= XFASTINT (len
);
2385 SAFE_ALLOCA_LISP (args
, leni
);
2387 mapcar1 (leni
, args
, function
, sequence
);
2389 ret
= Flist (leni
, args
);
2395 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2396 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2397 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2398 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2399 (Lisp_Object function
, Lisp_Object sequence
)
2401 register EMACS_INT leni
;
2403 leni
= XFASTINT (Flength (sequence
));
2404 if (CHAR_TABLE_P (sequence
))
2405 wrong_type_argument (Qlistp
, sequence
);
2406 mapcar1 (leni
, 0, function
, sequence
);
2411 /* This is how C code calls `yes-or-no-p' and allows the user
2414 Anything that calls this function must protect from GC! */
2417 do_yes_or_no_p (Lisp_Object prompt
)
2419 return call1 (intern ("yes-or-no-p"), prompt
);
2422 /* Anything that calls this function must protect from GC! */
2424 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2425 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2426 PROMPT is the string to display to ask the question. It should end in
2427 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2429 The user must confirm the answer with RET, and can edit it until it
2432 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2433 is nil, and `use-dialog-box' is non-nil. */)
2434 (Lisp_Object prompt
)
2436 register Lisp_Object ans
;
2437 Lisp_Object args
[2];
2438 struct gcpro gcpro1
;
2440 CHECK_STRING (prompt
);
2443 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2444 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2448 Lisp_Object pane
, menu
, obj
;
2449 redisplay_preserve_echo_area (4);
2450 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2451 Fcons (Fcons (build_string ("No"), Qnil
),
2454 menu
= Fcons (prompt
, pane
);
2455 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2459 #endif /* HAVE_MENUS */
2462 args
[1] = build_string ("(yes or no) ");
2463 prompt
= Fconcat (2, args
);
2469 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2470 Qyes_or_no_p_history
, Qnil
,
2472 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2477 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2485 message ("Please answer yes or no.");
2486 Fsleep_for (make_number (2), Qnil
);
2490 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2491 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2493 Each of the three load averages is multiplied by 100, then converted
2496 When USE-FLOATS is non-nil, floats will be used instead of integers.
2497 These floats are not multiplied by 100.
2499 If the 5-minute or 15-minute load averages are not available, return a
2500 shortened list, containing only those averages which are available.
2502 An error is thrown if the load average can't be obtained. In some
2503 cases making it work would require Emacs being installed setuid or
2504 setgid so that it can read kernel information, and that usually isn't
2506 (Lisp_Object use_floats
)
2509 int loads
= getloadavg (load_ave
, 3);
2510 Lisp_Object ret
= Qnil
;
2513 error ("load-average not implemented for this operating system");
2517 Lisp_Object load
= (NILP (use_floats
)
2518 ? make_number (100.0 * load_ave
[loads
])
2519 : make_float (load_ave
[loads
]));
2520 ret
= Fcons (load
, ret
);
2526 static Lisp_Object Qsubfeatures
;
2528 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2529 doc
: /* Return t if FEATURE is present in this Emacs.
2531 Use this to conditionalize execution of lisp code based on the
2532 presence or absence of Emacs or environment extensions.
2533 Use `provide' to declare that a feature is available. This function
2534 looks at the value of the variable `features'. The optional argument
2535 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2536 (Lisp_Object feature
, Lisp_Object subfeature
)
2538 register Lisp_Object tem
;
2539 CHECK_SYMBOL (feature
);
2540 tem
= Fmemq (feature
, Vfeatures
);
2541 if (!NILP (tem
) && !NILP (subfeature
))
2542 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2543 return (NILP (tem
)) ? Qnil
: Qt
;
2546 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2547 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2548 The optional argument SUBFEATURES should be a list of symbols listing
2549 particular subfeatures supported in this version of FEATURE. */)
2550 (Lisp_Object feature
, Lisp_Object subfeatures
)
2552 register Lisp_Object tem
;
2553 CHECK_SYMBOL (feature
);
2554 CHECK_LIST (subfeatures
);
2555 if (!NILP (Vautoload_queue
))
2556 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2558 tem
= Fmemq (feature
, Vfeatures
);
2560 Vfeatures
= Fcons (feature
, Vfeatures
);
2561 if (!NILP (subfeatures
))
2562 Fput (feature
, Qsubfeatures
, subfeatures
);
2563 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2565 /* Run any load-hooks for this file. */
2566 tem
= Fassq (feature
, Vafter_load_alist
);
2568 Fprogn (XCDR (tem
));
2573 /* `require' and its subroutines. */
2575 /* List of features currently being require'd, innermost first. */
2577 static Lisp_Object require_nesting_list
;
2580 require_unwind (Lisp_Object old_value
)
2582 return require_nesting_list
= old_value
;
2585 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2586 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2587 If FEATURE is not a member of the list `features', then the feature
2588 is not loaded; so load the file FILENAME.
2589 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2590 and `load' will try to load this name appended with the suffix `.elc' or
2591 `.el', in that order. The name without appended suffix will not be used.
2592 See `get-load-suffixes' for the complete list of suffixes.
2593 If the optional third argument NOERROR is non-nil,
2594 then return nil if the file is not found instead of signaling an error.
2595 Normally the return value is FEATURE.
2596 The normal messages at start and end of loading FILENAME are suppressed. */)
2597 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2600 struct gcpro gcpro1
, gcpro2
;
2601 bool from_file
= load_in_progress
;
2603 CHECK_SYMBOL (feature
);
2605 /* Record the presence of `require' in this file
2606 even if the feature specified is already loaded.
2607 But not more than once in any file,
2608 and not when we aren't loading or reading from a file. */
2610 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2611 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2616 tem
= Fcons (Qrequire
, feature
);
2617 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2618 LOADHIST_ATTACH (tem
);
2620 tem
= Fmemq (feature
, Vfeatures
);
2624 ptrdiff_t count
= SPECPDL_INDEX ();
2627 /* This is to make sure that loadup.el gives a clear picture
2628 of what files are preloaded and when. */
2629 if (! NILP (Vpurify_flag
))
2630 error ("(require %s) while preparing to dump",
2631 SDATA (SYMBOL_NAME (feature
)));
2633 /* A certain amount of recursive `require' is legitimate,
2634 but if we require the same feature recursively 3 times,
2636 tem
= require_nesting_list
;
2637 while (! NILP (tem
))
2639 if (! NILP (Fequal (feature
, XCAR (tem
))))
2644 error ("Recursive `require' for feature `%s'",
2645 SDATA (SYMBOL_NAME (feature
)));
2647 /* Update the list for any nested `require's that occur. */
2648 record_unwind_protect (require_unwind
, require_nesting_list
);
2649 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2651 /* Value saved here is to be restored into Vautoload_queue */
2652 record_unwind_protect (un_autoload
, Vautoload_queue
);
2653 Vautoload_queue
= Qt
;
2655 /* Load the file. */
2656 GCPRO2 (feature
, filename
);
2657 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2658 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2661 /* If load failed entirely, return nil. */
2663 return unbind_to (count
, Qnil
);
2665 tem
= Fmemq (feature
, Vfeatures
);
2667 error ("Required feature `%s' was not provided",
2668 SDATA (SYMBOL_NAME (feature
)));
2670 /* Once loading finishes, don't undo it. */
2671 Vautoload_queue
= Qt
;
2672 feature
= unbind_to (count
, feature
);
2678 /* Primitives for work of the "widget" library.
2679 In an ideal world, this section would not have been necessary.
2680 However, lisp function calls being as slow as they are, it turns
2681 out that some functions in the widget library (wid-edit.el) are the
2682 bottleneck of Widget operation. Here is their translation to C,
2683 for the sole reason of efficiency. */
2685 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2686 doc
: /* Return non-nil if PLIST has the property PROP.
2687 PLIST is a property list, which is a list of the form
2688 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2689 Unlike `plist-get', this allows you to distinguish between a missing
2690 property and a property with the value nil.
2691 The value is actually the tail of PLIST whose car is PROP. */)
2692 (Lisp_Object plist
, Lisp_Object prop
)
2694 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2697 plist
= XCDR (plist
);
2698 plist
= CDR (plist
);
2703 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2704 doc
: /* In WIDGET, set PROPERTY to VALUE.
2705 The value can later be retrieved with `widget-get'. */)
2706 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2708 CHECK_CONS (widget
);
2709 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2713 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2714 doc
: /* In WIDGET, get the value of PROPERTY.
2715 The value could either be specified when the widget was created, or
2716 later with `widget-put'. */)
2717 (Lisp_Object widget
, Lisp_Object property
)
2725 CHECK_CONS (widget
);
2726 tmp
= Fplist_member (XCDR (widget
), property
);
2732 tmp
= XCAR (widget
);
2735 widget
= Fget (tmp
, Qwidget_type
);
2739 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2740 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2741 ARGS are passed as extra arguments to the function.
2742 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2743 (ptrdiff_t nargs
, Lisp_Object
*args
)
2745 /* This function can GC. */
2746 Lisp_Object newargs
[3];
2747 struct gcpro gcpro1
, gcpro2
;
2750 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2751 newargs
[1] = args
[0];
2752 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2753 GCPRO2 (newargs
[0], newargs
[2]);
2754 result
= Fapply (3, newargs
);
2759 #ifdef HAVE_LANGINFO_CODESET
2760 #include <langinfo.h>
2763 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2764 doc
: /* Access locale data ITEM for the current C locale, if available.
2765 ITEM should be one of the following:
2767 `codeset', returning the character set as a string (locale item CODESET);
2769 `days', returning a 7-element vector of day names (locale items DAY_n);
2771 `months', returning a 12-element vector of month names (locale items MON_n);
2773 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2774 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2776 If the system can't provide such information through a call to
2777 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2779 See also Info node `(libc)Locales'.
2781 The data read from the system are decoded using `locale-coding-system'. */)
2785 #ifdef HAVE_LANGINFO_CODESET
2787 if (EQ (item
, Qcodeset
))
2789 str
= nl_langinfo (CODESET
);
2790 return build_string (str
);
2793 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2795 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2796 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2798 struct gcpro gcpro1
;
2800 synchronize_system_time_locale ();
2801 for (i
= 0; i
< 7; i
++)
2803 str
= nl_langinfo (days
[i
]);
2804 val
= build_unibyte_string (str
);
2805 /* Fixme: Is this coding system necessarily right, even if
2806 it is consistent with CODESET? If not, what to do? */
2807 Faset (v
, make_number (i
),
2808 code_convert_string_norecord (val
, Vlocale_coding_system
,
2816 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2818 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2819 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2820 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2822 struct gcpro gcpro1
;
2824 synchronize_system_time_locale ();
2825 for (i
= 0; i
< 12; i
++)
2827 str
= nl_langinfo (months
[i
]);
2828 val
= build_unibyte_string (str
);
2829 Faset (v
, make_number (i
),
2830 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2836 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2837 but is in the locale files. This could be used by ps-print. */
2839 else if (EQ (item
, Qpaper
))
2841 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2842 make_number (nl_langinfo (PAPER_HEIGHT
)));
2844 #endif /* PAPER_WIDTH */
2845 #endif /* HAVE_LANGINFO_CODESET*/
2849 /* base64 encode/decode functions (RFC 2045).
2850 Based on code from GNU recode. */
2852 #define MIME_LINE_LENGTH 76
2854 #define IS_ASCII(Character) \
2856 #define IS_BASE64(Character) \
2857 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2858 #define IS_BASE64_IGNORABLE(Character) \
2859 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2860 || (Character) == '\f' || (Character) == '\r')
2862 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2863 character or return retval if there are no characters left to
2865 #define READ_QUADRUPLET_BYTE(retval) \
2870 if (nchars_return) \
2871 *nchars_return = nchars; \
2876 while (IS_BASE64_IGNORABLE (c))
2878 /* Table of characters coding the 64 values. */
2879 static const char base64_value_to_char
[64] =
2881 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2882 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2883 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2884 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2885 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2886 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2887 '8', '9', '+', '/' /* 60-63 */
2890 /* Table of base64 values for first 128 characters. */
2891 static const short base64_char_to_value
[128] =
2893 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2894 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2895 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2896 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2897 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2898 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2899 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2900 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2901 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2902 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2903 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2904 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2905 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2908 /* The following diagram shows the logical steps by which three octets
2909 get transformed into four base64 characters.
2911 .--------. .--------. .--------.
2912 |aaaaaabb| |bbbbcccc| |ccdddddd|
2913 `--------' `--------' `--------'
2915 .--------+--------+--------+--------.
2916 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2917 `--------+--------+--------+--------'
2919 .--------+--------+--------+--------.
2920 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2921 `--------+--------+--------+--------'
2923 The octets are divided into 6 bit chunks, which are then encoded into
2924 base64 characters. */
2927 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2928 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2931 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2933 doc
: /* Base64-encode the region between BEG and END.
2934 Return the length of the encoded text.
2935 Optional third argument NO-LINE-BREAK means do not break long lines
2936 into shorter lines. */)
2937 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2940 ptrdiff_t allength
, length
;
2941 ptrdiff_t ibeg
, iend
, encoded_length
;
2942 ptrdiff_t old_pos
= PT
;
2945 validate_region (&beg
, &end
);
2947 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2948 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2949 move_gap_both (XFASTINT (beg
), ibeg
);
2951 /* We need to allocate enough room for encoding the text.
2952 We need 33 1/3% more space, plus a newline every 76
2953 characters, and then we round up. */
2954 length
= iend
- ibeg
;
2955 allength
= length
+ length
/3 + 1;
2956 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2958 encoded
= SAFE_ALLOCA (allength
);
2959 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2960 encoded
, length
, NILP (no_line_break
),
2961 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2962 if (encoded_length
> allength
)
2965 if (encoded_length
< 0)
2967 /* The encoding wasn't possible. */
2969 error ("Multibyte character in data for base64 encoding");
2972 /* Now we have encoded the region, so we insert the new contents
2973 and delete the old. (Insert first in order to preserve markers.) */
2974 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2975 insert (encoded
, encoded_length
);
2977 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2979 /* If point was outside of the region, restore it exactly; else just
2980 move to the beginning of the region. */
2981 if (old_pos
>= XFASTINT (end
))
2982 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2983 else if (old_pos
> XFASTINT (beg
))
2984 old_pos
= XFASTINT (beg
);
2987 /* We return the length of the encoded text. */
2988 return make_number (encoded_length
);
2991 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2993 doc
: /* Base64-encode STRING and return the result.
2994 Optional second argument NO-LINE-BREAK means do not break long lines
2995 into shorter lines. */)
2996 (Lisp_Object string
, Lisp_Object no_line_break
)
2998 ptrdiff_t allength
, length
, encoded_length
;
3000 Lisp_Object encoded_string
;
3003 CHECK_STRING (string
);
3005 /* We need to allocate enough room for encoding the text.
3006 We need 33 1/3% more space, plus a newline every 76
3007 characters, and then we round up. */
3008 length
= SBYTES (string
);
3009 allength
= length
+ length
/3 + 1;
3010 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3012 /* We need to allocate enough room for decoding the text. */
3013 encoded
= SAFE_ALLOCA (allength
);
3015 encoded_length
= base64_encode_1 (SSDATA (string
),
3016 encoded
, length
, NILP (no_line_break
),
3017 STRING_MULTIBYTE (string
));
3018 if (encoded_length
> allength
)
3021 if (encoded_length
< 0)
3023 /* The encoding wasn't possible. */
3025 error ("Multibyte character in data for base64 encoding");
3028 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3031 return encoded_string
;
3035 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3036 bool line_break
, bool multibyte
)
3049 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3050 if (CHAR_BYTE8_P (c
))
3051 c
= CHAR_TO_BYTE8 (c
);
3059 /* Wrap line every 76 characters. */
3063 if (counter
< MIME_LINE_LENGTH
/ 4)
3072 /* Process first byte of a triplet. */
3074 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3075 value
= (0x03 & c
) << 4;
3077 /* Process second byte of a triplet. */
3081 *e
++ = base64_value_to_char
[value
];
3089 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3090 if (CHAR_BYTE8_P (c
))
3091 c
= CHAR_TO_BYTE8 (c
);
3099 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3100 value
= (0x0f & c
) << 2;
3102 /* Process third byte of a triplet. */
3106 *e
++ = base64_value_to_char
[value
];
3113 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3114 if (CHAR_BYTE8_P (c
))
3115 c
= CHAR_TO_BYTE8 (c
);
3123 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3124 *e
++ = base64_value_to_char
[0x3f & c
];
3131 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3133 doc
: /* Base64-decode the region between BEG and END.
3134 Return the length of the decoded text.
3135 If the region can't be decoded, signal an error and don't modify the buffer. */)
3136 (Lisp_Object beg
, Lisp_Object end
)
3138 ptrdiff_t ibeg
, iend
, length
, allength
;
3140 ptrdiff_t old_pos
= PT
;
3141 ptrdiff_t decoded_length
;
3142 ptrdiff_t inserted_chars
;
3143 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3146 validate_region (&beg
, &end
);
3148 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3149 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3151 length
= iend
- ibeg
;
3153 /* We need to allocate enough room for decoding the text. If we are
3154 working on a multibyte buffer, each decoded code may occupy at
3156 allength
= multibyte
? length
* 2 : length
;
3157 decoded
= SAFE_ALLOCA (allength
);
3159 move_gap_both (XFASTINT (beg
), ibeg
);
3160 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3162 multibyte
, &inserted_chars
);
3163 if (decoded_length
> allength
)
3166 if (decoded_length
< 0)
3168 /* The decoding wasn't possible. */
3170 error ("Invalid base64 data");
3173 /* Now we have decoded the region, so we insert the new contents
3174 and delete the old. (Insert first in order to preserve markers.) */
3175 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3176 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3179 /* Delete the original text. */
3180 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3181 iend
+ decoded_length
, 1);
3183 /* If point was outside of the region, restore it exactly; else just
3184 move to the beginning of the region. */
3185 if (old_pos
>= XFASTINT (end
))
3186 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3187 else if (old_pos
> XFASTINT (beg
))
3188 old_pos
= XFASTINT (beg
);
3189 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3191 return make_number (inserted_chars
);
3194 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3196 doc
: /* Base64-decode STRING and return the result. */)
3197 (Lisp_Object string
)
3200 ptrdiff_t length
, decoded_length
;
3201 Lisp_Object decoded_string
;
3204 CHECK_STRING (string
);
3206 length
= SBYTES (string
);
3207 /* We need to allocate enough room for decoding the text. */
3208 decoded
= SAFE_ALLOCA (length
);
3210 /* The decoded result should be unibyte. */
3211 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3213 if (decoded_length
> length
)
3215 else if (decoded_length
>= 0)
3216 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3218 decoded_string
= Qnil
;
3221 if (!STRINGP (decoded_string
))
3222 error ("Invalid base64 data");
3224 return decoded_string
;
3227 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3228 MULTIBYTE, the decoded result should be in multibyte
3229 form. If NCHARS_RETURN is not NULL, store the number of produced
3230 characters in *NCHARS_RETURN. */
3233 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3234 bool multibyte
, ptrdiff_t *nchars_return
)
3236 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3239 unsigned long value
;
3240 ptrdiff_t nchars
= 0;
3244 /* Process first byte of a quadruplet. */
3246 READ_QUADRUPLET_BYTE (e
-to
);
3250 value
= base64_char_to_value
[c
] << 18;
3252 /* Process second byte of a quadruplet. */
3254 READ_QUADRUPLET_BYTE (-1);
3258 value
|= base64_char_to_value
[c
] << 12;
3260 c
= (unsigned char) (value
>> 16);
3261 if (multibyte
&& c
>= 128)
3262 e
+= BYTE8_STRING (c
, e
);
3267 /* Process third byte of a quadruplet. */
3269 READ_QUADRUPLET_BYTE (-1);
3273 READ_QUADRUPLET_BYTE (-1);
3282 value
|= base64_char_to_value
[c
] << 6;
3284 c
= (unsigned char) (0xff & value
>> 8);
3285 if (multibyte
&& c
>= 128)
3286 e
+= BYTE8_STRING (c
, e
);
3291 /* Process fourth byte of a quadruplet. */
3293 READ_QUADRUPLET_BYTE (-1);
3300 value
|= base64_char_to_value
[c
];
3302 c
= (unsigned char) (0xff & value
);
3303 if (multibyte
&& c
>= 128)
3304 e
+= BYTE8_STRING (c
, e
);
3313 /***********************************************************************
3315 ***** Hash Tables *****
3317 ***********************************************************************/
3319 /* Implemented by gerd@gnu.org. This hash table implementation was
3320 inspired by CMUCL hash tables. */
3324 1. For small tables, association lists are probably faster than
3325 hash tables because they have lower overhead.
3327 For uses of hash tables where the O(1) behavior of table
3328 operations is not a requirement, it might therefore be a good idea
3329 not to hash. Instead, we could just do a linear search in the
3330 key_and_value vector of the hash table. This could be done
3331 if a `:linear-search t' argument is given to make-hash-table. */
3334 /* The list of all weak hash tables. Don't staticpro this one. */
3336 static struct Lisp_Hash_Table
*weak_hash_tables
;
3338 /* Various symbols. */
3340 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
, Qeql
;
3341 Lisp_Object Qeq
, Qequal
;
3342 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3343 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3346 /***********************************************************************
3348 ***********************************************************************/
3350 /* If OBJ is a Lisp hash table, return a pointer to its struct
3351 Lisp_Hash_Table. Otherwise, signal an error. */
3353 static struct Lisp_Hash_Table
*
3354 check_hash_table (Lisp_Object obj
)
3356 CHECK_HASH_TABLE (obj
);
3357 return XHASH_TABLE (obj
);
3361 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3362 number. A number is "almost" a prime number if it is not divisible
3363 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3366 next_almost_prime (EMACS_INT n
)
3368 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3369 for (n
|= 1; ; n
+= 2)
3370 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3375 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3376 which USED[I] is non-zero. If found at index I in ARGS, set
3377 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3378 0. This function is used to extract a keyword/argument pair from
3379 a DEFUN parameter list. */
3382 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3386 for (i
= 1; i
< nargs
; i
++)
3387 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3398 /* Return a Lisp vector which has the same contents as VEC but has
3399 at least INCR_MIN more entries, where INCR_MIN is positive.
3400 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3401 than NITEMS_MAX. Entries in the resulting
3402 vector that are not copied from VEC are set to nil. */
3405 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3407 struct Lisp_Vector
*v
;
3408 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3409 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3410 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3411 ? nitems_max
: C_language_max
);
3412 eassert (VECTORP (vec
));
3413 eassert (0 < incr_min
&& -1 <= nitems_max
);
3414 old_size
= ASIZE (vec
);
3415 incr_max
= n_max
- old_size
;
3416 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3417 if (incr_max
< incr
)
3418 memory_full (SIZE_MAX
);
3419 new_size
= old_size
+ incr
;
3420 v
= allocate_vector (new_size
);
3421 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3422 for (i
= old_size
; i
< new_size
; ++i
)
3423 v
->contents
[i
] = Qnil
;
3424 XSETVECTOR (vec
, v
);
3429 /***********************************************************************
3431 ***********************************************************************/
3433 static struct hash_table_test hashtest_eq
;
3434 struct hash_table_test hashtest_eql
, hashtest_equal
;
3436 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3437 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3438 KEY2 are the same. */
3441 cmpfn_eql (struct hash_table_test
*ht
,
3445 return (FLOATP (key1
)
3447 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3451 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3452 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3453 KEY2 are the same. */
3456 cmpfn_equal (struct hash_table_test
*ht
,
3460 return !NILP (Fequal (key1
, key2
));
3464 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3465 HASH2 in hash table H using H->user_cmp_function. Value is true
3466 if KEY1 and KEY2 are the same. */
3469 cmpfn_user_defined (struct hash_table_test
*ht
,
3473 Lisp_Object args
[3];
3475 args
[0] = ht
->user_cmp_function
;
3478 return !NILP (Ffuncall (3, args
));
3482 /* Value is a hash code for KEY for use in hash table H which uses
3483 `eq' to compare keys. The hash code returned is guaranteed to fit
3484 in a Lisp integer. */
3487 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3489 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3493 /* Value is a hash code for KEY for use in hash table H which uses
3494 `eql' to compare keys. The hash code returned is guaranteed to fit
3495 in a Lisp integer. */
3498 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3502 hash
= sxhash (key
, 0);
3504 hash
= XHASH (key
) ^ XTYPE (key
);
3508 /* Value is a hash code for KEY for use in hash table H which uses
3509 `equal' to compare keys. The hash code returned is guaranteed to fit
3510 in a Lisp integer. */
3513 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3515 EMACS_UINT hash
= sxhash (key
, 0);
3519 /* Value is a hash code for KEY for use in hash table H which uses as
3520 user-defined function to compare keys. The hash code returned is
3521 guaranteed to fit in a Lisp integer. */
3524 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3526 Lisp_Object args
[2], hash
;
3528 args
[0] = ht
->user_hash_function
;
3530 hash
= Ffuncall (2, args
);
3531 if (!INTEGERP (hash
))
3532 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3533 return XUINT (hash
);
3536 /* An upper bound on the size of a hash table index. It must fit in
3537 ptrdiff_t and be a valid Emacs fixnum. */
3538 #define INDEX_SIZE_BOUND \
3539 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3541 /* Create and initialize a new hash table.
3543 TEST specifies the test the hash table will use to compare keys.
3544 It must be either one of the predefined tests `eq', `eql' or
3545 `equal' or a symbol denoting a user-defined test named TEST with
3546 test and hash functions USER_TEST and USER_HASH.
3548 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3550 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3551 new size when it becomes full is computed by adding REHASH_SIZE to
3552 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3553 table's new size is computed by multiplying its old size with
3556 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3557 be resized when the ratio of (number of entries in the table) /
3558 (table size) is >= REHASH_THRESHOLD.
3560 WEAK specifies the weakness of the table. If non-nil, it must be
3561 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3564 make_hash_table (struct hash_table_test test
,
3565 Lisp_Object size
, Lisp_Object rehash_size
,
3566 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3568 struct Lisp_Hash_Table
*h
;
3570 EMACS_INT index_size
, sz
;
3574 /* Preconditions. */
3575 eassert (SYMBOLP (test
.name
));
3576 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3577 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3578 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3579 eassert (FLOATP (rehash_threshold
)
3580 && 0 < XFLOAT_DATA (rehash_threshold
)
3581 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3583 if (XFASTINT (size
) == 0)
3584 size
= make_number (1);
3586 sz
= XFASTINT (size
);
3587 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3588 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3589 ? next_almost_prime (index_float
)
3590 : INDEX_SIZE_BOUND
+ 1);
3591 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3592 error ("Hash table too large");
3594 /* Allocate a table and initialize it. */
3595 h
= allocate_hash_table ();
3597 /* Initialize hash table slots. */
3600 h
->rehash_threshold
= rehash_threshold
;
3601 h
->rehash_size
= rehash_size
;
3603 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3604 h
->hash
= Fmake_vector (size
, Qnil
);
3605 h
->next
= Fmake_vector (size
, Qnil
);
3606 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3608 /* Set up the free list. */
3609 for (i
= 0; i
< sz
- 1; ++i
)
3610 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3611 h
->next_free
= make_number (0);
3613 XSET_HASH_TABLE (table
, h
);
3614 eassert (HASH_TABLE_P (table
));
3615 eassert (XHASH_TABLE (table
) == h
);
3617 /* Maybe add this hash table to the list of all weak hash tables. */
3619 h
->next_weak
= NULL
;
3622 h
->next_weak
= weak_hash_tables
;
3623 weak_hash_tables
= h
;
3630 /* Return a copy of hash table H1. Keys and values are not copied,
3631 only the table itself is. */
3634 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3637 struct Lisp_Hash_Table
*h2
;
3639 h2
= allocate_hash_table ();
3641 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3642 h2
->hash
= Fcopy_sequence (h1
->hash
);
3643 h2
->next
= Fcopy_sequence (h1
->next
);
3644 h2
->index
= Fcopy_sequence (h1
->index
);
3645 XSET_HASH_TABLE (table
, h2
);
3647 /* Maybe add this hash table to the list of all weak hash tables. */
3648 if (!NILP (h2
->weak
))
3650 h2
->next_weak
= weak_hash_tables
;
3651 weak_hash_tables
= h2
;
3658 /* Resize hash table H if it's too full. If H cannot be resized
3659 because it's already too large, throw an error. */
3662 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3664 if (NILP (h
->next_free
))
3666 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3667 EMACS_INT new_size
, index_size
, nsize
;
3671 if (INTEGERP (h
->rehash_size
))
3672 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3675 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3676 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3678 new_size
= float_new_size
;
3679 if (new_size
<= old_size
)
3680 new_size
= old_size
+ 1;
3683 new_size
= INDEX_SIZE_BOUND
+ 1;
3685 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3686 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3687 ? next_almost_prime (index_float
)
3688 : INDEX_SIZE_BOUND
+ 1);
3689 nsize
= max (index_size
, 2 * new_size
);
3690 if (INDEX_SIZE_BOUND
< nsize
)
3691 error ("Hash table too large to resize");
3693 #ifdef ENABLE_CHECKING
3694 if (HASH_TABLE_P (Vpurify_flag
)
3695 && XHASH_TABLE (Vpurify_flag
) == h
)
3697 Lisp_Object args
[2];
3698 args
[0] = build_string ("Growing hash table to: %d");
3699 args
[1] = make_number (new_size
);
3704 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3705 2 * (new_size
- old_size
), -1));
3706 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3707 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3708 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3710 /* Update the free list. Do it so that new entries are added at
3711 the end of the free list. This makes some operations like
3713 for (i
= old_size
; i
< new_size
- 1; ++i
)
3714 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3716 if (!NILP (h
->next_free
))
3718 Lisp_Object last
, next
;
3720 last
= h
->next_free
;
3721 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3725 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3728 XSETFASTINT (h
->next_free
, old_size
);
3731 for (i
= 0; i
< old_size
; ++i
)
3732 if (!NILP (HASH_HASH (h
, i
)))
3734 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3735 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3736 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3737 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3743 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3744 the hash code of KEY. Value is the index of the entry in H
3745 matching KEY, or -1 if not found. */
3748 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3750 EMACS_UINT hash_code
;
3751 ptrdiff_t start_of_bucket
;
3754 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3755 eassert ((hash_code
& ~INTMASK
) == 0);
3759 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3760 idx
= HASH_INDEX (h
, start_of_bucket
);
3762 /* We need not gcpro idx since it's either an integer or nil. */
3765 ptrdiff_t i
= XFASTINT (idx
);
3766 if (EQ (key
, HASH_KEY (h
, i
))
3768 && hash_code
== XUINT (HASH_HASH (h
, i
))
3769 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3771 idx
= HASH_NEXT (h
, i
);
3774 return NILP (idx
) ? -1 : XFASTINT (idx
);
3778 /* Put an entry into hash table H that associates KEY with VALUE.
3779 HASH is a previously computed hash code of KEY.
3780 Value is the index of the entry in H matching KEY. */
3783 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3786 ptrdiff_t start_of_bucket
, i
;
3788 eassert ((hash
& ~INTMASK
) == 0);
3790 /* Increment count after resizing because resizing may fail. */
3791 maybe_resize_hash_table (h
);
3794 /* Store key/value in the key_and_value vector. */
3795 i
= XFASTINT (h
->next_free
);
3796 h
->next_free
= HASH_NEXT (h
, i
);
3797 set_hash_key_slot (h
, i
, key
);
3798 set_hash_value_slot (h
, i
, value
);
3800 /* Remember its hash code. */
3801 set_hash_hash_slot (h
, i
, make_number (hash
));
3803 /* Add new entry to its collision chain. */
3804 start_of_bucket
= hash
% ASIZE (h
->index
);
3805 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3806 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3811 /* Remove the entry matching KEY from hash table H, if there is one. */
3814 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3816 EMACS_UINT hash_code
;
3817 ptrdiff_t start_of_bucket
;
3818 Lisp_Object idx
, prev
;
3820 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3821 eassert ((hash_code
& ~INTMASK
) == 0);
3822 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3823 idx
= HASH_INDEX (h
, start_of_bucket
);
3826 /* We need not gcpro idx, prev since they're either integers or nil. */
3829 ptrdiff_t i
= XFASTINT (idx
);
3831 if (EQ (key
, HASH_KEY (h
, i
))
3833 && hash_code
== XUINT (HASH_HASH (h
, i
))
3834 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3836 /* Take entry out of collision chain. */
3838 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3840 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3842 /* Clear slots in key_and_value and add the slots to
3844 set_hash_key_slot (h
, i
, Qnil
);
3845 set_hash_value_slot (h
, i
, Qnil
);
3846 set_hash_hash_slot (h
, i
, Qnil
);
3847 set_hash_next_slot (h
, i
, h
->next_free
);
3848 h
->next_free
= make_number (i
);
3850 eassert (h
->count
>= 0);
3856 idx
= HASH_NEXT (h
, i
);
3862 /* Clear hash table H. */
3865 hash_clear (struct Lisp_Hash_Table
*h
)
3869 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3871 for (i
= 0; i
< size
; ++i
)
3873 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3874 set_hash_key_slot (h
, i
, Qnil
);
3875 set_hash_value_slot (h
, i
, Qnil
);
3876 set_hash_hash_slot (h
, i
, Qnil
);
3879 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3880 ASET (h
->index
, i
, Qnil
);
3882 h
->next_free
= make_number (0);
3889 /************************************************************************
3891 ************************************************************************/
3893 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3894 entries from the table that don't survive the current GC.
3895 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3896 true if anything was marked. */
3899 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3901 ptrdiff_t bucket
, n
;
3904 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3907 for (bucket
= 0; bucket
< n
; ++bucket
)
3909 Lisp_Object idx
, next
, prev
;
3911 /* Follow collision chain, removing entries that
3912 don't survive this garbage collection. */
3914 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3916 ptrdiff_t i
= XFASTINT (idx
);
3917 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3918 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3921 if (EQ (h
->weak
, Qkey
))
3922 remove_p
= !key_known_to_survive_p
;
3923 else if (EQ (h
->weak
, Qvalue
))
3924 remove_p
= !value_known_to_survive_p
;
3925 else if (EQ (h
->weak
, Qkey_or_value
))
3926 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3927 else if (EQ (h
->weak
, Qkey_and_value
))
3928 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3932 next
= HASH_NEXT (h
, i
);
3934 if (remove_entries_p
)
3938 /* Take out of collision chain. */
3940 set_hash_index_slot (h
, bucket
, next
);
3942 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3944 /* Add to free list. */
3945 set_hash_next_slot (h
, i
, h
->next_free
);
3948 /* Clear key, value, and hash. */
3949 set_hash_key_slot (h
, i
, Qnil
);
3950 set_hash_value_slot (h
, i
, Qnil
);
3951 set_hash_hash_slot (h
, i
, Qnil
);
3964 /* Make sure key and value survive. */
3965 if (!key_known_to_survive_p
)
3967 mark_object (HASH_KEY (h
, i
));
3971 if (!value_known_to_survive_p
)
3973 mark_object (HASH_VALUE (h
, i
));
3984 /* Remove elements from weak hash tables that don't survive the
3985 current garbage collection. Remove weak tables that don't survive
3986 from Vweak_hash_tables. Called from gc_sweep. */
3989 sweep_weak_hash_tables (void)
3991 struct Lisp_Hash_Table
*h
, *used
, *next
;
3994 /* Mark all keys and values that are in use. Keep on marking until
3995 there is no more change. This is necessary for cases like
3996 value-weak table A containing an entry X -> Y, where Y is used in a
3997 key-weak table B, Z -> Y. If B comes after A in the list of weak
3998 tables, X -> Y might be removed from A, although when looking at B
3999 one finds that it shouldn't. */
4003 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4005 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4006 marked
|= sweep_weak_table (h
, 0);
4011 /* Remove tables and entries that aren't used. */
4012 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4014 next
= h
->next_weak
;
4016 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4018 /* TABLE is marked as used. Sweep its contents. */
4020 sweep_weak_table (h
, 1);
4022 /* Add table to the list of used weak hash tables. */
4023 h
->next_weak
= used
;
4028 weak_hash_tables
= used
;
4033 /***********************************************************************
4034 Hash Code Computation
4035 ***********************************************************************/
4037 /* Maximum depth up to which to dive into Lisp structures. */
4039 #define SXHASH_MAX_DEPTH 3
4041 /* Maximum length up to which to take list and vector elements into
4044 #define SXHASH_MAX_LEN 7
4046 /* Hash X, returning a value that fits into a Lisp integer. */
4047 #define SXHASH_REDUCE(X) \
4048 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4050 /* Return a hash for string PTR which has length LEN. The hash value
4051 can be any EMACS_UINT value. */
4054 hash_string (char const *ptr
, ptrdiff_t len
)
4056 char const *p
= ptr
;
4057 char const *end
= p
+ len
;
4059 EMACS_UINT hash
= 0;
4064 hash
= sxhash_combine (hash
, c
);
4070 /* Return a hash for string PTR which has length LEN. The hash
4071 code returned is guaranteed to fit in a Lisp integer. */
4074 sxhash_string (char const *ptr
, ptrdiff_t len
)
4076 EMACS_UINT hash
= hash_string (ptr
, len
);
4077 return SXHASH_REDUCE (hash
);
4080 /* Return a hash for the floating point value VAL. */
4083 sxhash_float (double val
)
4085 EMACS_UINT hash
= 0;
4087 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4088 + (sizeof val
% sizeof hash
!= 0))
4092 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4096 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4097 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4098 hash
= sxhash_combine (hash
, u
.word
[i
]);
4099 return SXHASH_REDUCE (hash
);
4102 /* Return a hash for list LIST. DEPTH is the current depth in the
4103 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4106 sxhash_list (Lisp_Object list
, int depth
)
4108 EMACS_UINT hash
= 0;
4111 if (depth
< SXHASH_MAX_DEPTH
)
4113 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4114 list
= XCDR (list
), ++i
)
4116 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4117 hash
= sxhash_combine (hash
, hash2
);
4122 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4123 hash
= sxhash_combine (hash
, hash2
);
4126 return SXHASH_REDUCE (hash
);
4130 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4131 the Lisp structure. */
4134 sxhash_vector (Lisp_Object vec
, int depth
)
4136 EMACS_UINT hash
= ASIZE (vec
);
4139 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4140 for (i
= 0; i
< n
; ++i
)
4142 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4143 hash
= sxhash_combine (hash
, hash2
);
4146 return SXHASH_REDUCE (hash
);
4149 /* Return a hash for bool-vector VECTOR. */
4152 sxhash_bool_vector (Lisp_Object vec
)
4154 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4157 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4158 for (i
= 0; i
< n
; ++i
)
4159 hash
= sxhash_combine (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4161 return SXHASH_REDUCE (hash
);
4165 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4166 structure. Value is an unsigned integer clipped to INTMASK. */
4169 sxhash (Lisp_Object obj
, int depth
)
4173 if (depth
> SXHASH_MAX_DEPTH
)
4176 switch (XTYPE (obj
))
4187 obj
= SYMBOL_NAME (obj
);
4191 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4194 /* This can be everything from a vector to an overlay. */
4195 case Lisp_Vectorlike
:
4197 /* According to the CL HyperSpec, two arrays are equal only if
4198 they are `eq', except for strings and bit-vectors. In
4199 Emacs, this works differently. We have to compare element
4201 hash
= sxhash_vector (obj
, depth
);
4202 else if (BOOL_VECTOR_P (obj
))
4203 hash
= sxhash_bool_vector (obj
);
4205 /* Others are `equal' if they are `eq', so let's take their
4211 hash
= sxhash_list (obj
, depth
);
4215 hash
= sxhash_float (XFLOAT_DATA (obj
));
4227 /***********************************************************************
4229 ***********************************************************************/
4232 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4233 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4236 EMACS_UINT hash
= sxhash (obj
, 0);
4237 return make_number (hash
);
4241 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4242 doc
: /* Create and return a new hash table.
4244 Arguments are specified as keyword/argument pairs. The following
4245 arguments are defined:
4247 :test TEST -- TEST must be a symbol that specifies how to compare
4248 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4249 `equal'. User-supplied test and hash functions can be specified via
4250 `define-hash-table-test'.
4252 :size SIZE -- A hint as to how many elements will be put in the table.
4255 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4256 fills up. If REHASH-SIZE is an integer, increase the size by that
4257 amount. If it is a float, it must be > 1.0, and the new size is the
4258 old size multiplied by that factor. Default is 1.5.
4260 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4261 Resize the hash table when the ratio (number of entries / table size)
4262 is greater than or equal to THRESHOLD. Default is 0.8.
4264 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4265 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4266 returned is a weak table. Key/value pairs are removed from a weak
4267 hash table when there are no non-weak references pointing to their
4268 key, value, one of key or value, or both key and value, depending on
4269 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4272 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4273 (ptrdiff_t nargs
, Lisp_Object
*args
)
4275 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4276 struct hash_table_test testdesc
;
4280 /* The vector `used' is used to keep track of arguments that
4281 have been consumed. */
4282 used
= alloca (nargs
* sizeof *used
);
4283 memset (used
, 0, nargs
* sizeof *used
);
4285 /* See if there's a `:test TEST' among the arguments. */
4286 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4287 test
= i
? args
[i
] : Qeql
;
4289 testdesc
= hashtest_eq
;
4290 else if (EQ (test
, Qeql
))
4291 testdesc
= hashtest_eql
;
4292 else if (EQ (test
, Qequal
))
4293 testdesc
= hashtest_equal
;
4296 /* See if it is a user-defined test. */
4299 prop
= Fget (test
, Qhash_table_test
);
4300 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4301 signal_error ("Invalid hash table test", test
);
4302 testdesc
.name
= test
;
4303 testdesc
.user_cmp_function
= XCAR (prop
);
4304 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4305 testdesc
.hashfn
= hashfn_user_defined
;
4306 testdesc
.cmpfn
= cmpfn_user_defined
;
4309 /* See if there's a `:size SIZE' argument. */
4310 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4311 size
= i
? args
[i
] : Qnil
;
4313 size
= make_number (DEFAULT_HASH_SIZE
);
4314 else if (!INTEGERP (size
) || XINT (size
) < 0)
4315 signal_error ("Invalid hash table size", size
);
4317 /* Look for `:rehash-size SIZE'. */
4318 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4319 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4320 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4321 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4322 signal_error ("Invalid hash table rehash size", rehash_size
);
4324 /* Look for `:rehash-threshold THRESHOLD'. */
4325 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4326 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4327 if (! (FLOATP (rehash_threshold
)
4328 && 0 < XFLOAT_DATA (rehash_threshold
)
4329 && XFLOAT_DATA (rehash_threshold
) <= 1))
4330 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4332 /* Look for `:weakness WEAK'. */
4333 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4334 weak
= i
? args
[i
] : Qnil
;
4336 weak
= Qkey_and_value
;
4339 && !EQ (weak
, Qvalue
)
4340 && !EQ (weak
, Qkey_or_value
)
4341 && !EQ (weak
, Qkey_and_value
))
4342 signal_error ("Invalid hash table weakness", weak
);
4344 /* Now, all args should have been used up, or there's a problem. */
4345 for (i
= 0; i
< nargs
; ++i
)
4347 signal_error ("Invalid argument list", args
[i
]);
4349 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4353 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4354 doc
: /* Return a copy of hash table TABLE. */)
4357 return copy_hash_table (check_hash_table (table
));
4361 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4362 doc
: /* Return the number of elements in TABLE. */)
4365 return make_number (check_hash_table (table
)->count
);
4369 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4370 Shash_table_rehash_size
, 1, 1, 0,
4371 doc
: /* Return the current rehash size of TABLE. */)
4374 return check_hash_table (table
)->rehash_size
;
4378 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4379 Shash_table_rehash_threshold
, 1, 1, 0,
4380 doc
: /* Return the current rehash threshold of TABLE. */)
4383 return check_hash_table (table
)->rehash_threshold
;
4387 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4388 doc
: /* Return the size of TABLE.
4389 The size can be used as an argument to `make-hash-table' to create
4390 a hash table than can hold as many elements as TABLE holds
4391 without need for resizing. */)
4394 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4395 return make_number (HASH_TABLE_SIZE (h
));
4399 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4400 doc
: /* Return the test TABLE uses. */)
4403 return check_hash_table (table
)->test
.name
;
4407 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4409 doc
: /* Return the weakness of TABLE. */)
4412 return check_hash_table (table
)->weak
;
4416 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4417 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4420 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4424 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4425 doc
: /* Clear hash table TABLE and return it. */)
4428 hash_clear (check_hash_table (table
));
4429 /* Be compatible with XEmacs. */
4434 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4435 doc
: /* Look up KEY in TABLE and return its associated value.
4436 If KEY is not found, return DFLT which defaults to nil. */)
4437 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4439 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4440 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4441 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4445 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4446 doc
: /* Associate KEY with VALUE in hash table TABLE.
4447 If KEY is already present in table, replace its current value with
4448 VALUE. In any case, return VALUE. */)
4449 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4451 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4455 i
= hash_lookup (h
, key
, &hash
);
4457 set_hash_value_slot (h
, i
, value
);
4459 hash_put (h
, key
, value
, hash
);
4465 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4466 doc
: /* Remove KEY from TABLE. */)
4467 (Lisp_Object key
, Lisp_Object table
)
4469 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4470 hash_remove_from_table (h
, key
);
4475 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4476 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4477 FUNCTION is called with two arguments, KEY and VALUE. */)
4478 (Lisp_Object function
, Lisp_Object table
)
4480 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4481 Lisp_Object args
[3];
4484 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4485 if (!NILP (HASH_HASH (h
, i
)))
4488 args
[1] = HASH_KEY (h
, i
);
4489 args
[2] = HASH_VALUE (h
, i
);
4497 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4498 Sdefine_hash_table_test
, 3, 3, 0,
4499 doc
: /* Define a new hash table test with name NAME, a symbol.
4501 In hash tables created with NAME specified as test, use TEST to
4502 compare keys, and HASH for computing hash codes of keys.
4504 TEST must be a function taking two arguments and returning non-nil if
4505 both arguments are the same. HASH must be a function taking one
4506 argument and return an integer that is the hash code of the argument.
4507 Hash code computation should use the whole value range of integers,
4508 including negative integers. */)
4509 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4511 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4516 /************************************************************************
4517 MD5, SHA-1, and SHA-2
4518 ************************************************************************/
4525 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4528 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4532 EMACS_INT start_char
= 0, end_char
= 0;
4533 ptrdiff_t start_byte
, end_byte
;
4534 register EMACS_INT b
, e
;
4535 register struct buffer
*bp
;
4538 void *(*hash_func
) (const char *, size_t, void *);
4541 CHECK_SYMBOL (algorithm
);
4543 if (STRINGP (object
))
4545 if (NILP (coding_system
))
4547 /* Decide the coding-system to encode the data with. */
4549 if (STRING_MULTIBYTE (object
))
4550 /* use default, we can't guess correct value */
4551 coding_system
= preferred_coding_system ();
4553 coding_system
= Qraw_text
;
4556 if (NILP (Fcoding_system_p (coding_system
)))
4558 /* Invalid coding system. */
4560 if (!NILP (noerror
))
4561 coding_system
= Qraw_text
;
4563 xsignal1 (Qcoding_system_error
, coding_system
);
4566 if (STRING_MULTIBYTE (object
))
4567 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4569 size
= SCHARS (object
);
4573 CHECK_NUMBER (start
);
4575 start_char
= XINT (start
);
4587 end_char
= XINT (end
);
4593 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4594 args_out_of_range_3 (object
, make_number (start_char
),
4595 make_number (end_char
));
4597 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4599 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4603 struct buffer
*prev
= current_buffer
;
4605 record_unwind_current_buffer ();
4607 CHECK_BUFFER (object
);
4609 bp
= XBUFFER (object
);
4610 set_buffer_internal (bp
);
4616 CHECK_NUMBER_COERCE_MARKER (start
);
4624 CHECK_NUMBER_COERCE_MARKER (end
);
4629 temp
= b
, b
= e
, e
= temp
;
4631 if (!(BEGV
<= b
&& e
<= ZV
))
4632 args_out_of_range (start
, end
);
4634 if (NILP (coding_system
))
4636 /* Decide the coding-system to encode the data with.
4637 See fileio.c:Fwrite-region */
4639 if (!NILP (Vcoding_system_for_write
))
4640 coding_system
= Vcoding_system_for_write
;
4643 bool force_raw_text
= 0;
4645 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4646 if (NILP (coding_system
)
4647 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4649 coding_system
= Qnil
;
4650 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4654 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4656 /* Check file-coding-system-alist. */
4657 Lisp_Object args
[4], val
;
4659 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4660 args
[3] = Fbuffer_file_name (object
);
4661 val
= Ffind_operation_coding_system (4, args
);
4662 if (CONSP (val
) && !NILP (XCDR (val
)))
4663 coding_system
= XCDR (val
);
4666 if (NILP (coding_system
)
4667 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4669 /* If we still have not decided a coding system, use the
4670 default value of buffer-file-coding-system. */
4671 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4675 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4676 /* Confirm that VAL can surely encode the current region. */
4677 coding_system
= call4 (Vselect_safe_coding_system_function
,
4678 make_number (b
), make_number (e
),
4679 coding_system
, Qnil
);
4682 coding_system
= Qraw_text
;
4685 if (NILP (Fcoding_system_p (coding_system
)))
4687 /* Invalid coding system. */
4689 if (!NILP (noerror
))
4690 coding_system
= Qraw_text
;
4692 xsignal1 (Qcoding_system_error
, coding_system
);
4696 object
= make_buffer_string (b
, e
, 0);
4697 set_buffer_internal (prev
);
4698 /* Discard the unwind protect for recovering the current
4702 if (STRING_MULTIBYTE (object
))
4703 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4705 end_byte
= SBYTES (object
);
4708 if (EQ (algorithm
, Qmd5
))
4710 digest_size
= MD5_DIGEST_SIZE
;
4711 hash_func
= md5_buffer
;
4713 else if (EQ (algorithm
, Qsha1
))
4715 digest_size
= SHA1_DIGEST_SIZE
;
4716 hash_func
= sha1_buffer
;
4718 else if (EQ (algorithm
, Qsha224
))
4720 digest_size
= SHA224_DIGEST_SIZE
;
4721 hash_func
= sha224_buffer
;
4723 else if (EQ (algorithm
, Qsha256
))
4725 digest_size
= SHA256_DIGEST_SIZE
;
4726 hash_func
= sha256_buffer
;
4728 else if (EQ (algorithm
, Qsha384
))
4730 digest_size
= SHA384_DIGEST_SIZE
;
4731 hash_func
= sha384_buffer
;
4733 else if (EQ (algorithm
, Qsha512
))
4735 digest_size
= SHA512_DIGEST_SIZE
;
4736 hash_func
= sha512_buffer
;
4739 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4741 /* allocate 2 x digest_size so that it can be re-used to hold the
4743 digest
= make_uninit_string (digest_size
* 2);
4745 hash_func (SSDATA (object
) + start_byte
,
4746 end_byte
- start_byte
,
4751 unsigned char *p
= SDATA (digest
);
4752 for (i
= digest_size
- 1; i
>= 0; i
--)
4754 static char const hexdigit
[16] = "0123456789abcdef";
4756 p
[2 * i
] = hexdigit
[p_i
>> 4];
4757 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4762 return make_unibyte_string (SSDATA (digest
), digest_size
);
4765 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4766 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4768 A message digest is a cryptographic checksum of a document, and the
4769 algorithm to calculate it is defined in RFC 1321.
4771 The two optional arguments START and END are character positions
4772 specifying for which part of OBJECT the message digest should be
4773 computed. If nil or omitted, the digest is computed for the whole
4776 The MD5 message digest is computed from the result of encoding the
4777 text in a coding system, not directly from the internal Emacs form of
4778 the text. The optional fourth argument CODING-SYSTEM specifies which
4779 coding system to encode the text with. It should be the same coding
4780 system that you used or will use when actually writing the text into a
4783 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4784 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4785 system would be chosen by default for writing this text into a file.
4787 If OBJECT is a string, the most preferred coding system (see the
4788 command `prefer-coding-system') is used.
4790 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4791 guesswork fails. Normally, an error is signaled in such case. */)
4792 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4794 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4797 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4798 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4799 ALGORITHM is a symbol specifying the hash to use:
4800 md5, sha1, sha224, sha256, sha384 or sha512.
4802 The two optional arguments START and END are positions specifying for
4803 which part of OBJECT to compute the hash. If nil or omitted, uses the
4806 If BINARY is non-nil, returns a string in binary form. */)
4807 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4809 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4815 DEFSYM (Qmd5
, "md5");
4816 DEFSYM (Qsha1
, "sha1");
4817 DEFSYM (Qsha224
, "sha224");
4818 DEFSYM (Qsha256
, "sha256");
4819 DEFSYM (Qsha384
, "sha384");
4820 DEFSYM (Qsha512
, "sha512");
4822 /* Hash table stuff. */
4823 DEFSYM (Qhash_table_p
, "hash-table-p");
4825 DEFSYM (Qeql
, "eql");
4826 DEFSYM (Qequal
, "equal");
4827 DEFSYM (QCtest
, ":test");
4828 DEFSYM (QCsize
, ":size");
4829 DEFSYM (QCrehash_size
, ":rehash-size");
4830 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4831 DEFSYM (QCweakness
, ":weakness");
4832 DEFSYM (Qkey
, "key");
4833 DEFSYM (Qvalue
, "value");
4834 DEFSYM (Qhash_table_test
, "hash-table-test");
4835 DEFSYM (Qkey_or_value
, "key-or-value");
4836 DEFSYM (Qkey_and_value
, "key-and-value");
4839 defsubr (&Smake_hash_table
);
4840 defsubr (&Scopy_hash_table
);
4841 defsubr (&Shash_table_count
);
4842 defsubr (&Shash_table_rehash_size
);
4843 defsubr (&Shash_table_rehash_threshold
);
4844 defsubr (&Shash_table_size
);
4845 defsubr (&Shash_table_test
);
4846 defsubr (&Shash_table_weakness
);
4847 defsubr (&Shash_table_p
);
4848 defsubr (&Sclrhash
);
4849 defsubr (&Sgethash
);
4850 defsubr (&Sputhash
);
4851 defsubr (&Sremhash
);
4852 defsubr (&Smaphash
);
4853 defsubr (&Sdefine_hash_table_test
);
4855 DEFSYM (Qstring_lessp
, "string-lessp");
4856 DEFSYM (Qprovide
, "provide");
4857 DEFSYM (Qrequire
, "require");
4858 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4859 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4860 DEFSYM (Qwidget_type
, "widget-type");
4862 staticpro (&string_char_byte_cache_string
);
4863 string_char_byte_cache_string
= Qnil
;
4865 require_nesting_list
= Qnil
;
4866 staticpro (&require_nesting_list
);
4868 Fset (Qyes_or_no_p_history
, Qnil
);
4870 DEFVAR_LISP ("features", Vfeatures
,
4871 doc
: /* A list of symbols which are the features of the executing Emacs.
4872 Used by `featurep' and `require', and altered by `provide'. */);
4873 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4874 DEFSYM (Qsubfeatures
, "subfeatures");
4876 #ifdef HAVE_LANGINFO_CODESET
4877 DEFSYM (Qcodeset
, "codeset");
4878 DEFSYM (Qdays
, "days");
4879 DEFSYM (Qmonths
, "months");
4880 DEFSYM (Qpaper
, "paper");
4881 #endif /* HAVE_LANGINFO_CODESET */
4883 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4884 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4885 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4886 invoked by mouse clicks and mouse menu items.
4888 On some platforms, file selection dialogs are also enabled if this is
4892 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4893 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4894 This applies to commands from menus and tool bar buttons even when
4895 they are initiated from the keyboard. If `use-dialog-box' is nil,
4896 that disables the use of a file dialog, regardless of the value of
4898 use_file_dialog
= 1;
4900 defsubr (&Sidentity
);
4903 defsubr (&Ssafe_length
);
4904 defsubr (&Sstring_bytes
);
4905 defsubr (&Sstring_equal
);
4906 defsubr (&Scompare_strings
);
4907 defsubr (&Sstring_lessp
);
4910 defsubr (&Svconcat
);
4911 defsubr (&Scopy_sequence
);
4912 defsubr (&Sstring_make_multibyte
);
4913 defsubr (&Sstring_make_unibyte
);
4914 defsubr (&Sstring_as_multibyte
);
4915 defsubr (&Sstring_as_unibyte
);
4916 defsubr (&Sstring_to_multibyte
);
4917 defsubr (&Sstring_to_unibyte
);
4918 defsubr (&Scopy_alist
);
4919 defsubr (&Ssubstring
);
4920 defsubr (&Ssubstring_no_properties
);
4933 defsubr (&Snreverse
);
4934 defsubr (&Sreverse
);
4936 defsubr (&Splist_get
);
4938 defsubr (&Splist_put
);
4940 defsubr (&Slax_plist_get
);
4941 defsubr (&Slax_plist_put
);
4944 defsubr (&Sequal_including_properties
);
4945 defsubr (&Sfillarray
);
4946 defsubr (&Sclear_string
);
4950 defsubr (&Smapconcat
);
4951 defsubr (&Syes_or_no_p
);
4952 defsubr (&Sload_average
);
4953 defsubr (&Sfeaturep
);
4954 defsubr (&Srequire
);
4955 defsubr (&Sprovide
);
4956 defsubr (&Splist_member
);
4957 defsubr (&Swidget_put
);
4958 defsubr (&Swidget_get
);
4959 defsubr (&Swidget_apply
);
4960 defsubr (&Sbase64_encode_region
);
4961 defsubr (&Sbase64_decode_region
);
4962 defsubr (&Sbase64_encode_string
);
4963 defsubr (&Sbase64_decode_string
);
4965 defsubr (&Ssecure_hash
);
4966 defsubr (&Slocale_info
);
4969 struct hash_table_test
4970 eq
= { Qeq
, Qnil
, Qnil
, NULL
, hashfn_eq
},
4971 eql
= { Qeql
, Qnil
, Qnil
, cmpfn_eql
, hashfn_eql
},
4972 equal
= { Qequal
, Qnil
, Qnil
, cmpfn_equal
, hashfn_equal
};
4975 hashtest_equal
= equal
;