1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
43 #endif /* HAVE_MENUS */
46 #define NULL ((POINTER_TYPE *)0)
49 Lisp_Object Qstring_lessp
;
50 static Lisp_Object Qprovide
, Qrequire
;
51 static Lisp_Object Qyes_or_no_p_history
;
52 Lisp_Object Qcursor_in_echo_area
;
53 static Lisp_Object Qwidget_type
;
54 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
56 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
58 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
64 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
65 doc
: /* Return the argument unchanged. */)
71 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
72 doc
: /* Return a pseudo-random number.
73 All integers representable in Lisp are equally likely.
74 On most systems, this is 29 bits' worth.
75 With positive integer LIMIT, return random number in interval [0,LIMIT).
76 With argument t, set the random number seed from the current time and pid.
77 Other values of LIMIT are ignored. */)
81 Lisp_Object lispy_val
;
87 seed_random (getpid () ^ EMACS_SECS (t
) ^ EMACS_USECS (t
));
90 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
92 /* Try to take our random number from the higher bits of VAL,
93 not the lower, since (says Gentzel) the low bits of `random'
94 are less random than the higher ones. We do this by using the
95 quotient rather than the remainder. At the high end of the RNG
96 it's possible to get a quotient larger than n; discarding
97 these values eliminates the bias that would otherwise appear
98 when using a large n. */
99 EMACS_INT denominator
= (INTMASK
+ 1) / XFASTINT (limit
);
101 val
= get_random () / denominator
;
102 while (val
>= XFASTINT (limit
));
106 XSETINT (lispy_val
, val
);
110 /* Heuristic on how many iterations of a tight loop can be safely done
111 before it's time to do a QUIT. This must be a power of 2. */
112 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
114 /* Random data-structure functions */
116 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
117 doc
: /* Return the length of vector, list or string SEQUENCE.
118 A byte-code function object is also allowed.
119 If the string contains multibyte characters, this is not necessarily
120 the number of bytes in the string; it is the number of characters.
121 To get the number of bytes, use `string-bytes'. */)
122 (register Lisp_Object sequence
)
124 register Lisp_Object val
;
126 if (STRINGP (sequence
))
127 XSETFASTINT (val
, SCHARS (sequence
));
128 else if (VECTORP (sequence
))
129 XSETFASTINT (val
, ASIZE (sequence
));
130 else if (CHAR_TABLE_P (sequence
))
131 XSETFASTINT (val
, MAX_CHAR
);
132 else if (BOOL_VECTOR_P (sequence
))
133 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
134 else if (COMPILEDP (sequence
))
135 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
136 else if (CONSP (sequence
))
143 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
145 if (MOST_POSITIVE_FIXNUM
< i
)
146 error ("List too long");
149 sequence
= XCDR (sequence
);
151 while (CONSP (sequence
));
153 CHECK_LIST_END (sequence
, sequence
);
155 val
= make_number (i
);
157 else if (NILP (sequence
))
158 XSETFASTINT (val
, 0);
160 wrong_type_argument (Qsequencep
, sequence
);
165 /* This does not check for quits. That is safe since it must terminate. */
167 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
168 doc
: /* Return the length of a list, but avoid error or infinite loop.
169 This function never gets an error. If LIST is not really a list,
170 it returns 0. If LIST is circular, it returns a finite value
171 which is at least the number of distinct elements. */)
174 Lisp_Object tail
, halftail
;
179 return make_number (0);
181 /* halftail is used to detect circular lists. */
182 for (tail
= halftail
= list
; ; )
187 if (EQ (tail
, halftail
))
190 if ((lolen
& 1) == 0)
192 halftail
= XCDR (halftail
);
193 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
197 hilen
+= UINTMAX_MAX
+ 1.0;
202 /* If the length does not fit into a fixnum, return a float.
203 On all known practical machines this returns an upper bound on
205 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
208 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
209 doc
: /* Return the number of bytes in STRING.
210 If STRING is multibyte, this may be greater than the length of STRING. */)
213 CHECK_STRING (string
);
214 return make_number (SBYTES (string
));
217 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
218 doc
: /* Return t if two strings have identical contents.
219 Case is significant, but text properties are ignored.
220 Symbols are also allowed; their print names are used instead. */)
221 (register Lisp_Object s1
, Lisp_Object s2
)
224 s1
= SYMBOL_NAME (s1
);
226 s2
= SYMBOL_NAME (s2
);
230 if (SCHARS (s1
) != SCHARS (s2
)
231 || SBYTES (s1
) != SBYTES (s2
)
232 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
237 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
238 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
239 In string STR1, skip the first START1 characters and stop at END1.
240 In string STR2, skip the first START2 characters and stop at END2.
241 END1 and END2 default to the full lengths of the respective strings.
243 Case is significant in this comparison if IGNORE-CASE is nil.
244 Unibyte strings are converted to multibyte for comparison.
246 The value is t if the strings (or specified portions) match.
247 If string STR1 is less, the value is a negative number N;
248 - 1 - N is the number of characters that match at the beginning.
249 If string STR1 is greater, the value is a positive number N;
250 N - 1 is the number of characters that match at the beginning. */)
251 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
253 register ptrdiff_t end1_char
, end2_char
;
254 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
259 start1
= make_number (0);
261 start2
= make_number (0);
262 CHECK_NATNUM (start1
);
263 CHECK_NATNUM (start2
);
269 end1_char
= SCHARS (str1
);
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
272 if (end1_char
< XINT (start1
))
273 args_out_of_range (str1
, start1
);
275 end2_char
= SCHARS (str2
);
276 if (! NILP (end2
) && end2_char
> XINT (end2
))
277 end2_char
= XINT (end2
);
278 if (end2_char
< XINT (start2
))
279 args_out_of_range (str2
, start2
);
284 i1_byte
= string_char_to_byte (str1
, i1
);
285 i2_byte
= string_char_to_byte (str2
, i2
);
287 while (i1
< end1_char
&& i2
< end2_char
)
289 /* When we find a mismatch, we must compare the
290 characters, not just the bytes. */
293 if (STRING_MULTIBYTE (str1
))
294 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
297 c1
= SREF (str1
, i1
++);
298 MAKE_CHAR_MULTIBYTE (c1
);
301 if (STRING_MULTIBYTE (str2
))
302 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
305 c2
= SREF (str2
, i2
++);
306 MAKE_CHAR_MULTIBYTE (c2
);
312 if (! NILP (ignore_case
))
316 tem
= Fupcase (make_number (c1
));
318 tem
= Fupcase (make_number (c2
));
325 /* Note that I1 has already been incremented
326 past the character that we are comparing;
327 hence we don't add or subtract 1 here. */
329 return make_number (- i1
+ XINT (start1
));
331 return make_number (i1
- XINT (start1
));
335 return make_number (i1
- XINT (start1
) + 1);
337 return make_number (- i1
+ XINT (start1
) - 1);
342 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
343 doc
: /* Return t if first arg string is less than second in lexicographic order.
345 Symbols are also allowed; their print names are used instead. */)
346 (register Lisp_Object s1
, Lisp_Object s2
)
348 register ptrdiff_t end
;
349 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
352 s1
= SYMBOL_NAME (s1
);
354 s2
= SYMBOL_NAME (s2
);
358 i1
= i1_byte
= i2
= i2_byte
= 0;
361 if (end
> SCHARS (s2
))
366 /* When we find a mismatch, we must compare the
367 characters, not just the bytes. */
370 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
371 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
374 return c1
< c2
? Qt
: Qnil
;
376 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
379 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
380 enum Lisp_Type target_type
, int last_special
);
384 concat2 (Lisp_Object s1
, Lisp_Object s2
)
389 return concat (2, args
, Lisp_String
, 0);
394 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
400 return concat (3, args
, Lisp_String
, 0);
403 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
404 doc
: /* Concatenate all the arguments and make the result a list.
405 The result is a list whose elements are the elements of all the arguments.
406 Each argument may be a list, vector or string.
407 The last argument is not copied, just used as the tail of the new list.
408 usage: (append &rest SEQUENCES) */)
409 (ptrdiff_t nargs
, Lisp_Object
*args
)
411 return concat (nargs
, args
, Lisp_Cons
, 1);
414 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
415 doc
: /* Concatenate all the arguments and make the result a string.
416 The result is a string whose elements are the elements of all the arguments.
417 Each argument may be a string or a list or vector of characters (integers).
418 usage: (concat &rest SEQUENCES) */)
419 (ptrdiff_t nargs
, Lisp_Object
*args
)
421 return concat (nargs
, args
, Lisp_String
, 0);
424 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
425 doc
: /* Concatenate all the arguments and make the result a vector.
426 The result is a vector whose elements are the elements of all the arguments.
427 Each argument may be a list, vector or string.
428 usage: (vconcat &rest SEQUENCES) */)
429 (ptrdiff_t nargs
, Lisp_Object
*args
)
431 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
435 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
436 doc
: /* Return a copy of a list, vector, string or char-table.
437 The elements of a list or vector are not copied; they are shared
438 with the original. */)
441 if (NILP (arg
)) return arg
;
443 if (CHAR_TABLE_P (arg
))
445 return copy_char_table (arg
);
448 if (BOOL_VECTOR_P (arg
))
451 ptrdiff_t size_in_chars
452 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
453 / BOOL_VECTOR_BITS_PER_CHAR
);
455 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
456 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
461 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
462 wrong_type_argument (Qsequencep
, arg
);
464 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
467 /* This structure holds information of an argument of `concat' that is
468 a string and has text properties to be copied. */
471 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
472 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
473 ptrdiff_t to
; /* refer to VAL (the target string) */
477 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
478 enum Lisp_Type target_type
, int last_special
)
481 register Lisp_Object tail
;
482 register Lisp_Object
this;
484 ptrdiff_t toindex_byte
= 0;
485 register EMACS_INT result_len
;
486 register EMACS_INT result_len_byte
;
488 Lisp_Object last_tail
;
491 /* When we make a multibyte string, we can't copy text properties
492 while concatenating each string because the length of resulting
493 string can't be decided until we finish the whole concatenation.
494 So, we record strings that have text properties to be copied
495 here, and copy the text properties after the concatenation. */
496 struct textprop_rec
*textprops
= NULL
;
497 /* Number of elements in textprops. */
498 ptrdiff_t num_textprops
= 0;
503 /* In append, the last arg isn't treated like the others */
504 if (last_special
&& nargs
> 0)
507 last_tail
= args
[nargs
];
512 /* Check each argument. */
513 for (argnum
= 0; argnum
< nargs
; argnum
++)
516 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
517 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
518 wrong_type_argument (Qsequencep
, this);
521 /* Compute total length in chars of arguments in RESULT_LEN.
522 If desired output is a string, also compute length in bytes
523 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
524 whether the result should be a multibyte string. */
528 for (argnum
= 0; argnum
< nargs
; argnum
++)
532 len
= XFASTINT (Flength (this));
533 if (target_type
== Lisp_String
)
535 /* We must count the number of bytes needed in the string
536 as well as the number of characters. */
540 ptrdiff_t this_len_byte
;
542 if (VECTORP (this) || COMPILEDP (this))
543 for (i
= 0; i
< len
; i
++)
546 CHECK_CHARACTER (ch
);
548 this_len_byte
= CHAR_BYTES (c
);
549 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
551 result_len_byte
+= this_len_byte
;
552 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
555 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
556 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
557 else if (CONSP (this))
558 for (; CONSP (this); this = XCDR (this))
561 CHECK_CHARACTER (ch
);
563 this_len_byte
= CHAR_BYTES (c
);
564 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
566 result_len_byte
+= this_len_byte
;
567 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
570 else if (STRINGP (this))
572 if (STRING_MULTIBYTE (this))
575 this_len_byte
= SBYTES (this);
578 this_len_byte
= count_size_as_multibyte (SDATA (this),
580 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
582 result_len_byte
+= this_len_byte
;
587 if (MOST_POSITIVE_FIXNUM
< result_len
)
588 memory_full (SIZE_MAX
);
591 if (! some_multibyte
)
592 result_len_byte
= result_len
;
594 /* Create the output object. */
595 if (target_type
== Lisp_Cons
)
596 val
= Fmake_list (make_number (result_len
), Qnil
);
597 else if (target_type
== Lisp_Vectorlike
)
598 val
= Fmake_vector (make_number (result_len
), Qnil
);
599 else if (some_multibyte
)
600 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
602 val
= make_uninit_string (result_len
);
604 /* In `append', if all but last arg are nil, return last arg. */
605 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
608 /* Copy the contents of the args into the result. */
610 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
612 toindex
= 0, toindex_byte
= 0;
616 SAFE_NALLOCA (textprops
, 1, nargs
);
618 for (argnum
= 0; argnum
< nargs
; argnum
++)
621 ptrdiff_t thisleni
= 0;
622 register ptrdiff_t thisindex
= 0;
623 register ptrdiff_t thisindex_byte
= 0;
627 thislen
= Flength (this), thisleni
= XINT (thislen
);
629 /* Between strings of the same kind, copy fast. */
630 if (STRINGP (this) && STRINGP (val
)
631 && STRING_MULTIBYTE (this) == some_multibyte
)
633 ptrdiff_t thislen_byte
= SBYTES (this);
635 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
636 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
638 textprops
[num_textprops
].argnum
= argnum
;
639 textprops
[num_textprops
].from
= 0;
640 textprops
[num_textprops
++].to
= toindex
;
642 toindex_byte
+= thislen_byte
;
645 /* Copy a single-byte string to a multibyte string. */
646 else if (STRINGP (this) && STRINGP (val
))
648 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
650 textprops
[num_textprops
].argnum
= argnum
;
651 textprops
[num_textprops
].from
= 0;
652 textprops
[num_textprops
++].to
= toindex
;
654 toindex_byte
+= copy_text (SDATA (this),
655 SDATA (val
) + toindex_byte
,
656 SCHARS (this), 0, 1);
660 /* Copy element by element. */
663 register Lisp_Object elt
;
665 /* Fetch next element of `this' arg into `elt', or break if
666 `this' is exhausted. */
667 if (NILP (this)) break;
669 elt
= XCAR (this), this = XCDR (this);
670 else if (thisindex
>= thisleni
)
672 else if (STRINGP (this))
675 if (STRING_MULTIBYTE (this))
676 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
681 c
= SREF (this, thisindex
); thisindex
++;
682 if (some_multibyte
&& !ASCII_CHAR_P (c
))
683 c
= BYTE8_TO_CHAR (c
);
685 XSETFASTINT (elt
, c
);
687 else if (BOOL_VECTOR_P (this))
690 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
691 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
699 elt
= AREF (this, thisindex
);
703 /* Store this element into the result. */
710 else if (VECTORP (val
))
712 ASET (val
, toindex
, elt
);
718 CHECK_CHARACTER (elt
);
721 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
723 SSET (val
, toindex_byte
++, c
);
729 XSETCDR (prev
, last_tail
);
731 if (num_textprops
> 0)
734 ptrdiff_t last_to_end
= -1;
736 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
738 this = args
[textprops
[argnum
].argnum
];
739 props
= text_property_list (this,
741 make_number (SCHARS (this)),
743 /* If successive arguments have properties, be sure that the
744 value of `composition' property be the copy. */
745 if (last_to_end
== textprops
[argnum
].to
)
746 make_composition_value_copy (props
);
747 add_text_properties_from_list (val
, props
,
748 make_number (textprops
[argnum
].to
));
749 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
757 static Lisp_Object string_char_byte_cache_string
;
758 static ptrdiff_t string_char_byte_cache_charpos
;
759 static ptrdiff_t string_char_byte_cache_bytepos
;
762 clear_string_char_byte_cache (void)
764 string_char_byte_cache_string
= Qnil
;
767 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
770 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
773 ptrdiff_t best_below
, best_below_byte
;
774 ptrdiff_t best_above
, best_above_byte
;
776 best_below
= best_below_byte
= 0;
777 best_above
= SCHARS (string
);
778 best_above_byte
= SBYTES (string
);
779 if (best_above
== best_above_byte
)
782 if (EQ (string
, string_char_byte_cache_string
))
784 if (string_char_byte_cache_charpos
< char_index
)
786 best_below
= string_char_byte_cache_charpos
;
787 best_below_byte
= string_char_byte_cache_bytepos
;
791 best_above
= string_char_byte_cache_charpos
;
792 best_above_byte
= string_char_byte_cache_bytepos
;
796 if (char_index
- best_below
< best_above
- char_index
)
798 unsigned char *p
= SDATA (string
) + best_below_byte
;
800 while (best_below
< char_index
)
802 p
+= BYTES_BY_CHAR_HEAD (*p
);
805 i_byte
= p
- SDATA (string
);
809 unsigned char *p
= SDATA (string
) + best_above_byte
;
811 while (best_above
> char_index
)
814 while (!CHAR_HEAD_P (*p
)) p
--;
817 i_byte
= p
- SDATA (string
);
820 string_char_byte_cache_bytepos
= i_byte
;
821 string_char_byte_cache_charpos
= char_index
;
822 string_char_byte_cache_string
= string
;
827 /* Return the character index corresponding to BYTE_INDEX in STRING. */
830 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
833 ptrdiff_t best_below
, best_below_byte
;
834 ptrdiff_t best_above
, best_above_byte
;
836 best_below
= best_below_byte
= 0;
837 best_above
= SCHARS (string
);
838 best_above_byte
= SBYTES (string
);
839 if (best_above
== best_above_byte
)
842 if (EQ (string
, string_char_byte_cache_string
))
844 if (string_char_byte_cache_bytepos
< byte_index
)
846 best_below
= string_char_byte_cache_charpos
;
847 best_below_byte
= string_char_byte_cache_bytepos
;
851 best_above
= string_char_byte_cache_charpos
;
852 best_above_byte
= string_char_byte_cache_bytepos
;
856 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
858 unsigned char *p
= SDATA (string
) + best_below_byte
;
859 unsigned char *pend
= SDATA (string
) + byte_index
;
863 p
+= BYTES_BY_CHAR_HEAD (*p
);
867 i_byte
= p
- SDATA (string
);
871 unsigned char *p
= SDATA (string
) + best_above_byte
;
872 unsigned char *pbeg
= SDATA (string
) + byte_index
;
877 while (!CHAR_HEAD_P (*p
)) p
--;
881 i_byte
= p
- SDATA (string
);
884 string_char_byte_cache_bytepos
= i_byte
;
885 string_char_byte_cache_charpos
= i
;
886 string_char_byte_cache_string
= string
;
891 /* Convert STRING to a multibyte string. */
894 string_make_multibyte (Lisp_Object string
)
901 if (STRING_MULTIBYTE (string
))
904 nbytes
= count_size_as_multibyte (SDATA (string
),
906 /* If all the chars are ASCII, they won't need any more bytes
907 once converted. In that case, we can return STRING itself. */
908 if (nbytes
== SBYTES (string
))
911 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
912 copy_text (SDATA (string
), buf
, SBYTES (string
),
915 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
922 /* Convert STRING (if unibyte) to a multibyte string without changing
923 the number of characters. Characters 0200 trough 0237 are
924 converted to eight-bit characters. */
927 string_to_multibyte (Lisp_Object string
)
934 if (STRING_MULTIBYTE (string
))
937 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
938 /* If all the chars are ASCII, they won't need any more bytes once
940 if (nbytes
== SBYTES (string
))
941 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
943 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
944 memcpy (buf
, SDATA (string
), SBYTES (string
));
945 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
947 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
954 /* Convert STRING to a single-byte string. */
957 string_make_unibyte (Lisp_Object string
)
964 if (! STRING_MULTIBYTE (string
))
967 nchars
= SCHARS (string
);
969 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
970 copy_text (SDATA (string
), buf
, SBYTES (string
),
973 ret
= make_unibyte_string ((char *) buf
, nchars
);
979 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
981 doc
: /* Return the multibyte equivalent of STRING.
982 If STRING is unibyte and contains non-ASCII characters, the function
983 `unibyte-char-to-multibyte' is used to convert each unibyte character
984 to a multibyte character. In this case, the returned string is a
985 newly created string with no text properties. If STRING is multibyte
986 or entirely ASCII, it is returned unchanged. In particular, when
987 STRING is unibyte and entirely ASCII, the returned string is unibyte.
988 \(When the characters are all ASCII, Emacs primitives will treat the
989 string the same way whether it is unibyte or multibyte.) */)
992 CHECK_STRING (string
);
994 return string_make_multibyte (string
);
997 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
999 doc
: /* Return the unibyte equivalent of STRING.
1000 Multibyte character codes are converted to unibyte according to
1001 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1002 If the lookup in the translation table fails, this function takes just
1003 the low 8 bits of each character. */)
1004 (Lisp_Object string
)
1006 CHECK_STRING (string
);
1008 return string_make_unibyte (string
);
1011 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1013 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1014 If STRING is unibyte, the result is STRING itself.
1015 Otherwise it is a newly created string, with no text properties.
1016 If STRING is multibyte and contains a character of charset
1017 `eight-bit', it is converted to the corresponding single byte. */)
1018 (Lisp_Object string
)
1020 CHECK_STRING (string
);
1022 if (STRING_MULTIBYTE (string
))
1024 ptrdiff_t bytes
= SBYTES (string
);
1025 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1027 memcpy (str
, SDATA (string
), bytes
);
1028 bytes
= str_as_unibyte (str
, bytes
);
1029 string
= make_unibyte_string ((char *) str
, bytes
);
1035 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1037 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1038 If STRING is multibyte, the result is STRING itself.
1039 Otherwise it is a newly created string, with no text properties.
1041 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1042 part of a correct utf-8 sequence), it is converted to the corresponding
1043 multibyte character of charset `eight-bit'.
1044 See also `string-to-multibyte'.
1046 Beware, this often doesn't really do what you think it does.
1047 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1048 If you're not sure, whether to use `string-as-multibyte' or
1049 `string-to-multibyte', use `string-to-multibyte'. */)
1050 (Lisp_Object string
)
1052 CHECK_STRING (string
);
1054 if (! STRING_MULTIBYTE (string
))
1056 Lisp_Object new_string
;
1057 ptrdiff_t nchars
, nbytes
;
1059 parse_str_as_multibyte (SDATA (string
),
1062 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1063 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1064 if (nbytes
!= SBYTES (string
))
1065 str_as_multibyte (SDATA (new_string
), nbytes
,
1066 SBYTES (string
), NULL
);
1067 string
= new_string
;
1068 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1073 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1075 doc
: /* Return a multibyte string with the same individual chars as STRING.
1076 If STRING is multibyte, the result is STRING itself.
1077 Otherwise it is a newly created string, with no text properties.
1079 If STRING is unibyte and contains an 8-bit byte, it is converted to
1080 the corresponding multibyte character of charset `eight-bit'.
1082 This differs from `string-as-multibyte' by converting each byte of a correct
1083 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1084 correct sequence. */)
1085 (Lisp_Object string
)
1087 CHECK_STRING (string
);
1089 return string_to_multibyte (string
);
1092 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1094 doc
: /* Return a unibyte string with the same individual chars as STRING.
1095 If STRING is unibyte, the result is STRING itself.
1096 Otherwise it is a newly created string, with no text properties,
1097 where each `eight-bit' character is converted to the corresponding byte.
1098 If STRING contains a non-ASCII, non-`eight-bit' character,
1099 an error is signaled. */)
1100 (Lisp_Object string
)
1102 CHECK_STRING (string
);
1104 if (STRING_MULTIBYTE (string
))
1106 ptrdiff_t chars
= SCHARS (string
);
1107 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1108 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1110 if (converted
< chars
)
1111 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1112 string
= make_unibyte_string ((char *) str
, chars
);
1119 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1120 doc
: /* Return a copy of ALIST.
1121 This is an alist which represents the same mapping from objects to objects,
1122 but does not share the alist structure with ALIST.
1123 The objects mapped (cars and cdrs of elements of the alist)
1124 are shared, however.
1125 Elements of ALIST that are not conses are also shared. */)
1128 register Lisp_Object tem
;
1133 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1134 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1136 register Lisp_Object car
;
1140 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1145 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1146 doc
: /* Return a new string whose contents are a substring of STRING.
1147 The returned string consists of the characters between index FROM
1148 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1149 zero-indexed: 0 means the first character of STRING. Negative values
1150 are counted from the end of STRING. If TO is nil, the substring runs
1151 to the end of STRING.
1153 The STRING argument may also be a vector. In that case, the return
1154 value is a new vector that contains the elements between index FROM
1155 \(inclusive) and index TO (exclusive) of that vector argument. */)
1156 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1160 EMACS_INT from_char
, to_char
;
1162 CHECK_VECTOR_OR_STRING (string
);
1163 CHECK_NUMBER (from
);
1165 if (STRINGP (string
))
1166 size
= SCHARS (string
);
1168 size
= ASIZE (string
);
1176 to_char
= XINT (to
);
1181 from_char
= XINT (from
);
1184 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1185 args_out_of_range_3 (string
, make_number (from_char
),
1186 make_number (to_char
));
1187 if (STRINGP (string
))
1190 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1191 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1192 res
= make_specified_string (SSDATA (string
) + from_byte
,
1193 to_char
- from_char
, to_byte
- from_byte
,
1194 STRING_MULTIBYTE (string
));
1195 copy_text_properties (make_number (from_char
), make_number (to_char
),
1196 string
, make_number (0), res
, Qnil
);
1199 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1205 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1206 doc
: /* Return a substring of STRING, without text properties.
1207 It starts at index FROM and ends before TO.
1208 TO may be nil or omitted; then the substring runs to the end of STRING.
1209 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1210 If FROM or TO is negative, it counts from the end.
1212 With one argument, just copy STRING without its properties. */)
1213 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1216 EMACS_INT from_char
, to_char
;
1217 ptrdiff_t from_byte
, to_byte
;
1219 CHECK_STRING (string
);
1221 size
= SCHARS (string
);
1227 CHECK_NUMBER (from
);
1228 from_char
= XINT (from
);
1238 to_char
= XINT (to
);
1243 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1244 args_out_of_range_3 (string
, make_number (from_char
),
1245 make_number (to_char
));
1247 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1249 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1250 return make_specified_string (SSDATA (string
) + from_byte
,
1251 to_char
- from_char
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1255 /* Extract a substring of STRING, giving start and end positions
1256 both in characters and in bytes. */
1259 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1260 ptrdiff_t to
, ptrdiff_t to_byte
)
1265 CHECK_VECTOR_OR_STRING (string
);
1267 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1269 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1270 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1272 if (STRINGP (string
))
1274 res
= make_specified_string (SSDATA (string
) + from_byte
,
1275 to
- from
, to_byte
- from_byte
,
1276 STRING_MULTIBYTE (string
));
1277 copy_text_properties (make_number (from
), make_number (to
),
1278 string
, make_number (0), res
, Qnil
);
1281 res
= Fvector (to
- from
, &AREF (string
, from
));
1286 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1287 doc
: /* Take cdr N times on LIST, return the result. */)
1288 (Lisp_Object n
, Lisp_Object list
)
1293 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1296 CHECK_LIST_CONS (list
, list
);
1302 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1303 doc
: /* Return the Nth element of LIST.
1304 N counts from zero. If LIST is not that long, nil is returned. */)
1305 (Lisp_Object n
, Lisp_Object list
)
1307 return Fcar (Fnthcdr (n
, list
));
1310 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1311 doc
: /* Return element of SEQUENCE at index N. */)
1312 (register Lisp_Object sequence
, Lisp_Object n
)
1315 if (CONSP (sequence
) || NILP (sequence
))
1316 return Fcar (Fnthcdr (n
, sequence
));
1318 /* Faref signals a "not array" error, so check here. */
1319 CHECK_ARRAY (sequence
, Qsequencep
);
1320 return Faref (sequence
, n
);
1323 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1324 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1325 The value is actually the tail of LIST whose car is ELT. */)
1326 (register Lisp_Object elt
, Lisp_Object list
)
1328 register Lisp_Object tail
;
1329 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1331 register Lisp_Object tem
;
1332 CHECK_LIST_CONS (tail
, list
);
1334 if (! NILP (Fequal (elt
, tem
)))
1341 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1342 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1343 The value is actually the tail of LIST whose car is ELT. */)
1344 (register Lisp_Object elt
, Lisp_Object list
)
1348 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1352 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1356 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1367 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1368 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1369 The value is actually the tail of LIST whose car is ELT. */)
1370 (register Lisp_Object elt
, Lisp_Object list
)
1372 register Lisp_Object tail
;
1375 return Fmemq (elt
, list
);
1377 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1379 register Lisp_Object tem
;
1380 CHECK_LIST_CONS (tail
, list
);
1382 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1389 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1390 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1391 The value is actually the first element of LIST whose car is KEY.
1392 Elements of LIST that are not conses are ignored. */)
1393 (Lisp_Object key
, Lisp_Object list
)
1398 || (CONSP (XCAR (list
))
1399 && EQ (XCAR (XCAR (list
)), key
)))
1404 || (CONSP (XCAR (list
))
1405 && EQ (XCAR (XCAR (list
)), key
)))
1410 || (CONSP (XCAR (list
))
1411 && EQ (XCAR (XCAR (list
)), key
)))
1421 /* Like Fassq but never report an error and do not allow quits.
1422 Use only on lists known never to be circular. */
1425 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1428 && (!CONSP (XCAR (list
))
1429 || !EQ (XCAR (XCAR (list
)), key
)))
1432 return CAR_SAFE (list
);
1435 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1436 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1437 The value is actually the first element of LIST whose car equals KEY. */)
1438 (Lisp_Object key
, Lisp_Object list
)
1445 || (CONSP (XCAR (list
))
1446 && (car
= XCAR (XCAR (list
)),
1447 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1452 || (CONSP (XCAR (list
))
1453 && (car
= XCAR (XCAR (list
)),
1454 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1459 || (CONSP (XCAR (list
))
1460 && (car
= XCAR (XCAR (list
)),
1461 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1471 /* Like Fassoc but never report an error and do not allow quits.
1472 Use only on lists known never to be circular. */
1475 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1478 && (!CONSP (XCAR (list
))
1479 || (!EQ (XCAR (XCAR (list
)), key
)
1480 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1483 return CONSP (list
) ? XCAR (list
) : Qnil
;
1486 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1487 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1488 The value is actually the first element of LIST whose cdr is KEY. */)
1489 (register Lisp_Object key
, Lisp_Object list
)
1494 || (CONSP (XCAR (list
))
1495 && EQ (XCDR (XCAR (list
)), key
)))
1500 || (CONSP (XCAR (list
))
1501 && EQ (XCDR (XCAR (list
)), key
)))
1506 || (CONSP (XCAR (list
))
1507 && EQ (XCDR (XCAR (list
)), key
)))
1517 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1518 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1519 The value is actually the first element of LIST whose cdr equals KEY. */)
1520 (Lisp_Object key
, Lisp_Object list
)
1527 || (CONSP (XCAR (list
))
1528 && (cdr
= XCDR (XCAR (list
)),
1529 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (cdr
= XCDR (XCAR (list
)),
1536 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (cdr
= XCDR (XCAR (list
)),
1543 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1553 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1554 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1555 The modified LIST is returned. Comparison is done with `eq'.
1556 If the first member of LIST is ELT, there is no way to remove it by side effect;
1557 therefore, write `(setq foo (delq element foo))'
1558 to be sure of changing the value of `foo'. */)
1559 (register Lisp_Object elt
, Lisp_Object list
)
1561 register Lisp_Object tail
, prev
;
1562 register Lisp_Object tem
;
1566 while (!NILP (tail
))
1568 CHECK_LIST_CONS (tail
, list
);
1575 Fsetcdr (prev
, XCDR (tail
));
1585 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1586 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1587 SEQ must be a list, a vector, or a string.
1588 The modified SEQ is returned. Comparison is done with `equal'.
1589 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1590 is not a side effect; it is simply using a different sequence.
1591 Therefore, write `(setq foo (delete element foo))'
1592 to be sure of changing the value of `foo'. */)
1593 (Lisp_Object elt
, Lisp_Object seq
)
1599 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1600 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1603 if (n
!= ASIZE (seq
))
1605 struct Lisp_Vector
*p
= allocate_vector (n
);
1607 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1608 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1609 p
->contents
[n
++] = AREF (seq
, i
);
1611 XSETVECTOR (seq
, p
);
1614 else if (STRINGP (seq
))
1616 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1619 for (i
= nchars
= nbytes
= ibyte
= 0;
1621 ++i
, ibyte
+= cbytes
)
1623 if (STRING_MULTIBYTE (seq
))
1625 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1626 cbytes
= CHAR_BYTES (c
);
1634 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1641 if (nchars
!= SCHARS (seq
))
1645 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1646 if (!STRING_MULTIBYTE (seq
))
1647 STRING_SET_UNIBYTE (tem
);
1649 for (i
= nchars
= nbytes
= ibyte
= 0;
1651 ++i
, ibyte
+= cbytes
)
1653 if (STRING_MULTIBYTE (seq
))
1655 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1656 cbytes
= CHAR_BYTES (c
);
1664 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1666 unsigned char *from
= SDATA (seq
) + ibyte
;
1667 unsigned char *to
= SDATA (tem
) + nbytes
;
1673 for (n
= cbytes
; n
--; )
1683 Lisp_Object tail
, prev
;
1685 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1687 CHECK_LIST_CONS (tail
, seq
);
1689 if (!NILP (Fequal (elt
, XCAR (tail
))))
1694 Fsetcdr (prev
, XCDR (tail
));
1705 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1706 doc
: /* Reverse LIST by modifying cdr pointers.
1707 Return the reversed list. */)
1710 register Lisp_Object prev
, tail
, next
;
1712 if (NILP (list
)) return list
;
1715 while (!NILP (tail
))
1718 CHECK_LIST_CONS (tail
, list
);
1720 Fsetcdr (tail
, prev
);
1727 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1728 doc
: /* Reverse LIST, copying. Return the reversed list.
1729 See also the function `nreverse', which is used more often. */)
1734 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1737 new = Fcons (XCAR (list
), new);
1739 CHECK_LIST_END (list
, list
);
1743 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1745 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1746 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1747 Returns the sorted list. LIST is modified by side effects.
1748 PREDICATE is called with two elements of LIST, and should return non-nil
1749 if the first element should sort before the second. */)
1750 (Lisp_Object list
, Lisp_Object predicate
)
1752 Lisp_Object front
, back
;
1753 register Lisp_Object len
, tem
;
1754 struct gcpro gcpro1
, gcpro2
;
1758 len
= Flength (list
);
1759 length
= XINT (len
);
1763 XSETINT (len
, (length
/ 2) - 1);
1764 tem
= Fnthcdr (len
, list
);
1766 Fsetcdr (tem
, Qnil
);
1768 GCPRO2 (front
, back
);
1769 front
= Fsort (front
, predicate
);
1770 back
= Fsort (back
, predicate
);
1772 return merge (front
, back
, predicate
);
1776 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1779 register Lisp_Object tail
;
1781 register Lisp_Object l1
, l2
;
1782 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1789 /* It is sufficient to protect org_l1 and org_l2.
1790 When l1 and l2 are updated, we copy the new values
1791 back into the org_ vars. */
1792 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1812 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1828 Fsetcdr (tail
, tem
);
1834 /* This does not check for quits. That is safe since it must terminate. */
1836 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1837 doc
: /* Extract a value from a property list.
1838 PLIST is a property list, which is a list of the form
1839 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1840 corresponding to the given PROP, or nil if PROP is not one of the
1841 properties on the list. This function never signals an error. */)
1842 (Lisp_Object plist
, Lisp_Object prop
)
1844 Lisp_Object tail
, halftail
;
1846 /* halftail is used to detect circular lists. */
1847 tail
= halftail
= plist
;
1848 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1850 if (EQ (prop
, XCAR (tail
)))
1851 return XCAR (XCDR (tail
));
1853 tail
= XCDR (XCDR (tail
));
1854 halftail
= XCDR (halftail
);
1855 if (EQ (tail
, halftail
))
1858 #if 0 /* Unsafe version. */
1859 /* This function can be called asynchronously
1860 (setup_coding_system). Don't QUIT in that case. */
1861 if (!interrupt_input_blocked
)
1869 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1870 doc
: /* Return the value of SYMBOL's PROPNAME property.
1871 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1872 (Lisp_Object symbol
, Lisp_Object propname
)
1874 CHECK_SYMBOL (symbol
);
1875 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1878 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1879 doc
: /* Change value in PLIST of PROP to VAL.
1880 PLIST is a property list, which is a list of the form
1881 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1882 If PROP is already a property on the list, its value is set to VAL,
1883 otherwise the new PROP VAL pair is added. The new plist is returned;
1884 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1885 The PLIST is modified by side effects. */)
1886 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1888 register Lisp_Object tail
, prev
;
1889 Lisp_Object newcell
;
1891 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1892 tail
= XCDR (XCDR (tail
)))
1894 if (EQ (prop
, XCAR (tail
)))
1896 Fsetcar (XCDR (tail
), val
);
1903 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1907 Fsetcdr (XCDR (prev
), newcell
);
1911 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1912 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1913 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1914 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1916 CHECK_SYMBOL (symbol
);
1917 XSYMBOL (symbol
)->plist
1918 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1922 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1923 doc
: /* Extract a value from a property list, comparing with `equal'.
1924 PLIST is a property list, which is a list of the form
1925 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1926 corresponding to the given PROP, or nil if PROP is not
1927 one of the properties on the list. */)
1928 (Lisp_Object plist
, Lisp_Object prop
)
1933 CONSP (tail
) && CONSP (XCDR (tail
));
1934 tail
= XCDR (XCDR (tail
)))
1936 if (! NILP (Fequal (prop
, XCAR (tail
))))
1937 return XCAR (XCDR (tail
));
1942 CHECK_LIST_END (tail
, prop
);
1947 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1948 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1949 PLIST is a property list, which is a list of the form
1950 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1951 If PROP is already a property on the list, its value is set to VAL,
1952 otherwise the new PROP VAL pair is added. The new plist is returned;
1953 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1954 The PLIST is modified by side effects. */)
1955 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1957 register Lisp_Object tail
, prev
;
1958 Lisp_Object newcell
;
1960 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1961 tail
= XCDR (XCDR (tail
)))
1963 if (! NILP (Fequal (prop
, XCAR (tail
))))
1965 Fsetcar (XCDR (tail
), val
);
1972 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1976 Fsetcdr (XCDR (prev
), newcell
);
1980 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1981 doc
: /* Return t if the two args are the same Lisp object.
1982 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1983 (Lisp_Object obj1
, Lisp_Object obj2
)
1986 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1988 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1991 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1992 doc
: /* Return t if two Lisp objects have similar structure and contents.
1993 They must have the same data type.
1994 Conses are compared by comparing the cars and the cdrs.
1995 Vectors and strings are compared element by element.
1996 Numbers are compared by value, but integers cannot equal floats.
1997 (Use `=' if you want integers and floats to be able to be equal.)
1998 Symbols must match exactly. */)
1999 (register Lisp_Object o1
, Lisp_Object o2
)
2001 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2004 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2005 doc
: /* Return t if two Lisp objects have similar structure and contents.
2006 This is like `equal' except that it compares the text properties
2007 of strings. (`equal' ignores text properties.) */)
2008 (register Lisp_Object o1
, Lisp_Object o2
)
2010 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2013 /* DEPTH is current depth of recursion. Signal an error if it
2015 PROPS, if non-nil, means compare string text properties too. */
2018 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2021 error ("Stack overflow in equal");
2027 if (XTYPE (o1
) != XTYPE (o2
))
2036 d1
= extract_float (o1
);
2037 d2
= extract_float (o2
);
2038 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2039 though they are not =. */
2040 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2044 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2051 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2055 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2057 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2060 o1
= XOVERLAY (o1
)->plist
;
2061 o2
= XOVERLAY (o2
)->plist
;
2066 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2067 && (XMARKER (o1
)->buffer
== 0
2068 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2072 case Lisp_Vectorlike
:
2075 ptrdiff_t size
= ASIZE (o1
);
2076 /* Pseudovectors have the type encoded in the size field, so this test
2077 actually checks that the objects have the same type as well as the
2079 if (ASIZE (o2
) != size
)
2081 /* Boolvectors are compared much like strings. */
2082 if (BOOL_VECTOR_P (o1
))
2084 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2086 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2087 ((XBOOL_VECTOR (o1
)->size
2088 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2089 / BOOL_VECTOR_BITS_PER_CHAR
)))
2093 if (WINDOW_CONFIGURATIONP (o1
))
2094 return compare_window_configurations (o1
, o2
, 0);
2096 /* Aside from them, only true vectors, char-tables, compiled
2097 functions, and fonts (font-spec, font-entity, font-object)
2098 are sensible to compare, so eliminate the others now. */
2099 if (size
& PSEUDOVECTOR_FLAG
)
2101 if (!(size
& (PVEC_COMPILED
2102 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2104 size
&= PSEUDOVECTOR_SIZE_MASK
;
2106 for (i
= 0; i
< size
; i
++)
2111 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2119 if (SCHARS (o1
) != SCHARS (o2
))
2121 if (SBYTES (o1
) != SBYTES (o2
))
2123 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2125 if (props
&& !compare_string_intervals (o1
, o2
))
2137 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2138 doc
: /* Store each element of ARRAY with ITEM.
2139 ARRAY is a vector, string, char-table, or bool-vector. */)
2140 (Lisp_Object array
, Lisp_Object item
)
2142 register ptrdiff_t size
, idx
;
2144 if (VECTORP (array
))
2146 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2147 size
= ASIZE (array
);
2148 for (idx
= 0; idx
< size
; idx
++)
2151 else if (CHAR_TABLE_P (array
))
2155 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2156 XCHAR_TABLE (array
)->contents
[i
] = item
;
2157 XCHAR_TABLE (array
)->defalt
= item
;
2159 else if (STRINGP (array
))
2161 register unsigned char *p
= SDATA (array
);
2163 CHECK_CHARACTER (item
);
2164 charval
= XFASTINT (item
);
2165 size
= SCHARS (array
);
2166 if (STRING_MULTIBYTE (array
))
2168 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2169 int len
= CHAR_STRING (charval
, str
);
2170 ptrdiff_t size_byte
= SBYTES (array
);
2172 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2173 || SCHARS (array
) * len
!= size_byte
)
2174 error ("Attempt to change byte length of a string");
2175 for (idx
= 0; idx
< size_byte
; idx
++)
2176 *p
++ = str
[idx
% len
];
2179 for (idx
= 0; idx
< size
; idx
++)
2182 else if (BOOL_VECTOR_P (array
))
2184 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2186 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2187 / BOOL_VECTOR_BITS_PER_CHAR
);
2191 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2193 /* Clear any extraneous bits in the last byte. */
2194 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2198 wrong_type_argument (Qarrayp
, array
);
2202 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2204 doc
: /* Clear the contents of STRING.
2205 This makes STRING unibyte and may change its length. */)
2206 (Lisp_Object string
)
2209 CHECK_STRING (string
);
2210 len
= SBYTES (string
);
2211 memset (SDATA (string
), 0, len
);
2212 STRING_SET_CHARS (string
, len
);
2213 STRING_SET_UNIBYTE (string
);
2219 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2221 Lisp_Object args
[2];
2224 return Fnconc (2, args
);
2227 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2228 doc
: /* Concatenate any number of lists by altering them.
2229 Only the last argument is not altered, and need not be a list.
2230 usage: (nconc &rest LISTS) */)
2231 (ptrdiff_t nargs
, Lisp_Object
*args
)
2234 register Lisp_Object tail
, tem
, val
;
2238 for (argnum
= 0; argnum
< nargs
; argnum
++)
2241 if (NILP (tem
)) continue;
2246 if (argnum
+ 1 == nargs
) break;
2248 CHECK_LIST_CONS (tem
, tem
);
2257 tem
= args
[argnum
+ 1];
2258 Fsetcdr (tail
, tem
);
2260 args
[argnum
+ 1] = tail
;
2266 /* This is the guts of all mapping functions.
2267 Apply FN to each element of SEQ, one by one,
2268 storing the results into elements of VALS, a C vector of Lisp_Objects.
2269 LENI is the length of VALS, which should also be the length of SEQ. */
2272 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2274 register Lisp_Object tail
;
2276 register EMACS_INT i
;
2277 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2281 /* Don't let vals contain any garbage when GC happens. */
2282 for (i
= 0; i
< leni
; i
++)
2285 GCPRO3 (dummy
, fn
, seq
);
2287 gcpro1
.nvars
= leni
;
2291 /* We need not explicitly protect `tail' because it is used only on lists, and
2292 1) lists are not relocated and 2) the list is marked via `seq' so will not
2295 if (VECTORP (seq
) || COMPILEDP (seq
))
2297 for (i
= 0; i
< leni
; i
++)
2299 dummy
= call1 (fn
, AREF (seq
, i
));
2304 else if (BOOL_VECTOR_P (seq
))
2306 for (i
= 0; i
< leni
; i
++)
2309 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2310 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2311 dummy
= call1 (fn
, dummy
);
2316 else if (STRINGP (seq
))
2320 for (i
= 0, i_byte
= 0; i
< leni
;)
2323 ptrdiff_t i_before
= i
;
2325 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2326 XSETFASTINT (dummy
, c
);
2327 dummy
= call1 (fn
, dummy
);
2329 vals
[i_before
] = dummy
;
2332 else /* Must be a list, since Flength did not get an error */
2335 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2337 dummy
= call1 (fn
, XCAR (tail
));
2347 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2348 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2349 In between each pair of results, stick in SEPARATOR. Thus, " " as
2350 SEPARATOR results in spaces between the values returned by FUNCTION.
2351 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2352 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2355 register EMACS_INT leni
;
2358 register Lisp_Object
*args
;
2359 struct gcpro gcpro1
;
2363 len
= Flength (sequence
);
2364 if (CHAR_TABLE_P (sequence
))
2365 wrong_type_argument (Qlistp
, sequence
);
2367 nargs
= leni
+ leni
- 1;
2368 if (nargs
< 0) return empty_unibyte_string
;
2370 SAFE_ALLOCA_LISP (args
, nargs
);
2373 mapcar1 (leni
, args
, function
, sequence
);
2376 for (i
= leni
- 1; i
> 0; i
--)
2377 args
[i
+ i
] = args
[i
];
2379 for (i
= 1; i
< nargs
; i
+= 2)
2380 args
[i
] = separator
;
2382 ret
= Fconcat (nargs
, args
);
2388 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2389 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2390 The result is a list just as long as SEQUENCE.
2391 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2392 (Lisp_Object function
, Lisp_Object sequence
)
2394 register Lisp_Object len
;
2395 register EMACS_INT leni
;
2396 register Lisp_Object
*args
;
2400 len
= Flength (sequence
);
2401 if (CHAR_TABLE_P (sequence
))
2402 wrong_type_argument (Qlistp
, sequence
);
2403 leni
= XFASTINT (len
);
2405 SAFE_ALLOCA_LISP (args
, leni
);
2407 mapcar1 (leni
, args
, function
, sequence
);
2409 ret
= Flist (leni
, args
);
2415 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2416 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2417 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2418 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2419 (Lisp_Object function
, Lisp_Object sequence
)
2421 register EMACS_INT leni
;
2423 leni
= XFASTINT (Flength (sequence
));
2424 if (CHAR_TABLE_P (sequence
))
2425 wrong_type_argument (Qlistp
, sequence
);
2426 mapcar1 (leni
, 0, function
, sequence
);
2431 /* This is how C code calls `yes-or-no-p' and allows the user
2434 Anything that calls this function must protect from GC! */
2437 do_yes_or_no_p (Lisp_Object prompt
)
2439 return call1 (intern ("yes-or-no-p"), prompt
);
2442 /* Anything that calls this function must protect from GC! */
2444 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2445 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2446 PROMPT is the string to display to ask the question. It should end in
2447 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2449 The user must confirm the answer with RET, and can edit it until it
2452 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2453 is nil, and `use-dialog-box' is non-nil. */)
2454 (Lisp_Object prompt
)
2456 register Lisp_Object ans
;
2457 Lisp_Object args
[2];
2458 struct gcpro gcpro1
;
2460 CHECK_STRING (prompt
);
2463 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2464 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2468 Lisp_Object pane
, menu
, obj
;
2469 redisplay_preserve_echo_area (4);
2470 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2471 Fcons (Fcons (build_string ("No"), Qnil
),
2474 menu
= Fcons (prompt
, pane
);
2475 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2479 #endif /* HAVE_MENUS */
2482 args
[1] = build_string ("(yes or no) ");
2483 prompt
= Fconcat (2, args
);
2489 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2490 Qyes_or_no_p_history
, Qnil
,
2492 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2497 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2505 message ("Please answer yes or no.");
2506 Fsleep_for (make_number (2), Qnil
);
2510 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2511 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2513 Each of the three load averages is multiplied by 100, then converted
2516 When USE-FLOATS is non-nil, floats will be used instead of integers.
2517 These floats are not multiplied by 100.
2519 If the 5-minute or 15-minute load averages are not available, return a
2520 shortened list, containing only those averages which are available.
2522 An error is thrown if the load average can't be obtained. In some
2523 cases making it work would require Emacs being installed setuid or
2524 setgid so that it can read kernel information, and that usually isn't
2526 (Lisp_Object use_floats
)
2529 int loads
= getloadavg (load_ave
, 3);
2530 Lisp_Object ret
= Qnil
;
2533 error ("load-average not implemented for this operating system");
2537 Lisp_Object load
= (NILP (use_floats
)
2538 ? make_number (100.0 * load_ave
[loads
])
2539 : make_float (load_ave
[loads
]));
2540 ret
= Fcons (load
, ret
);
2546 static Lisp_Object Qsubfeatures
;
2548 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2549 doc
: /* Return t if FEATURE is present in this Emacs.
2551 Use this to conditionalize execution of lisp code based on the
2552 presence or absence of Emacs or environment extensions.
2553 Use `provide' to declare that a feature is available. This function
2554 looks at the value of the variable `features'. The optional argument
2555 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2556 (Lisp_Object feature
, Lisp_Object subfeature
)
2558 register Lisp_Object tem
;
2559 CHECK_SYMBOL (feature
);
2560 tem
= Fmemq (feature
, Vfeatures
);
2561 if (!NILP (tem
) && !NILP (subfeature
))
2562 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2563 return (NILP (tem
)) ? Qnil
: Qt
;
2566 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2567 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2568 The optional argument SUBFEATURES should be a list of symbols listing
2569 particular subfeatures supported in this version of FEATURE. */)
2570 (Lisp_Object feature
, Lisp_Object subfeatures
)
2572 register Lisp_Object tem
;
2573 CHECK_SYMBOL (feature
);
2574 CHECK_LIST (subfeatures
);
2575 if (!NILP (Vautoload_queue
))
2576 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2578 tem
= Fmemq (feature
, Vfeatures
);
2580 Vfeatures
= Fcons (feature
, Vfeatures
);
2581 if (!NILP (subfeatures
))
2582 Fput (feature
, Qsubfeatures
, subfeatures
);
2583 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2585 /* Run any load-hooks for this file. */
2586 tem
= Fassq (feature
, Vafter_load_alist
);
2588 Fprogn (XCDR (tem
));
2593 /* `require' and its subroutines. */
2595 /* List of features currently being require'd, innermost first. */
2597 static Lisp_Object require_nesting_list
;
2600 require_unwind (Lisp_Object old_value
)
2602 return require_nesting_list
= old_value
;
2605 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2606 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2607 If FEATURE is not a member of the list `features', then the feature
2608 is not loaded; so load the file FILENAME.
2609 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2610 and `load' will try to load this name appended with the suffix `.elc' or
2611 `.el', in that order. The name without appended suffix will not be used.
2612 See `get-load-suffixes' for the complete list of suffixes.
2613 If the optional third argument NOERROR is non-nil,
2614 then return nil if the file is not found instead of signaling an error.
2615 Normally the return value is FEATURE.
2616 The normal messages at start and end of loading FILENAME are suppressed. */)
2617 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2619 register Lisp_Object tem
;
2620 struct gcpro gcpro1
, gcpro2
;
2621 int from_file
= load_in_progress
;
2623 CHECK_SYMBOL (feature
);
2625 /* Record the presence of `require' in this file
2626 even if the feature specified is already loaded.
2627 But not more than once in any file,
2628 and not when we aren't loading or reading from a file. */
2630 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2631 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2636 tem
= Fcons (Qrequire
, feature
);
2637 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2638 LOADHIST_ATTACH (tem
);
2640 tem
= Fmemq (feature
, Vfeatures
);
2644 ptrdiff_t count
= SPECPDL_INDEX ();
2647 /* This is to make sure that loadup.el gives a clear picture
2648 of what files are preloaded and when. */
2649 if (! NILP (Vpurify_flag
))
2650 error ("(require %s) while preparing to dump",
2651 SDATA (SYMBOL_NAME (feature
)));
2653 /* A certain amount of recursive `require' is legitimate,
2654 but if we require the same feature recursively 3 times,
2656 tem
= require_nesting_list
;
2657 while (! NILP (tem
))
2659 if (! NILP (Fequal (feature
, XCAR (tem
))))
2664 error ("Recursive `require' for feature `%s'",
2665 SDATA (SYMBOL_NAME (feature
)));
2667 /* Update the list for any nested `require's that occur. */
2668 record_unwind_protect (require_unwind
, require_nesting_list
);
2669 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2671 /* Value saved here is to be restored into Vautoload_queue */
2672 record_unwind_protect (un_autoload
, Vautoload_queue
);
2673 Vautoload_queue
= Qt
;
2675 /* Load the file. */
2676 GCPRO2 (feature
, filename
);
2677 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2678 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2681 /* If load failed entirely, return nil. */
2683 return unbind_to (count
, Qnil
);
2685 tem
= Fmemq (feature
, Vfeatures
);
2687 error ("Required feature `%s' was not provided",
2688 SDATA (SYMBOL_NAME (feature
)));
2690 /* Once loading finishes, don't undo it. */
2691 Vautoload_queue
= Qt
;
2692 feature
= unbind_to (count
, feature
);
2698 /* Primitives for work of the "widget" library.
2699 In an ideal world, this section would not have been necessary.
2700 However, lisp function calls being as slow as they are, it turns
2701 out that some functions in the widget library (wid-edit.el) are the
2702 bottleneck of Widget operation. Here is their translation to C,
2703 for the sole reason of efficiency. */
2705 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2706 doc
: /* Return non-nil if PLIST has the property PROP.
2707 PLIST is a property list, which is a list of the form
2708 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2709 Unlike `plist-get', this allows you to distinguish between a missing
2710 property and a property with the value nil.
2711 The value is actually the tail of PLIST whose car is PROP. */)
2712 (Lisp_Object plist
, Lisp_Object prop
)
2714 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2717 plist
= XCDR (plist
);
2718 plist
= CDR (plist
);
2723 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2724 doc
: /* In WIDGET, set PROPERTY to VALUE.
2725 The value can later be retrieved with `widget-get'. */)
2726 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2728 CHECK_CONS (widget
);
2729 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2733 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2734 doc
: /* In WIDGET, get the value of PROPERTY.
2735 The value could either be specified when the widget was created, or
2736 later with `widget-put'. */)
2737 (Lisp_Object widget
, Lisp_Object property
)
2745 CHECK_CONS (widget
);
2746 tmp
= Fplist_member (XCDR (widget
), property
);
2752 tmp
= XCAR (widget
);
2755 widget
= Fget (tmp
, Qwidget_type
);
2759 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2760 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2761 ARGS are passed as extra arguments to the function.
2762 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2763 (ptrdiff_t nargs
, Lisp_Object
*args
)
2765 /* This function can GC. */
2766 Lisp_Object newargs
[3];
2767 struct gcpro gcpro1
, gcpro2
;
2770 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2771 newargs
[1] = args
[0];
2772 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2773 GCPRO2 (newargs
[0], newargs
[2]);
2774 result
= Fapply (3, newargs
);
2779 #ifdef HAVE_LANGINFO_CODESET
2780 #include <langinfo.h>
2783 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2784 doc
: /* Access locale data ITEM for the current C locale, if available.
2785 ITEM should be one of the following:
2787 `codeset', returning the character set as a string (locale item CODESET);
2789 `days', returning a 7-element vector of day names (locale items DAY_n);
2791 `months', returning a 12-element vector of month names (locale items MON_n);
2793 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2794 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2796 If the system can't provide such information through a call to
2797 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2799 See also Info node `(libc)Locales'.
2801 The data read from the system are decoded using `locale-coding-system'. */)
2805 #ifdef HAVE_LANGINFO_CODESET
2807 if (EQ (item
, Qcodeset
))
2809 str
= nl_langinfo (CODESET
);
2810 return build_string (str
);
2813 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2815 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2816 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2818 struct gcpro gcpro1
;
2820 synchronize_system_time_locale ();
2821 for (i
= 0; i
< 7; i
++)
2823 str
= nl_langinfo (days
[i
]);
2824 val
= make_unibyte_string (str
, strlen (str
));
2825 /* Fixme: Is this coding system necessarily right, even if
2826 it is consistent with CODESET? If not, what to do? */
2827 Faset (v
, make_number (i
),
2828 code_convert_string_norecord (val
, Vlocale_coding_system
,
2836 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2838 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2839 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2840 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2842 struct gcpro gcpro1
;
2844 synchronize_system_time_locale ();
2845 for (i
= 0; i
< 12; i
++)
2847 str
= nl_langinfo (months
[i
]);
2848 val
= make_unibyte_string (str
, strlen (str
));
2849 Faset (v
, make_number (i
),
2850 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2856 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2857 but is in the locale files. This could be used by ps-print. */
2859 else if (EQ (item
, Qpaper
))
2861 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2862 make_number (nl_langinfo (PAPER_HEIGHT
)));
2864 #endif /* PAPER_WIDTH */
2865 #endif /* HAVE_LANGINFO_CODESET*/
2869 /* base64 encode/decode functions (RFC 2045).
2870 Based on code from GNU recode. */
2872 #define MIME_LINE_LENGTH 76
2874 #define IS_ASCII(Character) \
2876 #define IS_BASE64(Character) \
2877 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2878 #define IS_BASE64_IGNORABLE(Character) \
2879 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2880 || (Character) == '\f' || (Character) == '\r')
2882 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2883 character or return retval if there are no characters left to
2885 #define READ_QUADRUPLET_BYTE(retval) \
2890 if (nchars_return) \
2891 *nchars_return = nchars; \
2896 while (IS_BASE64_IGNORABLE (c))
2898 /* Table of characters coding the 64 values. */
2899 static const char base64_value_to_char
[64] =
2901 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2902 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2903 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2904 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2905 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2906 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2907 '8', '9', '+', '/' /* 60-63 */
2910 /* Table of base64 values for first 128 characters. */
2911 static const short base64_char_to_value
[128] =
2913 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2914 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2915 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2916 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2917 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2918 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2919 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2920 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2921 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2922 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2923 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2924 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2925 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2928 /* The following diagram shows the logical steps by which three octets
2929 get transformed into four base64 characters.
2931 .--------. .--------. .--------.
2932 |aaaaaabb| |bbbbcccc| |ccdddddd|
2933 `--------' `--------' `--------'
2935 .--------+--------+--------+--------.
2936 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2937 `--------+--------+--------+--------'
2939 .--------+--------+--------+--------.
2940 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2941 `--------+--------+--------+--------'
2943 The octets are divided into 6 bit chunks, which are then encoded into
2944 base64 characters. */
2947 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, int, int);
2948 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, int,
2951 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2953 doc
: /* Base64-encode the region between BEG and END.
2954 Return the length of the encoded text.
2955 Optional third argument NO-LINE-BREAK means do not break long lines
2956 into shorter lines. */)
2957 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2960 ptrdiff_t allength
, length
;
2961 ptrdiff_t ibeg
, iend
, encoded_length
;
2962 ptrdiff_t old_pos
= PT
;
2965 validate_region (&beg
, &end
);
2967 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2968 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2969 move_gap_both (XFASTINT (beg
), ibeg
);
2971 /* We need to allocate enough room for encoding the text.
2972 We need 33 1/3% more space, plus a newline every 76
2973 characters, and then we round up. */
2974 length
= iend
- ibeg
;
2975 allength
= length
+ length
/3 + 1;
2976 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2978 SAFE_ALLOCA (encoded
, char *, allength
);
2979 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2980 encoded
, length
, NILP (no_line_break
),
2981 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2982 if (encoded_length
> allength
)
2985 if (encoded_length
< 0)
2987 /* The encoding wasn't possible. */
2989 error ("Multibyte character in data for base64 encoding");
2992 /* Now we have encoded the region, so we insert the new contents
2993 and delete the old. (Insert first in order to preserve markers.) */
2994 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2995 insert (encoded
, encoded_length
);
2997 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2999 /* If point was outside of the region, restore it exactly; else just
3000 move to the beginning of the region. */
3001 if (old_pos
>= XFASTINT (end
))
3002 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3003 else if (old_pos
> XFASTINT (beg
))
3004 old_pos
= XFASTINT (beg
);
3007 /* We return the length of the encoded text. */
3008 return make_number (encoded_length
);
3011 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3013 doc
: /* Base64-encode STRING and return the result.
3014 Optional second argument NO-LINE-BREAK means do not break long lines
3015 into shorter lines. */)
3016 (Lisp_Object string
, Lisp_Object no_line_break
)
3018 ptrdiff_t allength
, length
, encoded_length
;
3020 Lisp_Object encoded_string
;
3023 CHECK_STRING (string
);
3025 /* We need to allocate enough room for encoding the text.
3026 We need 33 1/3% more space, plus a newline every 76
3027 characters, and then we round up. */
3028 length
= SBYTES (string
);
3029 allength
= length
+ length
/3 + 1;
3030 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3032 /* We need to allocate enough room for decoding the text. */
3033 SAFE_ALLOCA (encoded
, char *, allength
);
3035 encoded_length
= base64_encode_1 (SSDATA (string
),
3036 encoded
, length
, NILP (no_line_break
),
3037 STRING_MULTIBYTE (string
));
3038 if (encoded_length
> allength
)
3041 if (encoded_length
< 0)
3043 /* The encoding wasn't possible. */
3045 error ("Multibyte character in data for base64 encoding");
3048 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3051 return encoded_string
;
3055 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3056 int line_break
, int multibyte
)
3069 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3070 if (CHAR_BYTE8_P (c
))
3071 c
= CHAR_TO_BYTE8 (c
);
3079 /* Wrap line every 76 characters. */
3083 if (counter
< MIME_LINE_LENGTH
/ 4)
3092 /* Process first byte of a triplet. */
3094 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3095 value
= (0x03 & c
) << 4;
3097 /* Process second byte of a triplet. */
3101 *e
++ = base64_value_to_char
[value
];
3109 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3110 if (CHAR_BYTE8_P (c
))
3111 c
= CHAR_TO_BYTE8 (c
);
3119 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3120 value
= (0x0f & c
) << 2;
3122 /* Process third byte of a triplet. */
3126 *e
++ = base64_value_to_char
[value
];
3133 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3134 if (CHAR_BYTE8_P (c
))
3135 c
= CHAR_TO_BYTE8 (c
);
3143 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3144 *e
++ = base64_value_to_char
[0x3f & c
];
3151 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3153 doc
: /* Base64-decode the region between BEG and END.
3154 Return the length of the decoded text.
3155 If the region can't be decoded, signal an error and don't modify the buffer. */)
3156 (Lisp_Object beg
, Lisp_Object end
)
3158 ptrdiff_t ibeg
, iend
, length
, allength
;
3160 ptrdiff_t old_pos
= PT
;
3161 ptrdiff_t decoded_length
;
3162 ptrdiff_t inserted_chars
;
3163 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3166 validate_region (&beg
, &end
);
3168 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3169 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3171 length
= iend
- ibeg
;
3173 /* We need to allocate enough room for decoding the text. If we are
3174 working on a multibyte buffer, each decoded code may occupy at
3176 allength
= multibyte
? length
* 2 : length
;
3177 SAFE_ALLOCA (decoded
, char *, allength
);
3179 move_gap_both (XFASTINT (beg
), ibeg
);
3180 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3182 multibyte
, &inserted_chars
);
3183 if (decoded_length
> allength
)
3186 if (decoded_length
< 0)
3188 /* The decoding wasn't possible. */
3190 error ("Invalid base64 data");
3193 /* Now we have decoded the region, so we insert the new contents
3194 and delete the old. (Insert first in order to preserve markers.) */
3195 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3196 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3199 /* Delete the original text. */
3200 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3201 iend
+ decoded_length
, 1);
3203 /* If point was outside of the region, restore it exactly; else just
3204 move to the beginning of the region. */
3205 if (old_pos
>= XFASTINT (end
))
3206 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3207 else if (old_pos
> XFASTINT (beg
))
3208 old_pos
= XFASTINT (beg
);
3209 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3211 return make_number (inserted_chars
);
3214 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3216 doc
: /* Base64-decode STRING and return the result. */)
3217 (Lisp_Object string
)
3220 ptrdiff_t length
, decoded_length
;
3221 Lisp_Object decoded_string
;
3224 CHECK_STRING (string
);
3226 length
= SBYTES (string
);
3227 /* We need to allocate enough room for decoding the text. */
3228 SAFE_ALLOCA (decoded
, char *, length
);
3230 /* The decoded result should be unibyte. */
3231 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3233 if (decoded_length
> length
)
3235 else if (decoded_length
>= 0)
3236 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3238 decoded_string
= Qnil
;
3241 if (!STRINGP (decoded_string
))
3242 error ("Invalid base64 data");
3244 return decoded_string
;
3247 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3248 MULTIBYTE is nonzero, the decoded result should be in multibyte
3249 form. If NCHARS_RETRUN is not NULL, store the number of produced
3250 characters in *NCHARS_RETURN. */
3253 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3254 int multibyte
, ptrdiff_t *nchars_return
)
3256 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3259 unsigned long value
;
3260 ptrdiff_t nchars
= 0;
3264 /* Process first byte of a quadruplet. */
3266 READ_QUADRUPLET_BYTE (e
-to
);
3270 value
= base64_char_to_value
[c
] << 18;
3272 /* Process second byte of a quadruplet. */
3274 READ_QUADRUPLET_BYTE (-1);
3278 value
|= base64_char_to_value
[c
] << 12;
3280 c
= (unsigned char) (value
>> 16);
3281 if (multibyte
&& c
>= 128)
3282 e
+= BYTE8_STRING (c
, e
);
3287 /* Process third byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (-1);
3293 READ_QUADRUPLET_BYTE (-1);
3302 value
|= base64_char_to_value
[c
] << 6;
3304 c
= (unsigned char) (0xff & value
>> 8);
3305 if (multibyte
&& c
>= 128)
3306 e
+= BYTE8_STRING (c
, e
);
3311 /* Process fourth byte of a quadruplet. */
3313 READ_QUADRUPLET_BYTE (-1);
3320 value
|= base64_char_to_value
[c
];
3322 c
= (unsigned char) (0xff & value
);
3323 if (multibyte
&& c
>= 128)
3324 e
+= BYTE8_STRING (c
, e
);
3333 /***********************************************************************
3335 ***** Hash Tables *****
3337 ***********************************************************************/
3339 /* Implemented by gerd@gnu.org. This hash table implementation was
3340 inspired by CMUCL hash tables. */
3344 1. For small tables, association lists are probably faster than
3345 hash tables because they have lower overhead.
3347 For uses of hash tables where the O(1) behavior of table
3348 operations is not a requirement, it might therefore be a good idea
3349 not to hash. Instead, we could just do a linear search in the
3350 key_and_value vector of the hash table. This could be done
3351 if a `:linear-search t' argument is given to make-hash-table. */
3354 /* The list of all weak hash tables. Don't staticpro this one. */
3356 static struct Lisp_Hash_Table
*weak_hash_tables
;
3358 /* Various symbols. */
3360 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3361 Lisp_Object Qeq
, Qeql
, Qequal
;
3362 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3363 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3365 /* Function prototypes. */
3367 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3368 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3369 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3370 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3374 /***********************************************************************
3376 ***********************************************************************/
3378 /* If OBJ is a Lisp hash table, return a pointer to its struct
3379 Lisp_Hash_Table. Otherwise, signal an error. */
3381 static struct Lisp_Hash_Table
*
3382 check_hash_table (Lisp_Object obj
)
3384 CHECK_HASH_TABLE (obj
);
3385 return XHASH_TABLE (obj
);
3389 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3390 number. A number is "almost" a prime number if it is not divisible
3391 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3394 next_almost_prime (EMACS_INT n
)
3396 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3397 for (n
|= 1; ; n
+= 2)
3398 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3403 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3404 which USED[I] is non-zero. If found at index I in ARGS, set
3405 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3406 0. This function is used to extract a keyword/argument pair from
3407 a DEFUN parameter list. */
3410 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3414 for (i
= 1; i
< nargs
; i
++)
3415 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3426 /* Return a Lisp vector which has the same contents as VEC but has
3427 at least INCR_MIN more entries, where INCR_MIN is positive.
3428 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3429 than NITEMS_MAX. Entries in the resulting
3430 vector that are not copied from VEC are set to nil. */
3433 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t size_max
)
3435 struct Lisp_Vector
*v
;
3436 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3437 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3438 ptrdiff_t n_max
= (0 <= size_max
&& size_max
< C_language_max
3439 ? size_max
: C_language_max
);
3440 xassert (VECTORP (vec
));
3441 xassert (0 < incr_min
&& -1 <= size_max
);
3442 old_size
= ASIZE (vec
);
3443 incr_max
= n_max
- old_size
;
3444 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3445 if (incr_max
< incr
)
3446 memory_full (SIZE_MAX
);
3447 new_size
= old_size
+ incr
;
3448 v
= allocate_vector (new_size
);
3449 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3450 for (i
= old_size
; i
< new_size
; ++i
)
3451 v
->contents
[i
] = Qnil
;
3452 XSETVECTOR (vec
, v
);
3457 /***********************************************************************
3459 ***********************************************************************/
3461 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3462 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3463 KEY2 are the same. */
3466 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3467 Lisp_Object key1
, EMACS_UINT hash1
,
3468 Lisp_Object key2
, EMACS_UINT hash2
)
3470 return (FLOATP (key1
)
3472 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3476 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3477 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3478 KEY2 are the same. */
3481 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3482 Lisp_Object key1
, EMACS_UINT hash1
,
3483 Lisp_Object key2
, EMACS_UINT hash2
)
3485 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3489 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3490 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3491 if KEY1 and KEY2 are the same. */
3494 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3495 Lisp_Object key1
, EMACS_UINT hash1
,
3496 Lisp_Object key2
, EMACS_UINT hash2
)
3500 Lisp_Object args
[3];
3502 args
[0] = h
->user_cmp_function
;
3505 return !NILP (Ffuncall (3, args
));
3512 /* Value is a hash code for KEY for use in hash table H which uses
3513 `eq' to compare keys. The hash code returned is guaranteed to fit
3514 in a Lisp integer. */
3517 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3519 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3520 xassert ((hash
& ~INTMASK
) == 0);
3525 /* Value is a hash code for KEY for use in hash table H which uses
3526 `eql' to compare keys. The hash code returned is guaranteed to fit
3527 in a Lisp integer. */
3530 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3534 hash
= sxhash (key
, 0);
3536 hash
= XUINT (key
) ^ XTYPE (key
);
3537 xassert ((hash
& ~INTMASK
) == 0);
3542 /* Value is a hash code for KEY for use in hash table H which uses
3543 `equal' to compare keys. The hash code returned is guaranteed to fit
3544 in a Lisp integer. */
3547 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3549 EMACS_UINT hash
= sxhash (key
, 0);
3550 xassert ((hash
& ~INTMASK
) == 0);
3555 /* Value is a hash code for KEY for use in hash table H which uses as
3556 user-defined function to compare keys. The hash code returned is
3557 guaranteed to fit in a Lisp integer. */
3560 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3562 Lisp_Object args
[2], hash
;
3564 args
[0] = h
->user_hash_function
;
3566 hash
= Ffuncall (2, args
);
3567 if (!INTEGERP (hash
))
3568 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3569 return XUINT (hash
);
3572 /* An upper bound on the size of a hash table index. It must fit in
3573 ptrdiff_t and be a valid Emacs fixnum. */
3574 #define INDEX_SIZE_BOUND \
3575 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / sizeof (Lisp_Object)))
3577 /* Create and initialize a new hash table.
3579 TEST specifies the test the hash table will use to compare keys.
3580 It must be either one of the predefined tests `eq', `eql' or
3581 `equal' or a symbol denoting a user-defined test named TEST with
3582 test and hash functions USER_TEST and USER_HASH.
3584 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3586 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3587 new size when it becomes full is computed by adding REHASH_SIZE to
3588 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3589 table's new size is computed by multiplying its old size with
3592 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3593 be resized when the ratio of (number of entries in the table) /
3594 (table size) is >= REHASH_THRESHOLD.
3596 WEAK specifies the weakness of the table. If non-nil, it must be
3597 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3600 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3601 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3602 Lisp_Object user_test
, Lisp_Object user_hash
)
3604 struct Lisp_Hash_Table
*h
;
3606 EMACS_INT index_size
, sz
;
3610 /* Preconditions. */
3611 xassert (SYMBOLP (test
));
3612 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3613 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3614 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3615 xassert (FLOATP (rehash_threshold
)
3616 && 0 < XFLOAT_DATA (rehash_threshold
)
3617 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3619 if (XFASTINT (size
) == 0)
3620 size
= make_number (1);
3622 sz
= XFASTINT (size
);
3623 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3624 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3625 ? next_almost_prime (index_float
)
3626 : INDEX_SIZE_BOUND
+ 1);
3627 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3628 error ("Hash table too large");
3630 /* Allocate a table and initialize it. */
3631 h
= allocate_hash_table ();
3633 /* Initialize hash table slots. */
3635 if (EQ (test
, Qeql
))
3637 h
->cmpfn
= cmpfn_eql
;
3638 h
->hashfn
= hashfn_eql
;
3640 else if (EQ (test
, Qeq
))
3643 h
->hashfn
= hashfn_eq
;
3645 else if (EQ (test
, Qequal
))
3647 h
->cmpfn
= cmpfn_equal
;
3648 h
->hashfn
= hashfn_equal
;
3652 h
->user_cmp_function
= user_test
;
3653 h
->user_hash_function
= user_hash
;
3654 h
->cmpfn
= cmpfn_user_defined
;
3655 h
->hashfn
= hashfn_user_defined
;
3659 h
->rehash_threshold
= rehash_threshold
;
3660 h
->rehash_size
= rehash_size
;
3662 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3663 h
->hash
= Fmake_vector (size
, Qnil
);
3664 h
->next
= Fmake_vector (size
, Qnil
);
3665 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3667 /* Set up the free list. */
3668 for (i
= 0; i
< sz
- 1; ++i
)
3669 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3670 h
->next_free
= make_number (0);
3672 XSET_HASH_TABLE (table
, h
);
3673 xassert (HASH_TABLE_P (table
));
3674 xassert (XHASH_TABLE (table
) == h
);
3676 /* Maybe add this hash table to the list of all weak hash tables. */
3678 h
->next_weak
= NULL
;
3681 h
->next_weak
= weak_hash_tables
;
3682 weak_hash_tables
= h
;
3689 /* Return a copy of hash table H1. Keys and values are not copied,
3690 only the table itself is. */
3693 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3696 struct Lisp_Hash_Table
*h2
;
3697 struct Lisp_Vector
*next
;
3699 h2
= allocate_hash_table ();
3700 next
= h2
->header
.next
.vector
;
3701 memcpy (h2
, h1
, sizeof *h2
);
3702 h2
->header
.next
.vector
= next
;
3703 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3704 h2
->hash
= Fcopy_sequence (h1
->hash
);
3705 h2
->next
= Fcopy_sequence (h1
->next
);
3706 h2
->index
= Fcopy_sequence (h1
->index
);
3707 XSET_HASH_TABLE (table
, h2
);
3709 /* Maybe add this hash table to the list of all weak hash tables. */
3710 if (!NILP (h2
->weak
))
3712 h2
->next_weak
= weak_hash_tables
;
3713 weak_hash_tables
= h2
;
3720 /* Resize hash table H if it's too full. If H cannot be resized
3721 because it's already too large, throw an error. */
3724 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3726 if (NILP (h
->next_free
))
3728 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3729 EMACS_INT new_size
, index_size
, nsize
;
3733 if (INTEGERP (h
->rehash_size
))
3734 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3737 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3738 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3740 new_size
= float_new_size
;
3741 if (new_size
<= old_size
)
3742 new_size
= old_size
+ 1;
3745 new_size
= INDEX_SIZE_BOUND
+ 1;
3747 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3748 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3749 ? next_almost_prime (index_float
)
3750 : INDEX_SIZE_BOUND
+ 1);
3751 nsize
= max (index_size
, 2 * new_size
);
3752 if (INDEX_SIZE_BOUND
< nsize
)
3753 error ("Hash table too large to resize");
3755 h
->key_and_value
= larger_vector (h
->key_and_value
,
3756 2 * (new_size
- old_size
), -1);
3757 h
->next
= larger_vector (h
->next
, new_size
- old_size
, -1);
3758 h
->hash
= larger_vector (h
->hash
, new_size
- old_size
, -1);
3759 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3761 /* Update the free list. Do it so that new entries are added at
3762 the end of the free list. This makes some operations like
3764 for (i
= old_size
; i
< new_size
- 1; ++i
)
3765 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3767 if (!NILP (h
->next_free
))
3769 Lisp_Object last
, next
;
3771 last
= h
->next_free
;
3772 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3776 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3779 XSETFASTINT (h
->next_free
, old_size
);
3782 for (i
= 0; i
< old_size
; ++i
)
3783 if (!NILP (HASH_HASH (h
, i
)))
3785 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3786 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3787 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3788 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3794 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3795 the hash code of KEY. Value is the index of the entry in H
3796 matching KEY, or -1 if not found. */
3799 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3801 EMACS_UINT hash_code
;
3802 ptrdiff_t start_of_bucket
;
3805 hash_code
= h
->hashfn (h
, key
);
3809 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3810 idx
= HASH_INDEX (h
, start_of_bucket
);
3812 /* We need not gcpro idx since it's either an integer or nil. */
3815 ptrdiff_t i
= XFASTINT (idx
);
3816 if (EQ (key
, HASH_KEY (h
, i
))
3818 && h
->cmpfn (h
, key
, hash_code
,
3819 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3821 idx
= HASH_NEXT (h
, i
);
3824 return NILP (idx
) ? -1 : XFASTINT (idx
);
3828 /* Put an entry into hash table H that associates KEY with VALUE.
3829 HASH is a previously computed hash code of KEY.
3830 Value is the index of the entry in H matching KEY. */
3833 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3836 ptrdiff_t start_of_bucket
, i
;
3838 xassert ((hash
& ~INTMASK
) == 0);
3840 /* Increment count after resizing because resizing may fail. */
3841 maybe_resize_hash_table (h
);
3844 /* Store key/value in the key_and_value vector. */
3845 i
= XFASTINT (h
->next_free
);
3846 h
->next_free
= HASH_NEXT (h
, i
);
3847 HASH_KEY (h
, i
) = key
;
3848 HASH_VALUE (h
, i
) = value
;
3850 /* Remember its hash code. */
3851 HASH_HASH (h
, i
) = make_number (hash
);
3853 /* Add new entry to its collision chain. */
3854 start_of_bucket
= hash
% ASIZE (h
->index
);
3855 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3856 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3861 /* Remove the entry matching KEY from hash table H, if there is one. */
3864 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3866 EMACS_UINT hash_code
;
3867 ptrdiff_t start_of_bucket
;
3868 Lisp_Object idx
, prev
;
3870 hash_code
= h
->hashfn (h
, key
);
3871 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3872 idx
= HASH_INDEX (h
, start_of_bucket
);
3875 /* We need not gcpro idx, prev since they're either integers or nil. */
3878 ptrdiff_t i
= XFASTINT (idx
);
3880 if (EQ (key
, HASH_KEY (h
, i
))
3882 && h
->cmpfn (h
, key
, hash_code
,
3883 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3885 /* Take entry out of collision chain. */
3887 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3889 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3891 /* Clear slots in key_and_value and add the slots to
3893 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3894 HASH_NEXT (h
, i
) = h
->next_free
;
3895 h
->next_free
= make_number (i
);
3897 xassert (h
->count
>= 0);
3903 idx
= HASH_NEXT (h
, i
);
3909 /* Clear hash table H. */
3912 hash_clear (struct Lisp_Hash_Table
*h
)
3916 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3918 for (i
= 0; i
< size
; ++i
)
3920 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3921 HASH_KEY (h
, i
) = Qnil
;
3922 HASH_VALUE (h
, i
) = Qnil
;
3923 HASH_HASH (h
, i
) = Qnil
;
3926 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3927 ASET (h
->index
, i
, Qnil
);
3929 h
->next_free
= make_number (0);
3936 /************************************************************************
3938 ************************************************************************/
3941 init_weak_hash_tables (void)
3943 weak_hash_tables
= NULL
;
3946 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3947 entries from the table that don't survive the current GC.
3948 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3949 non-zero if anything was marked. */
3952 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3954 ptrdiff_t bucket
, n
;
3957 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3960 for (bucket
= 0; bucket
< n
; ++bucket
)
3962 Lisp_Object idx
, next
, prev
;
3964 /* Follow collision chain, removing entries that
3965 don't survive this garbage collection. */
3967 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3969 ptrdiff_t i
= XFASTINT (idx
);
3970 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3971 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3974 if (EQ (h
->weak
, Qkey
))
3975 remove_p
= !key_known_to_survive_p
;
3976 else if (EQ (h
->weak
, Qvalue
))
3977 remove_p
= !value_known_to_survive_p
;
3978 else if (EQ (h
->weak
, Qkey_or_value
))
3979 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3980 else if (EQ (h
->weak
, Qkey_and_value
))
3981 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3985 next
= HASH_NEXT (h
, i
);
3987 if (remove_entries_p
)
3991 /* Take out of collision chain. */
3993 HASH_INDEX (h
, bucket
) = next
;
3995 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3997 /* Add to free list. */
3998 HASH_NEXT (h
, i
) = h
->next_free
;
4001 /* Clear key, value, and hash. */
4002 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4003 HASH_HASH (h
, i
) = Qnil
;
4016 /* Make sure key and value survive. */
4017 if (!key_known_to_survive_p
)
4019 mark_object (HASH_KEY (h
, i
));
4023 if (!value_known_to_survive_p
)
4025 mark_object (HASH_VALUE (h
, i
));
4036 /* Remove elements from weak hash tables that don't survive the
4037 current garbage collection. Remove weak tables that don't survive
4038 from Vweak_hash_tables. Called from gc_sweep. */
4041 sweep_weak_hash_tables (void)
4043 struct Lisp_Hash_Table
*h
, *used
, *next
;
4046 /* Mark all keys and values that are in use. Keep on marking until
4047 there is no more change. This is necessary for cases like
4048 value-weak table A containing an entry X -> Y, where Y is used in a
4049 key-weak table B, Z -> Y. If B comes after A in the list of weak
4050 tables, X -> Y might be removed from A, although when looking at B
4051 one finds that it shouldn't. */
4055 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4057 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4058 marked
|= sweep_weak_table (h
, 0);
4063 /* Remove tables and entries that aren't used. */
4064 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4066 next
= h
->next_weak
;
4068 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4070 /* TABLE is marked as used. Sweep its contents. */
4072 sweep_weak_table (h
, 1);
4074 /* Add table to the list of used weak hash tables. */
4075 h
->next_weak
= used
;
4080 weak_hash_tables
= used
;
4085 /***********************************************************************
4086 Hash Code Computation
4087 ***********************************************************************/
4089 /* Maximum depth up to which to dive into Lisp structures. */
4091 #define SXHASH_MAX_DEPTH 3
4093 /* Maximum length up to which to take list and vector elements into
4096 #define SXHASH_MAX_LEN 7
4098 /* Combine two integers X and Y for hashing. The result might not fit
4099 into a Lisp integer. */
4101 #define SXHASH_COMBINE(X, Y) \
4102 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4105 /* Hash X, returning a value that fits into a Lisp integer. */
4106 #define SXHASH_REDUCE(X) \
4107 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4109 /* Return a hash for string PTR which has length LEN. The hash value
4110 can be any EMACS_UINT value. */
4113 hash_string (char const *ptr
, ptrdiff_t len
)
4115 char const *p
= ptr
;
4116 char const *end
= p
+ len
;
4118 EMACS_UINT hash
= 0;
4123 hash
= SXHASH_COMBINE (hash
, c
);
4129 /* Return a hash for string PTR which has length LEN. The hash
4130 code returned is guaranteed to fit in a Lisp integer. */
4133 sxhash_string (char const *ptr
, ptrdiff_t len
)
4135 EMACS_UINT hash
= hash_string (ptr
, len
);
4136 return SXHASH_REDUCE (hash
);
4139 /* Return a hash for the floating point value VAL. */
4142 sxhash_float (double val
)
4144 EMACS_UINT hash
= 0;
4146 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4147 + (sizeof val
% sizeof hash
!= 0))
4151 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4155 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4156 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4157 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4158 return SXHASH_REDUCE (hash
);
4161 /* Return a hash for list LIST. DEPTH is the current depth in the
4162 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4165 sxhash_list (Lisp_Object list
, int depth
)
4167 EMACS_UINT hash
= 0;
4170 if (depth
< SXHASH_MAX_DEPTH
)
4172 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4173 list
= XCDR (list
), ++i
)
4175 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4176 hash
= SXHASH_COMBINE (hash
, hash2
);
4181 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4182 hash
= SXHASH_COMBINE (hash
, hash2
);
4185 return SXHASH_REDUCE (hash
);
4189 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4190 the Lisp structure. */
4193 sxhash_vector (Lisp_Object vec
, int depth
)
4195 EMACS_UINT hash
= ASIZE (vec
);
4198 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4199 for (i
= 0; i
< n
; ++i
)
4201 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4202 hash
= SXHASH_COMBINE (hash
, hash2
);
4205 return SXHASH_REDUCE (hash
);
4208 /* Return a hash for bool-vector VECTOR. */
4211 sxhash_bool_vector (Lisp_Object vec
)
4213 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4216 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4217 for (i
= 0; i
< n
; ++i
)
4218 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4220 return SXHASH_REDUCE (hash
);
4224 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4225 structure. Value is an unsigned integer clipped to INTMASK. */
4228 sxhash (Lisp_Object obj
, int depth
)
4232 if (depth
> SXHASH_MAX_DEPTH
)
4235 switch (XTYPE (obj
))
4246 obj
= SYMBOL_NAME (obj
);
4250 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4253 /* This can be everything from a vector to an overlay. */
4254 case Lisp_Vectorlike
:
4256 /* According to the CL HyperSpec, two arrays are equal only if
4257 they are `eq', except for strings and bit-vectors. In
4258 Emacs, this works differently. We have to compare element
4260 hash
= sxhash_vector (obj
, depth
);
4261 else if (BOOL_VECTOR_P (obj
))
4262 hash
= sxhash_bool_vector (obj
);
4264 /* Others are `equal' if they are `eq', so let's take their
4270 hash
= sxhash_list (obj
, depth
);
4274 hash
= sxhash_float (XFLOAT_DATA (obj
));
4286 /***********************************************************************
4288 ***********************************************************************/
4291 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4292 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4295 EMACS_UINT hash
= sxhash (obj
, 0);
4296 return make_number (hash
);
4300 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4301 doc
: /* Create and return a new hash table.
4303 Arguments are specified as keyword/argument pairs. The following
4304 arguments are defined:
4306 :test TEST -- TEST must be a symbol that specifies how to compare
4307 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4308 `equal'. User-supplied test and hash functions can be specified via
4309 `define-hash-table-test'.
4311 :size SIZE -- A hint as to how many elements will be put in the table.
4314 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4315 fills up. If REHASH-SIZE is an integer, increase the size by that
4316 amount. If it is a float, it must be > 1.0, and the new size is the
4317 old size multiplied by that factor. Default is 1.5.
4319 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4320 Resize the hash table when the ratio (number of entries / table size)
4321 is greater than or equal to THRESHOLD. Default is 0.8.
4323 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4324 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4325 returned is a weak table. Key/value pairs are removed from a weak
4326 hash table when there are no non-weak references pointing to their
4327 key, value, one of key or value, or both key and value, depending on
4328 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4331 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4332 (ptrdiff_t nargs
, Lisp_Object
*args
)
4334 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4335 Lisp_Object user_test
, user_hash
;
4339 /* The vector `used' is used to keep track of arguments that
4340 have been consumed. */
4341 used
= (char *) alloca (nargs
* sizeof *used
);
4342 memset (used
, 0, nargs
* sizeof *used
);
4344 /* See if there's a `:test TEST' among the arguments. */
4345 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4346 test
= i
? args
[i
] : Qeql
;
4347 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4349 /* See if it is a user-defined test. */
4352 prop
= Fget (test
, Qhash_table_test
);
4353 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4354 signal_error ("Invalid hash table test", test
);
4355 user_test
= XCAR (prop
);
4356 user_hash
= XCAR (XCDR (prop
));
4359 user_test
= user_hash
= Qnil
;
4361 /* See if there's a `:size SIZE' argument. */
4362 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4363 size
= i
? args
[i
] : Qnil
;
4365 size
= make_number (DEFAULT_HASH_SIZE
);
4366 else if (!INTEGERP (size
) || XINT (size
) < 0)
4367 signal_error ("Invalid hash table size", size
);
4369 /* Look for `:rehash-size SIZE'. */
4370 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4371 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4372 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4373 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4374 signal_error ("Invalid hash table rehash size", rehash_size
);
4376 /* Look for `:rehash-threshold THRESHOLD'. */
4377 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4378 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4379 if (! (FLOATP (rehash_threshold
)
4380 && 0 < XFLOAT_DATA (rehash_threshold
)
4381 && XFLOAT_DATA (rehash_threshold
) <= 1))
4382 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4384 /* Look for `:weakness WEAK'. */
4385 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4386 weak
= i
? args
[i
] : Qnil
;
4388 weak
= Qkey_and_value
;
4391 && !EQ (weak
, Qvalue
)
4392 && !EQ (weak
, Qkey_or_value
)
4393 && !EQ (weak
, Qkey_and_value
))
4394 signal_error ("Invalid hash table weakness", weak
);
4396 /* Now, all args should have been used up, or there's a problem. */
4397 for (i
= 0; i
< nargs
; ++i
)
4399 signal_error ("Invalid argument list", args
[i
]);
4401 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4402 user_test
, user_hash
);
4406 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4407 doc
: /* Return a copy of hash table TABLE. */)
4410 return copy_hash_table (check_hash_table (table
));
4414 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4415 doc
: /* Return the number of elements in TABLE. */)
4418 return make_number (check_hash_table (table
)->count
);
4422 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4423 Shash_table_rehash_size
, 1, 1, 0,
4424 doc
: /* Return the current rehash size of TABLE. */)
4427 return check_hash_table (table
)->rehash_size
;
4431 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4432 Shash_table_rehash_threshold
, 1, 1, 0,
4433 doc
: /* Return the current rehash threshold of TABLE. */)
4436 return check_hash_table (table
)->rehash_threshold
;
4440 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4441 doc
: /* Return the size of TABLE.
4442 The size can be used as an argument to `make-hash-table' to create
4443 a hash table than can hold as many elements as TABLE holds
4444 without need for resizing. */)
4447 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4448 return make_number (HASH_TABLE_SIZE (h
));
4452 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4453 doc
: /* Return the test TABLE uses. */)
4456 return check_hash_table (table
)->test
;
4460 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4462 doc
: /* Return the weakness of TABLE. */)
4465 return check_hash_table (table
)->weak
;
4469 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4470 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4473 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4477 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4478 doc
: /* Clear hash table TABLE and return it. */)
4481 hash_clear (check_hash_table (table
));
4482 /* Be compatible with XEmacs. */
4487 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4488 doc
: /* Look up KEY in TABLE and return its associated value.
4489 If KEY is not found, return DFLT which defaults to nil. */)
4490 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4492 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4493 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4494 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4498 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4499 doc
: /* Associate KEY with VALUE in hash table TABLE.
4500 If KEY is already present in table, replace its current value with
4501 VALUE. In any case, return VALUE. */)
4502 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4504 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4508 i
= hash_lookup (h
, key
, &hash
);
4510 HASH_VALUE (h
, i
) = value
;
4512 hash_put (h
, key
, value
, hash
);
4518 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4519 doc
: /* Remove KEY from TABLE. */)
4520 (Lisp_Object key
, Lisp_Object table
)
4522 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4523 hash_remove_from_table (h
, key
);
4528 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4529 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4530 FUNCTION is called with two arguments, KEY and VALUE. */)
4531 (Lisp_Object function
, Lisp_Object table
)
4533 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4534 Lisp_Object args
[3];
4537 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4538 if (!NILP (HASH_HASH (h
, i
)))
4541 args
[1] = HASH_KEY (h
, i
);
4542 args
[2] = HASH_VALUE (h
, i
);
4550 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4551 Sdefine_hash_table_test
, 3, 3, 0,
4552 doc
: /* Define a new hash table test with name NAME, a symbol.
4554 In hash tables created with NAME specified as test, use TEST to
4555 compare keys, and HASH for computing hash codes of keys.
4557 TEST must be a function taking two arguments and returning non-nil if
4558 both arguments are the same. HASH must be a function taking one
4559 argument and return an integer that is the hash code of the argument.
4560 Hash code computation should use the whole value range of integers,
4561 including negative integers. */)
4562 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4564 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4569 /************************************************************************
4570 MD5, SHA-1, and SHA-2
4571 ************************************************************************/
4578 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4581 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4585 EMACS_INT start_char
= 0, end_char
= 0;
4586 ptrdiff_t start_byte
, end_byte
;
4587 register EMACS_INT b
, e
;
4588 register struct buffer
*bp
;
4591 void *(*hash_func
) (const char *, size_t, void *);
4594 CHECK_SYMBOL (algorithm
);
4596 if (STRINGP (object
))
4598 if (NILP (coding_system
))
4600 /* Decide the coding-system to encode the data with. */
4602 if (STRING_MULTIBYTE (object
))
4603 /* use default, we can't guess correct value */
4604 coding_system
= preferred_coding_system ();
4606 coding_system
= Qraw_text
;
4609 if (NILP (Fcoding_system_p (coding_system
)))
4611 /* Invalid coding system. */
4613 if (!NILP (noerror
))
4614 coding_system
= Qraw_text
;
4616 xsignal1 (Qcoding_system_error
, coding_system
);
4619 if (STRING_MULTIBYTE (object
))
4620 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4622 size
= SCHARS (object
);
4626 CHECK_NUMBER (start
);
4628 start_char
= XINT (start
);
4640 end_char
= XINT (end
);
4646 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4647 args_out_of_range_3 (object
, make_number (start_char
),
4648 make_number (end_char
));
4650 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4652 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4656 struct buffer
*prev
= current_buffer
;
4658 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4660 CHECK_BUFFER (object
);
4662 bp
= XBUFFER (object
);
4663 if (bp
!= current_buffer
)
4664 set_buffer_internal (bp
);
4670 CHECK_NUMBER_COERCE_MARKER (start
);
4678 CHECK_NUMBER_COERCE_MARKER (end
);
4683 temp
= b
, b
= e
, e
= temp
;
4685 if (!(BEGV
<= b
&& e
<= ZV
))
4686 args_out_of_range (start
, end
);
4688 if (NILP (coding_system
))
4690 /* Decide the coding-system to encode the data with.
4691 See fileio.c:Fwrite-region */
4693 if (!NILP (Vcoding_system_for_write
))
4694 coding_system
= Vcoding_system_for_write
;
4697 int force_raw_text
= 0;
4699 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4700 if (NILP (coding_system
)
4701 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4703 coding_system
= Qnil
;
4704 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4708 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4710 /* Check file-coding-system-alist. */
4711 Lisp_Object args
[4], val
;
4713 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4714 args
[3] = Fbuffer_file_name (object
);
4715 val
= Ffind_operation_coding_system (4, args
);
4716 if (CONSP (val
) && !NILP (XCDR (val
)))
4717 coding_system
= XCDR (val
);
4720 if (NILP (coding_system
)
4721 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4723 /* If we still have not decided a coding system, use the
4724 default value of buffer-file-coding-system. */
4725 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4729 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4730 /* Confirm that VAL can surely encode the current region. */
4731 coding_system
= call4 (Vselect_safe_coding_system_function
,
4732 make_number (b
), make_number (e
),
4733 coding_system
, Qnil
);
4736 coding_system
= Qraw_text
;
4739 if (NILP (Fcoding_system_p (coding_system
)))
4741 /* Invalid coding system. */
4743 if (!NILP (noerror
))
4744 coding_system
= Qraw_text
;
4746 xsignal1 (Qcoding_system_error
, coding_system
);
4750 object
= make_buffer_string (b
, e
, 0);
4751 if (prev
!= current_buffer
)
4752 set_buffer_internal (prev
);
4753 /* Discard the unwind protect for recovering the current
4757 if (STRING_MULTIBYTE (object
))
4758 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4760 end_byte
= SBYTES (object
);
4763 if (EQ (algorithm
, Qmd5
))
4765 digest_size
= MD5_DIGEST_SIZE
;
4766 hash_func
= md5_buffer
;
4768 else if (EQ (algorithm
, Qsha1
))
4770 digest_size
= SHA1_DIGEST_SIZE
;
4771 hash_func
= sha1_buffer
;
4773 else if (EQ (algorithm
, Qsha224
))
4775 digest_size
= SHA224_DIGEST_SIZE
;
4776 hash_func
= sha224_buffer
;
4778 else if (EQ (algorithm
, Qsha256
))
4780 digest_size
= SHA256_DIGEST_SIZE
;
4781 hash_func
= sha256_buffer
;
4783 else if (EQ (algorithm
, Qsha384
))
4785 digest_size
= SHA384_DIGEST_SIZE
;
4786 hash_func
= sha384_buffer
;
4788 else if (EQ (algorithm
, Qsha512
))
4790 digest_size
= SHA512_DIGEST_SIZE
;
4791 hash_func
= sha512_buffer
;
4794 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4796 /* allocate 2 x digest_size so that it can be re-used to hold the
4798 digest
= make_uninit_string (digest_size
* 2);
4800 hash_func (SSDATA (object
) + start_byte
,
4801 end_byte
- start_byte
,
4806 unsigned char *p
= SDATA (digest
);
4807 for (i
= digest_size
- 1; i
>= 0; i
--)
4809 static char const hexdigit
[16] = "0123456789abcdef";
4811 p
[2 * i
] = hexdigit
[p_i
>> 4];
4812 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4817 return make_unibyte_string (SSDATA (digest
), digest_size
);
4820 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4821 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4823 A message digest is a cryptographic checksum of a document, and the
4824 algorithm to calculate it is defined in RFC 1321.
4826 The two optional arguments START and END are character positions
4827 specifying for which part of OBJECT the message digest should be
4828 computed. If nil or omitted, the digest is computed for the whole
4831 The MD5 message digest is computed from the result of encoding the
4832 text in a coding system, not directly from the internal Emacs form of
4833 the text. The optional fourth argument CODING-SYSTEM specifies which
4834 coding system to encode the text with. It should be the same coding
4835 system that you used or will use when actually writing the text into a
4838 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4839 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4840 system would be chosen by default for writing this text into a file.
4842 If OBJECT is a string, the most preferred coding system (see the
4843 command `prefer-coding-system') is used.
4845 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4846 guesswork fails. Normally, an error is signaled in such case. */)
4847 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4849 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4852 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4853 doc
: /* Return the secure hash of an OBJECT.
4854 ALGORITHM is a symbol: md5, sha1, sha224, sha256, sha384 or sha512.
4855 OBJECT is either a string or a buffer.
4856 Optional arguments START and END are character positions specifying
4857 which portion of OBJECT for computing the hash. If BINARY is non-nil,
4858 return a string in binary form. */)
4859 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4861 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4867 DEFSYM (Qmd5
, "md5");
4868 DEFSYM (Qsha1
, "sha1");
4869 DEFSYM (Qsha224
, "sha224");
4870 DEFSYM (Qsha256
, "sha256");
4871 DEFSYM (Qsha384
, "sha384");
4872 DEFSYM (Qsha512
, "sha512");
4874 /* Hash table stuff. */
4875 DEFSYM (Qhash_table_p
, "hash-table-p");
4877 DEFSYM (Qeql
, "eql");
4878 DEFSYM (Qequal
, "equal");
4879 DEFSYM (QCtest
, ":test");
4880 DEFSYM (QCsize
, ":size");
4881 DEFSYM (QCrehash_size
, ":rehash-size");
4882 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4883 DEFSYM (QCweakness
, ":weakness");
4884 DEFSYM (Qkey
, "key");
4885 DEFSYM (Qvalue
, "value");
4886 DEFSYM (Qhash_table_test
, "hash-table-test");
4887 DEFSYM (Qkey_or_value
, "key-or-value");
4888 DEFSYM (Qkey_and_value
, "key-and-value");
4891 defsubr (&Smake_hash_table
);
4892 defsubr (&Scopy_hash_table
);
4893 defsubr (&Shash_table_count
);
4894 defsubr (&Shash_table_rehash_size
);
4895 defsubr (&Shash_table_rehash_threshold
);
4896 defsubr (&Shash_table_size
);
4897 defsubr (&Shash_table_test
);
4898 defsubr (&Shash_table_weakness
);
4899 defsubr (&Shash_table_p
);
4900 defsubr (&Sclrhash
);
4901 defsubr (&Sgethash
);
4902 defsubr (&Sputhash
);
4903 defsubr (&Sremhash
);
4904 defsubr (&Smaphash
);
4905 defsubr (&Sdefine_hash_table_test
);
4907 DEFSYM (Qstring_lessp
, "string-lessp");
4908 DEFSYM (Qprovide
, "provide");
4909 DEFSYM (Qrequire
, "require");
4910 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4911 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4912 DEFSYM (Qwidget_type
, "widget-type");
4914 staticpro (&string_char_byte_cache_string
);
4915 string_char_byte_cache_string
= Qnil
;
4917 require_nesting_list
= Qnil
;
4918 staticpro (&require_nesting_list
);
4920 Fset (Qyes_or_no_p_history
, Qnil
);
4922 DEFVAR_LISP ("features", Vfeatures
,
4923 doc
: /* A list of symbols which are the features of the executing Emacs.
4924 Used by `featurep' and `require', and altered by `provide'. */);
4925 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4926 DEFSYM (Qsubfeatures
, "subfeatures");
4928 #ifdef HAVE_LANGINFO_CODESET
4929 DEFSYM (Qcodeset
, "codeset");
4930 DEFSYM (Qdays
, "days");
4931 DEFSYM (Qmonths
, "months");
4932 DEFSYM (Qpaper
, "paper");
4933 #endif /* HAVE_LANGINFO_CODESET */
4935 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4936 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4937 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4938 invoked by mouse clicks and mouse menu items.
4940 On some platforms, file selection dialogs are also enabled if this is
4944 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4945 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4946 This applies to commands from menus and tool bar buttons even when
4947 they are initiated from the keyboard. If `use-dialog-box' is nil,
4948 that disables the use of a file dialog, regardless of the value of
4950 use_file_dialog
= 1;
4952 defsubr (&Sidentity
);
4955 defsubr (&Ssafe_length
);
4956 defsubr (&Sstring_bytes
);
4957 defsubr (&Sstring_equal
);
4958 defsubr (&Scompare_strings
);
4959 defsubr (&Sstring_lessp
);
4962 defsubr (&Svconcat
);
4963 defsubr (&Scopy_sequence
);
4964 defsubr (&Sstring_make_multibyte
);
4965 defsubr (&Sstring_make_unibyte
);
4966 defsubr (&Sstring_as_multibyte
);
4967 defsubr (&Sstring_as_unibyte
);
4968 defsubr (&Sstring_to_multibyte
);
4969 defsubr (&Sstring_to_unibyte
);
4970 defsubr (&Scopy_alist
);
4971 defsubr (&Ssubstring
);
4972 defsubr (&Ssubstring_no_properties
);
4985 defsubr (&Snreverse
);
4986 defsubr (&Sreverse
);
4988 defsubr (&Splist_get
);
4990 defsubr (&Splist_put
);
4992 defsubr (&Slax_plist_get
);
4993 defsubr (&Slax_plist_put
);
4996 defsubr (&Sequal_including_properties
);
4997 defsubr (&Sfillarray
);
4998 defsubr (&Sclear_string
);
5002 defsubr (&Smapconcat
);
5003 defsubr (&Syes_or_no_p
);
5004 defsubr (&Sload_average
);
5005 defsubr (&Sfeaturep
);
5006 defsubr (&Srequire
);
5007 defsubr (&Sprovide
);
5008 defsubr (&Splist_member
);
5009 defsubr (&Swidget_put
);
5010 defsubr (&Swidget_get
);
5011 defsubr (&Swidget_apply
);
5012 defsubr (&Sbase64_encode_region
);
5013 defsubr (&Sbase64_decode_region
);
5014 defsubr (&Sbase64_encode_string
);
5015 defsubr (&Sbase64_decode_string
);
5017 defsubr (&Ssecure_hash
);
5018 defsubr (&Slocale_info
);