1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2012
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
43 #endif /* HAVE_MENUS */
45 Lisp_Object Qstring_lessp
;
46 static Lisp_Object Qprovide
, Qrequire
;
47 static Lisp_Object Qyes_or_no_p_history
;
48 Lisp_Object Qcursor_in_echo_area
;
49 static Lisp_Object Qwidget_type
;
50 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
52 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
54 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
60 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
61 doc
: /* Return the argument unchanged. */)
67 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
68 doc
: /* Return a pseudo-random number.
69 All integers representable in Lisp are equally likely.
70 On most systems, this is 29 bits' worth.
71 With positive integer LIMIT, return random number in interval [0,LIMIT).
72 With argument t, set the random number seed from the current time and pid.
73 Other values of LIMIT are ignored. */)
77 Lisp_Object lispy_val
;
81 EMACS_TIME t
= current_emacs_time ();
82 seed_random (getpid () ^ EMACS_SECS (t
) ^ EMACS_NSECS (t
));
85 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
87 /* Try to take our random number from the higher bits of VAL,
88 not the lower, since (says Gentzel) the low bits of `random'
89 are less random than the higher ones. We do this by using the
90 quotient rather than the remainder. At the high end of the RNG
91 it's possible to get a quotient larger than n; discarding
92 these values eliminates the bias that would otherwise appear
93 when using a large n. */
94 EMACS_INT denominator
= (INTMASK
+ 1) / XFASTINT (limit
);
96 val
= get_random () / denominator
;
97 while (val
>= XFASTINT (limit
));
101 XSETINT (lispy_val
, val
);
105 /* Heuristic on how many iterations of a tight loop can be safely done
106 before it's time to do a QUIT. This must be a power of 2. */
107 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
109 /* Random data-structure functions */
111 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
112 doc
: /* Return the length of vector, list or string SEQUENCE.
113 A byte-code function object is also allowed.
114 If the string contains multibyte characters, this is not necessarily
115 the number of bytes in the string; it is the number of characters.
116 To get the number of bytes, use `string-bytes'. */)
117 (register Lisp_Object sequence
)
119 register Lisp_Object val
;
121 if (STRINGP (sequence
))
122 XSETFASTINT (val
, SCHARS (sequence
));
123 else if (VECTORP (sequence
))
124 XSETFASTINT (val
, ASIZE (sequence
));
125 else if (CHAR_TABLE_P (sequence
))
126 XSETFASTINT (val
, MAX_CHAR
);
127 else if (BOOL_VECTOR_P (sequence
))
128 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
129 else if (COMPILEDP (sequence
))
130 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
131 else if (CONSP (sequence
))
138 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
140 if (MOST_POSITIVE_FIXNUM
< i
)
141 error ("List too long");
144 sequence
= XCDR (sequence
);
146 while (CONSP (sequence
));
148 CHECK_LIST_END (sequence
, sequence
);
150 val
= make_number (i
);
152 else if (NILP (sequence
))
153 XSETFASTINT (val
, 0);
155 wrong_type_argument (Qsequencep
, sequence
);
160 /* This does not check for quits. That is safe since it must terminate. */
162 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
163 doc
: /* Return the length of a list, but avoid error or infinite loop.
164 This function never gets an error. If LIST is not really a list,
165 it returns 0. If LIST is circular, it returns a finite value
166 which is at least the number of distinct elements. */)
169 Lisp_Object tail
, halftail
;
174 return make_number (0);
176 /* halftail is used to detect circular lists. */
177 for (tail
= halftail
= list
; ; )
182 if (EQ (tail
, halftail
))
185 if ((lolen
& 1) == 0)
187 halftail
= XCDR (halftail
);
188 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
192 hilen
+= UINTMAX_MAX
+ 1.0;
197 /* If the length does not fit into a fixnum, return a float.
198 On all known practical machines this returns an upper bound on
200 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
203 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
204 doc
: /* Return the number of bytes in STRING.
205 If STRING is multibyte, this may be greater than the length of STRING. */)
208 CHECK_STRING (string
);
209 return make_number (SBYTES (string
));
212 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
213 doc
: /* Return t if two strings have identical contents.
214 Case is significant, but text properties are ignored.
215 Symbols are also allowed; their print names are used instead. */)
216 (register Lisp_Object s1
, Lisp_Object s2
)
219 s1
= SYMBOL_NAME (s1
);
221 s2
= SYMBOL_NAME (s2
);
225 if (SCHARS (s1
) != SCHARS (s2
)
226 || SBYTES (s1
) != SBYTES (s2
)
227 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
232 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
233 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
234 In string STR1, skip the first START1 characters and stop at END1.
235 In string STR2, skip the first START2 characters and stop at END2.
236 END1 and END2 default to the full lengths of the respective strings.
238 Case is significant in this comparison if IGNORE-CASE is nil.
239 Unibyte strings are converted to multibyte for comparison.
241 The value is t if the strings (or specified portions) match.
242 If string STR1 is less, the value is a negative number N;
243 - 1 - N is the number of characters that match at the beginning.
244 If string STR1 is greater, the value is a positive number N;
245 N - 1 is the number of characters that match at the beginning. */)
246 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
248 register ptrdiff_t end1_char
, end2_char
;
249 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
254 start1
= make_number (0);
256 start2
= make_number (0);
257 CHECK_NATNUM (start1
);
258 CHECK_NATNUM (start2
);
264 end1_char
= SCHARS (str1
);
265 if (! NILP (end1
) && end1_char
> XINT (end1
))
266 end1_char
= XINT (end1
);
267 if (end1_char
< XINT (start1
))
268 args_out_of_range (str1
, start1
);
270 end2_char
= SCHARS (str2
);
271 if (! NILP (end2
) && end2_char
> XINT (end2
))
272 end2_char
= XINT (end2
);
273 if (end2_char
< XINT (start2
))
274 args_out_of_range (str2
, start2
);
279 i1_byte
= string_char_to_byte (str1
, i1
);
280 i2_byte
= string_char_to_byte (str2
, i2
);
282 while (i1
< end1_char
&& i2
< end2_char
)
284 /* When we find a mismatch, we must compare the
285 characters, not just the bytes. */
288 if (STRING_MULTIBYTE (str1
))
289 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
292 c1
= SREF (str1
, i1
++);
293 MAKE_CHAR_MULTIBYTE (c1
);
296 if (STRING_MULTIBYTE (str2
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
300 c2
= SREF (str2
, i2
++);
301 MAKE_CHAR_MULTIBYTE (c2
);
307 if (! NILP (ignore_case
))
311 tem
= Fupcase (make_number (c1
));
313 tem
= Fupcase (make_number (c2
));
320 /* Note that I1 has already been incremented
321 past the character that we are comparing;
322 hence we don't add or subtract 1 here. */
324 return make_number (- i1
+ XINT (start1
));
326 return make_number (i1
- XINT (start1
));
330 return make_number (i1
- XINT (start1
) + 1);
332 return make_number (- i1
+ XINT (start1
) - 1);
337 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
338 doc
: /* Return t if first arg string is less than second in lexicographic order.
340 Symbols are also allowed; their print names are used instead. */)
341 (register Lisp_Object s1
, Lisp_Object s2
)
343 register ptrdiff_t end
;
344 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
347 s1
= SYMBOL_NAME (s1
);
349 s2
= SYMBOL_NAME (s2
);
353 i1
= i1_byte
= i2
= i2_byte
= 0;
356 if (end
> SCHARS (s2
))
361 /* When we find a mismatch, we must compare the
362 characters, not just the bytes. */
365 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
366 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
369 return c1
< c2
? Qt
: Qnil
;
371 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
374 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
375 enum Lisp_Type target_type
, int last_special
);
379 concat2 (Lisp_Object s1
, Lisp_Object s2
)
384 return concat (2, args
, Lisp_String
, 0);
389 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
395 return concat (3, args
, Lisp_String
, 0);
398 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
399 doc
: /* Concatenate all the arguments and make the result a list.
400 The result is a list whose elements are the elements of all the arguments.
401 Each argument may be a list, vector or string.
402 The last argument is not copied, just used as the tail of the new list.
403 usage: (append &rest SEQUENCES) */)
404 (ptrdiff_t nargs
, Lisp_Object
*args
)
406 return concat (nargs
, args
, Lisp_Cons
, 1);
409 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
410 doc
: /* Concatenate all the arguments and make the result a string.
411 The result is a string whose elements are the elements of all the arguments.
412 Each argument may be a string or a list or vector of characters (integers).
413 usage: (concat &rest SEQUENCES) */)
414 (ptrdiff_t nargs
, Lisp_Object
*args
)
416 return concat (nargs
, args
, Lisp_String
, 0);
419 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
420 doc
: /* Concatenate all the arguments and make the result a vector.
421 The result is a vector whose elements are the elements of all the arguments.
422 Each argument may be a list, vector or string.
423 usage: (vconcat &rest SEQUENCES) */)
424 (ptrdiff_t nargs
, Lisp_Object
*args
)
426 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
430 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
431 doc
: /* Return a copy of a list, vector, string or char-table.
432 The elements of a list or vector are not copied; they are shared
433 with the original. */)
436 if (NILP (arg
)) return arg
;
438 if (CHAR_TABLE_P (arg
))
440 return copy_char_table (arg
);
443 if (BOOL_VECTOR_P (arg
))
446 ptrdiff_t size_in_chars
447 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
448 / BOOL_VECTOR_BITS_PER_CHAR
);
450 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
451 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
456 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
457 wrong_type_argument (Qsequencep
, arg
);
459 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
462 /* This structure holds information of an argument of `concat' that is
463 a string and has text properties to be copied. */
466 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
467 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
468 ptrdiff_t to
; /* refer to VAL (the target string) */
472 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
473 enum Lisp_Type target_type
, int last_special
)
476 register Lisp_Object tail
;
477 register Lisp_Object
this;
479 ptrdiff_t toindex_byte
= 0;
480 register EMACS_INT result_len
;
481 register EMACS_INT result_len_byte
;
483 Lisp_Object last_tail
;
486 /* When we make a multibyte string, we can't copy text properties
487 while concatenating each string because the length of resulting
488 string can't be decided until we finish the whole concatenation.
489 So, we record strings that have text properties to be copied
490 here, and copy the text properties after the concatenation. */
491 struct textprop_rec
*textprops
= NULL
;
492 /* Number of elements in textprops. */
493 ptrdiff_t num_textprops
= 0;
498 /* In append, the last arg isn't treated like the others */
499 if (last_special
&& nargs
> 0)
502 last_tail
= args
[nargs
];
507 /* Check each argument. */
508 for (argnum
= 0; argnum
< nargs
; argnum
++)
511 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
512 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
513 wrong_type_argument (Qsequencep
, this);
516 /* Compute total length in chars of arguments in RESULT_LEN.
517 If desired output is a string, also compute length in bytes
518 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
519 whether the result should be a multibyte string. */
523 for (argnum
= 0; argnum
< nargs
; argnum
++)
527 len
= XFASTINT (Flength (this));
528 if (target_type
== Lisp_String
)
530 /* We must count the number of bytes needed in the string
531 as well as the number of characters. */
535 ptrdiff_t this_len_byte
;
537 if (VECTORP (this) || COMPILEDP (this))
538 for (i
= 0; i
< len
; i
++)
541 CHECK_CHARACTER (ch
);
543 this_len_byte
= CHAR_BYTES (c
);
544 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
546 result_len_byte
+= this_len_byte
;
547 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
550 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
551 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
552 else if (CONSP (this))
553 for (; CONSP (this); this = XCDR (this))
556 CHECK_CHARACTER (ch
);
558 this_len_byte
= CHAR_BYTES (c
);
559 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
561 result_len_byte
+= this_len_byte
;
562 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
565 else if (STRINGP (this))
567 if (STRING_MULTIBYTE (this))
570 this_len_byte
= SBYTES (this);
573 this_len_byte
= count_size_as_multibyte (SDATA (this),
575 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
577 result_len_byte
+= this_len_byte
;
582 if (MOST_POSITIVE_FIXNUM
< result_len
)
583 memory_full (SIZE_MAX
);
586 if (! some_multibyte
)
587 result_len_byte
= result_len
;
589 /* Create the output object. */
590 if (target_type
== Lisp_Cons
)
591 val
= Fmake_list (make_number (result_len
), Qnil
);
592 else if (target_type
== Lisp_Vectorlike
)
593 val
= Fmake_vector (make_number (result_len
), Qnil
);
594 else if (some_multibyte
)
595 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
597 val
= make_uninit_string (result_len
);
599 /* In `append', if all but last arg are nil, return last arg. */
600 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
603 /* Copy the contents of the args into the result. */
605 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
607 toindex
= 0, toindex_byte
= 0;
611 SAFE_NALLOCA (textprops
, 1, nargs
);
613 for (argnum
= 0; argnum
< nargs
; argnum
++)
616 ptrdiff_t thisleni
= 0;
617 register ptrdiff_t thisindex
= 0;
618 register ptrdiff_t thisindex_byte
= 0;
622 thislen
= Flength (this), thisleni
= XINT (thislen
);
624 /* Between strings of the same kind, copy fast. */
625 if (STRINGP (this) && STRINGP (val
)
626 && STRING_MULTIBYTE (this) == some_multibyte
)
628 ptrdiff_t thislen_byte
= SBYTES (this);
630 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
631 if (string_intervals (this))
633 textprops
[num_textprops
].argnum
= argnum
;
634 textprops
[num_textprops
].from
= 0;
635 textprops
[num_textprops
++].to
= toindex
;
637 toindex_byte
+= thislen_byte
;
640 /* Copy a single-byte string to a multibyte string. */
641 else if (STRINGP (this) && STRINGP (val
))
643 if (string_intervals (this))
645 textprops
[num_textprops
].argnum
= argnum
;
646 textprops
[num_textprops
].from
= 0;
647 textprops
[num_textprops
++].to
= toindex
;
649 toindex_byte
+= copy_text (SDATA (this),
650 SDATA (val
) + toindex_byte
,
651 SCHARS (this), 0, 1);
655 /* Copy element by element. */
658 register Lisp_Object elt
;
660 /* Fetch next element of `this' arg into `elt', or break if
661 `this' is exhausted. */
662 if (NILP (this)) break;
664 elt
= XCAR (this), this = XCDR (this);
665 else if (thisindex
>= thisleni
)
667 else if (STRINGP (this))
670 if (STRING_MULTIBYTE (this))
671 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
676 c
= SREF (this, thisindex
); thisindex
++;
677 if (some_multibyte
&& !ASCII_CHAR_P (c
))
678 c
= BYTE8_TO_CHAR (c
);
680 XSETFASTINT (elt
, c
);
682 else if (BOOL_VECTOR_P (this))
685 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
686 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
694 elt
= AREF (this, thisindex
);
698 /* Store this element into the result. */
705 else if (VECTORP (val
))
707 ASET (val
, toindex
, elt
);
713 CHECK_CHARACTER (elt
);
716 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
718 SSET (val
, toindex_byte
++, c
);
724 XSETCDR (prev
, last_tail
);
726 if (num_textprops
> 0)
729 ptrdiff_t last_to_end
= -1;
731 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
733 this = args
[textprops
[argnum
].argnum
];
734 props
= text_property_list (this,
736 make_number (SCHARS (this)),
738 /* If successive arguments have properties, be sure that the
739 value of `composition' property be the copy. */
740 if (last_to_end
== textprops
[argnum
].to
)
741 make_composition_value_copy (props
);
742 add_text_properties_from_list (val
, props
,
743 make_number (textprops
[argnum
].to
));
744 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
752 static Lisp_Object string_char_byte_cache_string
;
753 static ptrdiff_t string_char_byte_cache_charpos
;
754 static ptrdiff_t string_char_byte_cache_bytepos
;
757 clear_string_char_byte_cache (void)
759 string_char_byte_cache_string
= Qnil
;
762 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
765 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
768 ptrdiff_t best_below
, best_below_byte
;
769 ptrdiff_t best_above
, best_above_byte
;
771 best_below
= best_below_byte
= 0;
772 best_above
= SCHARS (string
);
773 best_above_byte
= SBYTES (string
);
774 if (best_above
== best_above_byte
)
777 if (EQ (string
, string_char_byte_cache_string
))
779 if (string_char_byte_cache_charpos
< char_index
)
781 best_below
= string_char_byte_cache_charpos
;
782 best_below_byte
= string_char_byte_cache_bytepos
;
786 best_above
= string_char_byte_cache_charpos
;
787 best_above_byte
= string_char_byte_cache_bytepos
;
791 if (char_index
- best_below
< best_above
- char_index
)
793 unsigned char *p
= SDATA (string
) + best_below_byte
;
795 while (best_below
< char_index
)
797 p
+= BYTES_BY_CHAR_HEAD (*p
);
800 i_byte
= p
- SDATA (string
);
804 unsigned char *p
= SDATA (string
) + best_above_byte
;
806 while (best_above
> char_index
)
809 while (!CHAR_HEAD_P (*p
)) p
--;
812 i_byte
= p
- SDATA (string
);
815 string_char_byte_cache_bytepos
= i_byte
;
816 string_char_byte_cache_charpos
= char_index
;
817 string_char_byte_cache_string
= string
;
822 /* Return the character index corresponding to BYTE_INDEX in STRING. */
825 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
828 ptrdiff_t best_below
, best_below_byte
;
829 ptrdiff_t best_above
, best_above_byte
;
831 best_below
= best_below_byte
= 0;
832 best_above
= SCHARS (string
);
833 best_above_byte
= SBYTES (string
);
834 if (best_above
== best_above_byte
)
837 if (EQ (string
, string_char_byte_cache_string
))
839 if (string_char_byte_cache_bytepos
< byte_index
)
841 best_below
= string_char_byte_cache_charpos
;
842 best_below_byte
= string_char_byte_cache_bytepos
;
846 best_above
= string_char_byte_cache_charpos
;
847 best_above_byte
= string_char_byte_cache_bytepos
;
851 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
853 unsigned char *p
= SDATA (string
) + best_below_byte
;
854 unsigned char *pend
= SDATA (string
) + byte_index
;
858 p
+= BYTES_BY_CHAR_HEAD (*p
);
862 i_byte
= p
- SDATA (string
);
866 unsigned char *p
= SDATA (string
) + best_above_byte
;
867 unsigned char *pbeg
= SDATA (string
) + byte_index
;
872 while (!CHAR_HEAD_P (*p
)) p
--;
876 i_byte
= p
- SDATA (string
);
879 string_char_byte_cache_bytepos
= i_byte
;
880 string_char_byte_cache_charpos
= i
;
881 string_char_byte_cache_string
= string
;
886 /* Convert STRING to a multibyte string. */
889 string_make_multibyte (Lisp_Object string
)
896 if (STRING_MULTIBYTE (string
))
899 nbytes
= count_size_as_multibyte (SDATA (string
),
901 /* If all the chars are ASCII, they won't need any more bytes
902 once converted. In that case, we can return STRING itself. */
903 if (nbytes
== SBYTES (string
))
906 buf
= SAFE_ALLOCA (nbytes
);
907 copy_text (SDATA (string
), buf
, SBYTES (string
),
910 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
917 /* Convert STRING (if unibyte) to a multibyte string without changing
918 the number of characters. Characters 0200 trough 0237 are
919 converted to eight-bit characters. */
922 string_to_multibyte (Lisp_Object string
)
929 if (STRING_MULTIBYTE (string
))
932 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
933 /* If all the chars are ASCII, they won't need any more bytes once
935 if (nbytes
== SBYTES (string
))
936 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
938 buf
= SAFE_ALLOCA (nbytes
);
939 memcpy (buf
, SDATA (string
), SBYTES (string
));
940 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
942 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
949 /* Convert STRING to a single-byte string. */
952 string_make_unibyte (Lisp_Object string
)
959 if (! STRING_MULTIBYTE (string
))
962 nchars
= SCHARS (string
);
964 buf
= SAFE_ALLOCA (nchars
);
965 copy_text (SDATA (string
), buf
, SBYTES (string
),
968 ret
= make_unibyte_string ((char *) buf
, nchars
);
974 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
976 doc
: /* Return the multibyte equivalent of STRING.
977 If STRING is unibyte and contains non-ASCII characters, the function
978 `unibyte-char-to-multibyte' is used to convert each unibyte character
979 to a multibyte character. In this case, the returned string is a
980 newly created string with no text properties. If STRING is multibyte
981 or entirely ASCII, it is returned unchanged. In particular, when
982 STRING is unibyte and entirely ASCII, the returned string is unibyte.
983 \(When the characters are all ASCII, Emacs primitives will treat the
984 string the same way whether it is unibyte or multibyte.) */)
987 CHECK_STRING (string
);
989 return string_make_multibyte (string
);
992 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
994 doc
: /* Return the unibyte equivalent of STRING.
995 Multibyte character codes are converted to unibyte according to
996 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
997 If the lookup in the translation table fails, this function takes just
998 the low 8 bits of each character. */)
1001 CHECK_STRING (string
);
1003 return string_make_unibyte (string
);
1006 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1008 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1009 If STRING is unibyte, the result is STRING itself.
1010 Otherwise it is a newly created string, with no text properties.
1011 If STRING is multibyte and contains a character of charset
1012 `eight-bit', it is converted to the corresponding single byte. */)
1013 (Lisp_Object string
)
1015 CHECK_STRING (string
);
1017 if (STRING_MULTIBYTE (string
))
1019 ptrdiff_t bytes
= SBYTES (string
);
1020 unsigned char *str
= xmalloc (bytes
);
1022 memcpy (str
, SDATA (string
), bytes
);
1023 bytes
= str_as_unibyte (str
, bytes
);
1024 string
= make_unibyte_string ((char *) str
, bytes
);
1030 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1032 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1033 If STRING is multibyte, the result is STRING itself.
1034 Otherwise it is a newly created string, with no text properties.
1036 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1037 part of a correct utf-8 sequence), it is converted to the corresponding
1038 multibyte character of charset `eight-bit'.
1039 See also `string-to-multibyte'.
1041 Beware, this often doesn't really do what you think it does.
1042 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1043 If you're not sure, whether to use `string-as-multibyte' or
1044 `string-to-multibyte', use `string-to-multibyte'. */)
1045 (Lisp_Object string
)
1047 CHECK_STRING (string
);
1049 if (! STRING_MULTIBYTE (string
))
1051 Lisp_Object new_string
;
1052 ptrdiff_t nchars
, nbytes
;
1054 parse_str_as_multibyte (SDATA (string
),
1057 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1058 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1059 if (nbytes
!= SBYTES (string
))
1060 str_as_multibyte (SDATA (new_string
), nbytes
,
1061 SBYTES (string
), NULL
);
1062 string
= new_string
;
1063 set_string_intervals (string
, NULL
);
1068 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1070 doc
: /* Return a multibyte string with the same individual chars as STRING.
1071 If STRING is multibyte, the result is STRING itself.
1072 Otherwise it is a newly created string, with no text properties.
1074 If STRING is unibyte and contains an 8-bit byte, it is converted to
1075 the corresponding multibyte character of charset `eight-bit'.
1077 This differs from `string-as-multibyte' by converting each byte of a correct
1078 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1079 correct sequence. */)
1080 (Lisp_Object string
)
1082 CHECK_STRING (string
);
1084 return string_to_multibyte (string
);
1087 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1089 doc
: /* Return a unibyte string with the same individual chars as STRING.
1090 If STRING is unibyte, the result is STRING itself.
1091 Otherwise it is a newly created string, with no text properties,
1092 where each `eight-bit' character is converted to the corresponding byte.
1093 If STRING contains a non-ASCII, non-`eight-bit' character,
1094 an error is signaled. */)
1095 (Lisp_Object string
)
1097 CHECK_STRING (string
);
1099 if (STRING_MULTIBYTE (string
))
1101 ptrdiff_t chars
= SCHARS (string
);
1102 unsigned char *str
= xmalloc (chars
);
1103 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1105 if (converted
< chars
)
1106 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1107 string
= make_unibyte_string ((char *) str
, chars
);
1114 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1115 doc
: /* Return a copy of ALIST.
1116 This is an alist which represents the same mapping from objects to objects,
1117 but does not share the alist structure with ALIST.
1118 The objects mapped (cars and cdrs of elements of the alist)
1119 are shared, however.
1120 Elements of ALIST that are not conses are also shared. */)
1123 register Lisp_Object tem
;
1128 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1129 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1131 register Lisp_Object car
;
1135 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1140 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1141 doc
: /* Return a new string whose contents are a substring of STRING.
1142 The returned string consists of the characters between index FROM
1143 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1144 zero-indexed: 0 means the first character of STRING. Negative values
1145 are counted from the end of STRING. If TO is nil, the substring runs
1146 to the end of STRING.
1148 The STRING argument may also be a vector. In that case, the return
1149 value is a new vector that contains the elements between index FROM
1150 \(inclusive) and index TO (exclusive) of that vector argument. */)
1151 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1155 EMACS_INT from_char
, to_char
;
1157 CHECK_VECTOR_OR_STRING (string
);
1158 CHECK_NUMBER (from
);
1160 if (STRINGP (string
))
1161 size
= SCHARS (string
);
1163 size
= ASIZE (string
);
1171 to_char
= XINT (to
);
1176 from_char
= XINT (from
);
1179 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1180 args_out_of_range_3 (string
, make_number (from_char
),
1181 make_number (to_char
));
1183 if (STRINGP (string
))
1186 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1187 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1188 res
= make_specified_string (SSDATA (string
) + from_byte
,
1189 to_char
- from_char
, to_byte
- from_byte
,
1190 STRING_MULTIBYTE (string
));
1191 copy_text_properties (make_number (from_char
), make_number (to_char
),
1192 string
, make_number (0), res
, Qnil
);
1195 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1201 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1202 doc
: /* Return a substring of STRING, without text properties.
1203 It starts at index FROM and ends before TO.
1204 TO may be nil or omitted; then the substring runs to the end of STRING.
1205 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1206 If FROM or TO is negative, it counts from the end.
1208 With one argument, just copy STRING without its properties. */)
1209 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1212 EMACS_INT from_char
, to_char
;
1213 ptrdiff_t from_byte
, to_byte
;
1215 CHECK_STRING (string
);
1217 size
= SCHARS (string
);
1223 CHECK_NUMBER (from
);
1224 from_char
= XINT (from
);
1234 to_char
= XINT (to
);
1239 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1240 args_out_of_range_3 (string
, make_number (from_char
),
1241 make_number (to_char
));
1243 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1245 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1246 return make_specified_string (SSDATA (string
) + from_byte
,
1247 to_char
- from_char
, to_byte
- from_byte
,
1248 STRING_MULTIBYTE (string
));
1251 /* Extract a substring of STRING, giving start and end positions
1252 both in characters and in bytes. */
1255 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1256 ptrdiff_t to
, ptrdiff_t to_byte
)
1261 CHECK_VECTOR_OR_STRING (string
);
1263 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1265 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1266 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1268 if (STRINGP (string
))
1270 res
= make_specified_string (SSDATA (string
) + from_byte
,
1271 to
- from
, to_byte
- from_byte
,
1272 STRING_MULTIBYTE (string
));
1273 copy_text_properties (make_number (from
), make_number (to
),
1274 string
, make_number (0), res
, Qnil
);
1277 res
= Fvector (to
- from
, aref_addr (string
, from
));
1282 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1283 doc
: /* Take cdr N times on LIST, return the result. */)
1284 (Lisp_Object n
, Lisp_Object list
)
1289 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1292 CHECK_LIST_CONS (list
, list
);
1298 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1299 doc
: /* Return the Nth element of LIST.
1300 N counts from zero. If LIST is not that long, nil is returned. */)
1301 (Lisp_Object n
, Lisp_Object list
)
1303 return Fcar (Fnthcdr (n
, list
));
1306 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1307 doc
: /* Return element of SEQUENCE at index N. */)
1308 (register Lisp_Object sequence
, Lisp_Object n
)
1311 if (CONSP (sequence
) || NILP (sequence
))
1312 return Fcar (Fnthcdr (n
, sequence
));
1314 /* Faref signals a "not array" error, so check here. */
1315 CHECK_ARRAY (sequence
, Qsequencep
);
1316 return Faref (sequence
, n
);
1319 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1320 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1321 The value is actually the tail of LIST whose car is ELT. */)
1322 (register Lisp_Object elt
, Lisp_Object list
)
1324 register Lisp_Object tail
;
1325 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1327 register Lisp_Object tem
;
1328 CHECK_LIST_CONS (tail
, list
);
1330 if (! NILP (Fequal (elt
, tem
)))
1337 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1338 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1339 The value is actually the tail of LIST whose car is ELT. */)
1340 (register Lisp_Object elt
, Lisp_Object list
)
1344 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1348 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1352 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1363 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1364 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1365 The value is actually the tail of LIST whose car is ELT. */)
1366 (register Lisp_Object elt
, Lisp_Object list
)
1368 register Lisp_Object tail
;
1371 return Fmemq (elt
, list
);
1373 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1375 register Lisp_Object tem
;
1376 CHECK_LIST_CONS (tail
, list
);
1378 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1385 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1386 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1387 The value is actually the first element of LIST whose car is KEY.
1388 Elements of LIST that are not conses are ignored. */)
1389 (Lisp_Object key
, Lisp_Object list
)
1394 || (CONSP (XCAR (list
))
1395 && EQ (XCAR (XCAR (list
)), key
)))
1400 || (CONSP (XCAR (list
))
1401 && EQ (XCAR (XCAR (list
)), key
)))
1406 || (CONSP (XCAR (list
))
1407 && EQ (XCAR (XCAR (list
)), key
)))
1417 /* Like Fassq but never report an error and do not allow quits.
1418 Use only on lists known never to be circular. */
1421 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1424 && (!CONSP (XCAR (list
))
1425 || !EQ (XCAR (XCAR (list
)), key
)))
1428 return CAR_SAFE (list
);
1431 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1432 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1433 The value is actually the first element of LIST whose car equals KEY. */)
1434 (Lisp_Object key
, Lisp_Object list
)
1441 || (CONSP (XCAR (list
))
1442 && (car
= XCAR (XCAR (list
)),
1443 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1448 || (CONSP (XCAR (list
))
1449 && (car
= XCAR (XCAR (list
)),
1450 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1455 || (CONSP (XCAR (list
))
1456 && (car
= XCAR (XCAR (list
)),
1457 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1467 /* Like Fassoc but never report an error and do not allow quits.
1468 Use only on lists known never to be circular. */
1471 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1474 && (!CONSP (XCAR (list
))
1475 || (!EQ (XCAR (XCAR (list
)), key
)
1476 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1479 return CONSP (list
) ? XCAR (list
) : Qnil
;
1482 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1483 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1484 The value is actually the first element of LIST whose cdr is KEY. */)
1485 (register Lisp_Object key
, Lisp_Object list
)
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCDR (XCAR (list
)), key
)))
1496 || (CONSP (XCAR (list
))
1497 && EQ (XCDR (XCAR (list
)), key
)))
1502 || (CONSP (XCAR (list
))
1503 && EQ (XCDR (XCAR (list
)), key
)))
1513 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1514 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1515 The value is actually the first element of LIST whose cdr equals KEY. */)
1516 (Lisp_Object key
, Lisp_Object list
)
1523 || (CONSP (XCAR (list
))
1524 && (cdr
= XCDR (XCAR (list
)),
1525 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1530 || (CONSP (XCAR (list
))
1531 && (cdr
= XCDR (XCAR (list
)),
1532 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1537 || (CONSP (XCAR (list
))
1538 && (cdr
= XCDR (XCAR (list
)),
1539 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1549 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1550 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1551 The modified LIST is returned. Comparison is done with `eq'.
1552 If the first member of LIST is ELT, there is no way to remove it by side effect;
1553 therefore, write `(setq foo (delq element foo))'
1554 to be sure of changing the value of `foo'. */)
1555 (register Lisp_Object elt
, Lisp_Object list
)
1557 register Lisp_Object tail
, prev
;
1558 register Lisp_Object tem
;
1562 while (!NILP (tail
))
1564 CHECK_LIST_CONS (tail
, list
);
1571 Fsetcdr (prev
, XCDR (tail
));
1581 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1582 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1583 SEQ must be a list, a vector, or a string.
1584 The modified SEQ is returned. Comparison is done with `equal'.
1585 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1586 is not a side effect; it is simply using a different sequence.
1587 Therefore, write `(setq foo (delete element foo))'
1588 to be sure of changing the value of `foo'. */)
1589 (Lisp_Object elt
, Lisp_Object seq
)
1595 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1596 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1599 if (n
!= ASIZE (seq
))
1601 struct Lisp_Vector
*p
= allocate_vector (n
);
1603 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1604 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1605 p
->contents
[n
++] = AREF (seq
, i
);
1607 XSETVECTOR (seq
, p
);
1610 else if (STRINGP (seq
))
1612 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1615 for (i
= nchars
= nbytes
= ibyte
= 0;
1617 ++i
, ibyte
+= cbytes
)
1619 if (STRING_MULTIBYTE (seq
))
1621 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1622 cbytes
= CHAR_BYTES (c
);
1630 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1637 if (nchars
!= SCHARS (seq
))
1641 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1642 if (!STRING_MULTIBYTE (seq
))
1643 STRING_SET_UNIBYTE (tem
);
1645 for (i
= nchars
= nbytes
= ibyte
= 0;
1647 ++i
, ibyte
+= cbytes
)
1649 if (STRING_MULTIBYTE (seq
))
1651 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1652 cbytes
= CHAR_BYTES (c
);
1660 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1662 unsigned char *from
= SDATA (seq
) + ibyte
;
1663 unsigned char *to
= SDATA (tem
) + nbytes
;
1669 for (n
= cbytes
; n
--; )
1679 Lisp_Object tail
, prev
;
1681 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1683 CHECK_LIST_CONS (tail
, seq
);
1685 if (!NILP (Fequal (elt
, XCAR (tail
))))
1690 Fsetcdr (prev
, XCDR (tail
));
1701 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1702 doc
: /* Reverse LIST by modifying cdr pointers.
1703 Return the reversed list. */)
1706 register Lisp_Object prev
, tail
, next
;
1708 if (NILP (list
)) return list
;
1711 while (!NILP (tail
))
1714 CHECK_LIST_CONS (tail
, list
);
1716 Fsetcdr (tail
, prev
);
1723 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1724 doc
: /* Reverse LIST, copying. Return the reversed list.
1725 See also the function `nreverse', which is used more often. */)
1730 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1733 new = Fcons (XCAR (list
), new);
1735 CHECK_LIST_END (list
, list
);
1739 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1741 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1742 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1743 Returns the sorted list. LIST is modified by side effects.
1744 PREDICATE is called with two elements of LIST, and should return non-nil
1745 if the first element should sort before the second. */)
1746 (Lisp_Object list
, Lisp_Object predicate
)
1748 Lisp_Object front
, back
;
1749 register Lisp_Object len
, tem
;
1750 struct gcpro gcpro1
, gcpro2
;
1754 len
= Flength (list
);
1755 length
= XINT (len
);
1759 XSETINT (len
, (length
/ 2) - 1);
1760 tem
= Fnthcdr (len
, list
);
1762 Fsetcdr (tem
, Qnil
);
1764 GCPRO2 (front
, back
);
1765 front
= Fsort (front
, predicate
);
1766 back
= Fsort (back
, predicate
);
1768 return merge (front
, back
, predicate
);
1772 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1775 register Lisp_Object tail
;
1777 register Lisp_Object l1
, l2
;
1778 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1785 /* It is sufficient to protect org_l1 and org_l2.
1786 When l1 and l2 are updated, we copy the new values
1787 back into the org_ vars. */
1788 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1808 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1824 Fsetcdr (tail
, tem
);
1830 /* This does not check for quits. That is safe since it must terminate. */
1832 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1833 doc
: /* Extract a value from a property list.
1834 PLIST is a property list, which is a list of the form
1835 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1836 corresponding to the given PROP, or nil if PROP is not one of the
1837 properties on the list. This function never signals an error. */)
1838 (Lisp_Object plist
, Lisp_Object prop
)
1840 Lisp_Object tail
, halftail
;
1842 /* halftail is used to detect circular lists. */
1843 tail
= halftail
= plist
;
1844 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1846 if (EQ (prop
, XCAR (tail
)))
1847 return XCAR (XCDR (tail
));
1849 tail
= XCDR (XCDR (tail
));
1850 halftail
= XCDR (halftail
);
1851 if (EQ (tail
, halftail
))
1854 #if 0 /* Unsafe version. */
1855 /* This function can be called asynchronously
1856 (setup_coding_system). Don't QUIT in that case. */
1857 if (!interrupt_input_blocked
)
1865 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1866 doc
: /* Return the value of SYMBOL's PROPNAME property.
1867 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1868 (Lisp_Object symbol
, Lisp_Object propname
)
1870 CHECK_SYMBOL (symbol
);
1871 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1874 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1875 doc
: /* Change value in PLIST of PROP to VAL.
1876 PLIST is a property list, which is a list of the form
1877 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1878 If PROP is already a property on the list, its value is set to VAL,
1879 otherwise the new PROP VAL pair is added. The new plist is returned;
1880 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1881 The PLIST is modified by side effects. */)
1882 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1884 register Lisp_Object tail
, prev
;
1885 Lisp_Object newcell
;
1887 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1888 tail
= XCDR (XCDR (tail
)))
1890 if (EQ (prop
, XCAR (tail
)))
1892 Fsetcar (XCDR (tail
), val
);
1899 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1903 Fsetcdr (XCDR (prev
), newcell
);
1907 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1908 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1909 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1910 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1912 CHECK_SYMBOL (symbol
);
1914 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1918 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1919 doc
: /* Extract a value from a property list, comparing with `equal'.
1920 PLIST is a property list, which is a list of the form
1921 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1922 corresponding to the given PROP, or nil if PROP is not
1923 one of the properties on the list. */)
1924 (Lisp_Object plist
, Lisp_Object prop
)
1929 CONSP (tail
) && CONSP (XCDR (tail
));
1930 tail
= XCDR (XCDR (tail
)))
1932 if (! NILP (Fequal (prop
, XCAR (tail
))))
1933 return XCAR (XCDR (tail
));
1938 CHECK_LIST_END (tail
, prop
);
1943 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1944 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1945 PLIST is a property list, which is a list of the form
1946 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1947 If PROP is already a property on the list, its value is set to VAL,
1948 otherwise the new PROP VAL pair is added. The new plist is returned;
1949 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1950 The PLIST is modified by side effects. */)
1951 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1953 register Lisp_Object tail
, prev
;
1954 Lisp_Object newcell
;
1956 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1957 tail
= XCDR (XCDR (tail
)))
1959 if (! NILP (Fequal (prop
, XCAR (tail
))))
1961 Fsetcar (XCDR (tail
), val
);
1968 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1972 Fsetcdr (XCDR (prev
), newcell
);
1976 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1977 doc
: /* Return t if the two args are the same Lisp object.
1978 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1979 (Lisp_Object obj1
, Lisp_Object obj2
)
1982 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1984 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1987 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1988 doc
: /* Return t if two Lisp objects have similar structure and contents.
1989 They must have the same data type.
1990 Conses are compared by comparing the cars and the cdrs.
1991 Vectors and strings are compared element by element.
1992 Numbers are compared by value, but integers cannot equal floats.
1993 (Use `=' if you want integers and floats to be able to be equal.)
1994 Symbols must match exactly. */)
1995 (register Lisp_Object o1
, Lisp_Object o2
)
1997 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2000 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2001 doc
: /* Return t if two Lisp objects have similar structure and contents.
2002 This is like `equal' except that it compares the text properties
2003 of strings. (`equal' ignores text properties.) */)
2004 (register Lisp_Object o1
, Lisp_Object o2
)
2006 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2009 /* DEPTH is current depth of recursion. Signal an error if it
2011 PROPS, if non-nil, means compare string text properties too. */
2014 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2017 error ("Stack overflow in equal");
2023 if (XTYPE (o1
) != XTYPE (o2
))
2032 d1
= extract_float (o1
);
2033 d2
= extract_float (o2
);
2034 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2035 though they are not =. */
2036 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2040 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2047 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2051 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2053 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2056 o1
= XOVERLAY (o1
)->plist
;
2057 o2
= XOVERLAY (o2
)->plist
;
2062 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2063 && (XMARKER (o1
)->buffer
== 0
2064 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2068 case Lisp_Vectorlike
:
2071 ptrdiff_t size
= ASIZE (o1
);
2072 /* Pseudovectors have the type encoded in the size field, so this test
2073 actually checks that the objects have the same type as well as the
2075 if (ASIZE (o2
) != size
)
2077 /* Boolvectors are compared much like strings. */
2078 if (BOOL_VECTOR_P (o1
))
2080 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2082 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2083 ((XBOOL_VECTOR (o1
)->size
2084 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2085 / BOOL_VECTOR_BITS_PER_CHAR
)))
2089 if (WINDOW_CONFIGURATIONP (o1
))
2090 return compare_window_configurations (o1
, o2
, 0);
2092 /* Aside from them, only true vectors, char-tables, compiled
2093 functions, and fonts (font-spec, font-entity, font-object)
2094 are sensible to compare, so eliminate the others now. */
2095 if (size
& PSEUDOVECTOR_FLAG
)
2097 if (!(size
& ((PVEC_COMPILED
| PVEC_CHAR_TABLE
2098 | PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)
2099 << PSEUDOVECTOR_SIZE_BITS
)))
2101 size
&= PSEUDOVECTOR_SIZE_MASK
;
2103 for (i
= 0; i
< size
; i
++)
2108 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2116 if (SCHARS (o1
) != SCHARS (o2
))
2118 if (SBYTES (o1
) != SBYTES (o2
))
2120 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2122 if (props
&& !compare_string_intervals (o1
, o2
))
2134 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2135 doc
: /* Store each element of ARRAY with ITEM.
2136 ARRAY is a vector, string, char-table, or bool-vector. */)
2137 (Lisp_Object array
, Lisp_Object item
)
2139 register ptrdiff_t size
, idx
;
2141 if (VECTORP (array
))
2142 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2143 ASET (array
, idx
, item
);
2144 else if (CHAR_TABLE_P (array
))
2148 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2149 set_char_table_contents (array
, i
, item
);
2150 set_char_table_defalt (array
, item
);
2152 else if (STRINGP (array
))
2154 register unsigned char *p
= SDATA (array
);
2156 CHECK_CHARACTER (item
);
2157 charval
= XFASTINT (item
);
2158 size
= SCHARS (array
);
2159 if (STRING_MULTIBYTE (array
))
2161 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2162 int len
= CHAR_STRING (charval
, str
);
2163 ptrdiff_t size_byte
= SBYTES (array
);
2165 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2166 || SCHARS (array
) * len
!= size_byte
)
2167 error ("Attempt to change byte length of a string");
2168 for (idx
= 0; idx
< size_byte
; idx
++)
2169 *p
++ = str
[idx
% len
];
2172 for (idx
= 0; idx
< size
; idx
++)
2175 else if (BOOL_VECTOR_P (array
))
2177 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2179 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2180 / BOOL_VECTOR_BITS_PER_CHAR
);
2184 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2186 /* Clear any extraneous bits in the last byte. */
2187 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2191 wrong_type_argument (Qarrayp
, array
);
2195 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2197 doc
: /* Clear the contents of STRING.
2198 This makes STRING unibyte and may change its length. */)
2199 (Lisp_Object string
)
2202 CHECK_STRING (string
);
2203 len
= SBYTES (string
);
2204 memset (SDATA (string
), 0, len
);
2205 STRING_SET_CHARS (string
, len
);
2206 STRING_SET_UNIBYTE (string
);
2212 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2214 Lisp_Object args
[2];
2217 return Fnconc (2, args
);
2220 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2221 doc
: /* Concatenate any number of lists by altering them.
2222 Only the last argument is not altered, and need not be a list.
2223 usage: (nconc &rest LISTS) */)
2224 (ptrdiff_t nargs
, Lisp_Object
*args
)
2227 register Lisp_Object tail
, tem
, val
;
2231 for (argnum
= 0; argnum
< nargs
; argnum
++)
2234 if (NILP (tem
)) continue;
2239 if (argnum
+ 1 == nargs
) break;
2241 CHECK_LIST_CONS (tem
, tem
);
2250 tem
= args
[argnum
+ 1];
2251 Fsetcdr (tail
, tem
);
2253 args
[argnum
+ 1] = tail
;
2259 /* This is the guts of all mapping functions.
2260 Apply FN to each element of SEQ, one by one,
2261 storing the results into elements of VALS, a C vector of Lisp_Objects.
2262 LENI is the length of VALS, which should also be the length of SEQ. */
2265 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2267 register Lisp_Object tail
;
2269 register EMACS_INT i
;
2270 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2274 /* Don't let vals contain any garbage when GC happens. */
2275 for (i
= 0; i
< leni
; i
++)
2278 GCPRO3 (dummy
, fn
, seq
);
2280 gcpro1
.nvars
= leni
;
2284 /* We need not explicitly protect `tail' because it is used only on lists, and
2285 1) lists are not relocated and 2) the list is marked via `seq' so will not
2288 if (VECTORP (seq
) || COMPILEDP (seq
))
2290 for (i
= 0; i
< leni
; i
++)
2292 dummy
= call1 (fn
, AREF (seq
, i
));
2297 else if (BOOL_VECTOR_P (seq
))
2299 for (i
= 0; i
< leni
; i
++)
2302 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2303 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2304 dummy
= call1 (fn
, dummy
);
2309 else if (STRINGP (seq
))
2313 for (i
= 0, i_byte
= 0; i
< leni
;)
2316 ptrdiff_t i_before
= i
;
2318 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2319 XSETFASTINT (dummy
, c
);
2320 dummy
= call1 (fn
, dummy
);
2322 vals
[i_before
] = dummy
;
2325 else /* Must be a list, since Flength did not get an error */
2328 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2330 dummy
= call1 (fn
, XCAR (tail
));
2340 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2341 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2342 In between each pair of results, stick in SEPARATOR. Thus, " " as
2343 SEPARATOR results in spaces between the values returned by FUNCTION.
2344 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2345 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2348 register EMACS_INT leni
;
2351 register Lisp_Object
*args
;
2352 struct gcpro gcpro1
;
2356 len
= Flength (sequence
);
2357 if (CHAR_TABLE_P (sequence
))
2358 wrong_type_argument (Qlistp
, sequence
);
2360 nargs
= leni
+ leni
- 1;
2361 if (nargs
< 0) return empty_unibyte_string
;
2363 SAFE_ALLOCA_LISP (args
, nargs
);
2366 mapcar1 (leni
, args
, function
, sequence
);
2369 for (i
= leni
- 1; i
> 0; i
--)
2370 args
[i
+ i
] = args
[i
];
2372 for (i
= 1; i
< nargs
; i
+= 2)
2373 args
[i
] = separator
;
2375 ret
= Fconcat (nargs
, args
);
2381 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2382 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2383 The result is a list just as long as SEQUENCE.
2384 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2385 (Lisp_Object function
, Lisp_Object sequence
)
2387 register Lisp_Object len
;
2388 register EMACS_INT leni
;
2389 register Lisp_Object
*args
;
2393 len
= Flength (sequence
);
2394 if (CHAR_TABLE_P (sequence
))
2395 wrong_type_argument (Qlistp
, sequence
);
2396 leni
= XFASTINT (len
);
2398 SAFE_ALLOCA_LISP (args
, leni
);
2400 mapcar1 (leni
, args
, function
, sequence
);
2402 ret
= Flist (leni
, args
);
2408 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2409 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2410 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2411 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2412 (Lisp_Object function
, Lisp_Object sequence
)
2414 register EMACS_INT leni
;
2416 leni
= XFASTINT (Flength (sequence
));
2417 if (CHAR_TABLE_P (sequence
))
2418 wrong_type_argument (Qlistp
, sequence
);
2419 mapcar1 (leni
, 0, function
, sequence
);
2424 /* This is how C code calls `yes-or-no-p' and allows the user
2427 Anything that calls this function must protect from GC! */
2430 do_yes_or_no_p (Lisp_Object prompt
)
2432 return call1 (intern ("yes-or-no-p"), prompt
);
2435 /* Anything that calls this function must protect from GC! */
2437 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2438 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2439 PROMPT is the string to display to ask the question. It should end in
2440 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2442 The user must confirm the answer with RET, and can edit it until it
2445 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2446 is nil, and `use-dialog-box' is non-nil. */)
2447 (Lisp_Object prompt
)
2449 register Lisp_Object ans
;
2450 Lisp_Object args
[2];
2451 struct gcpro gcpro1
;
2453 CHECK_STRING (prompt
);
2456 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2457 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2461 Lisp_Object pane
, menu
, obj
;
2462 redisplay_preserve_echo_area (4);
2463 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2464 Fcons (Fcons (build_string ("No"), Qnil
),
2467 menu
= Fcons (prompt
, pane
);
2468 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2472 #endif /* HAVE_MENUS */
2475 args
[1] = build_string ("(yes or no) ");
2476 prompt
= Fconcat (2, args
);
2482 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2483 Qyes_or_no_p_history
, Qnil
,
2485 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2490 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2498 message ("Please answer yes or no.");
2499 Fsleep_for (make_number (2), Qnil
);
2503 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2504 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2506 Each of the three load averages is multiplied by 100, then converted
2509 When USE-FLOATS is non-nil, floats will be used instead of integers.
2510 These floats are not multiplied by 100.
2512 If the 5-minute or 15-minute load averages are not available, return a
2513 shortened list, containing only those averages which are available.
2515 An error is thrown if the load average can't be obtained. In some
2516 cases making it work would require Emacs being installed setuid or
2517 setgid so that it can read kernel information, and that usually isn't
2519 (Lisp_Object use_floats
)
2522 int loads
= getloadavg (load_ave
, 3);
2523 Lisp_Object ret
= Qnil
;
2526 error ("load-average not implemented for this operating system");
2530 Lisp_Object load
= (NILP (use_floats
)
2531 ? make_number (100.0 * load_ave
[loads
])
2532 : make_float (load_ave
[loads
]));
2533 ret
= Fcons (load
, ret
);
2539 static Lisp_Object Qsubfeatures
;
2541 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2542 doc
: /* Return t if FEATURE is present in this Emacs.
2544 Use this to conditionalize execution of lisp code based on the
2545 presence or absence of Emacs or environment extensions.
2546 Use `provide' to declare that a feature is available. This function
2547 looks at the value of the variable `features'. The optional argument
2548 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2549 (Lisp_Object feature
, Lisp_Object subfeature
)
2551 register Lisp_Object tem
;
2552 CHECK_SYMBOL (feature
);
2553 tem
= Fmemq (feature
, Vfeatures
);
2554 if (!NILP (tem
) && !NILP (subfeature
))
2555 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2556 return (NILP (tem
)) ? Qnil
: Qt
;
2559 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2560 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2561 The optional argument SUBFEATURES should be a list of symbols listing
2562 particular subfeatures supported in this version of FEATURE. */)
2563 (Lisp_Object feature
, Lisp_Object subfeatures
)
2565 register Lisp_Object tem
;
2566 CHECK_SYMBOL (feature
);
2567 CHECK_LIST (subfeatures
);
2568 if (!NILP (Vautoload_queue
))
2569 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2571 tem
= Fmemq (feature
, Vfeatures
);
2573 Vfeatures
= Fcons (feature
, Vfeatures
);
2574 if (!NILP (subfeatures
))
2575 Fput (feature
, Qsubfeatures
, subfeatures
);
2576 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2578 /* Run any load-hooks for this file. */
2579 tem
= Fassq (feature
, Vafter_load_alist
);
2581 Fprogn (XCDR (tem
));
2586 /* `require' and its subroutines. */
2588 /* List of features currently being require'd, innermost first. */
2590 static Lisp_Object require_nesting_list
;
2593 require_unwind (Lisp_Object old_value
)
2595 return require_nesting_list
= old_value
;
2598 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2599 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2600 If FEATURE is not a member of the list `features', then the feature
2601 is not loaded; so load the file FILENAME.
2602 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2603 and `load' will try to load this name appended with the suffix `.elc' or
2604 `.el', in that order. The name without appended suffix will not be used.
2605 See `get-load-suffixes' for the complete list of suffixes.
2606 If the optional third argument NOERROR is non-nil,
2607 then return nil if the file is not found instead of signaling an error.
2608 Normally the return value is FEATURE.
2609 The normal messages at start and end of loading FILENAME are suppressed. */)
2610 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2612 register Lisp_Object tem
;
2613 struct gcpro gcpro1
, gcpro2
;
2614 int from_file
= load_in_progress
;
2616 CHECK_SYMBOL (feature
);
2618 /* Record the presence of `require' in this file
2619 even if the feature specified is already loaded.
2620 But not more than once in any file,
2621 and not when we aren't loading or reading from a file. */
2623 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2624 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2629 tem
= Fcons (Qrequire
, feature
);
2630 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2631 LOADHIST_ATTACH (tem
);
2633 tem
= Fmemq (feature
, Vfeatures
);
2637 ptrdiff_t count
= SPECPDL_INDEX ();
2640 /* This is to make sure that loadup.el gives a clear picture
2641 of what files are preloaded and when. */
2642 if (! NILP (Vpurify_flag
))
2643 error ("(require %s) while preparing to dump",
2644 SDATA (SYMBOL_NAME (feature
)));
2646 /* A certain amount of recursive `require' is legitimate,
2647 but if we require the same feature recursively 3 times,
2649 tem
= require_nesting_list
;
2650 while (! NILP (tem
))
2652 if (! NILP (Fequal (feature
, XCAR (tem
))))
2657 error ("Recursive `require' for feature `%s'",
2658 SDATA (SYMBOL_NAME (feature
)));
2660 /* Update the list for any nested `require's that occur. */
2661 record_unwind_protect (require_unwind
, require_nesting_list
);
2662 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2664 /* Value saved here is to be restored into Vautoload_queue */
2665 record_unwind_protect (un_autoload
, Vautoload_queue
);
2666 Vautoload_queue
= Qt
;
2668 /* Load the file. */
2669 GCPRO2 (feature
, filename
);
2670 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2671 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2674 /* If load failed entirely, return nil. */
2676 return unbind_to (count
, Qnil
);
2678 tem
= Fmemq (feature
, Vfeatures
);
2680 error ("Required feature `%s' was not provided",
2681 SDATA (SYMBOL_NAME (feature
)));
2683 /* Once loading finishes, don't undo it. */
2684 Vautoload_queue
= Qt
;
2685 feature
= unbind_to (count
, feature
);
2691 /* Primitives for work of the "widget" library.
2692 In an ideal world, this section would not have been necessary.
2693 However, lisp function calls being as slow as they are, it turns
2694 out that some functions in the widget library (wid-edit.el) are the
2695 bottleneck of Widget operation. Here is their translation to C,
2696 for the sole reason of efficiency. */
2698 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2699 doc
: /* Return non-nil if PLIST has the property PROP.
2700 PLIST is a property list, which is a list of the form
2701 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2702 Unlike `plist-get', this allows you to distinguish between a missing
2703 property and a property with the value nil.
2704 The value is actually the tail of PLIST whose car is PROP. */)
2705 (Lisp_Object plist
, Lisp_Object prop
)
2707 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2710 plist
= XCDR (plist
);
2711 plist
= CDR (plist
);
2716 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2717 doc
: /* In WIDGET, set PROPERTY to VALUE.
2718 The value can later be retrieved with `widget-get'. */)
2719 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2721 CHECK_CONS (widget
);
2722 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2726 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2727 doc
: /* In WIDGET, get the value of PROPERTY.
2728 The value could either be specified when the widget was created, or
2729 later with `widget-put'. */)
2730 (Lisp_Object widget
, Lisp_Object property
)
2738 CHECK_CONS (widget
);
2739 tmp
= Fplist_member (XCDR (widget
), property
);
2745 tmp
= XCAR (widget
);
2748 widget
= Fget (tmp
, Qwidget_type
);
2752 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2753 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2754 ARGS are passed as extra arguments to the function.
2755 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2756 (ptrdiff_t nargs
, Lisp_Object
*args
)
2758 /* This function can GC. */
2759 Lisp_Object newargs
[3];
2760 struct gcpro gcpro1
, gcpro2
;
2763 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2764 newargs
[1] = args
[0];
2765 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2766 GCPRO2 (newargs
[0], newargs
[2]);
2767 result
= Fapply (3, newargs
);
2772 #ifdef HAVE_LANGINFO_CODESET
2773 #include <langinfo.h>
2776 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2777 doc
: /* Access locale data ITEM for the current C locale, if available.
2778 ITEM should be one of the following:
2780 `codeset', returning the character set as a string (locale item CODESET);
2782 `days', returning a 7-element vector of day names (locale items DAY_n);
2784 `months', returning a 12-element vector of month names (locale items MON_n);
2786 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2787 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2789 If the system can't provide such information through a call to
2790 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2792 See also Info node `(libc)Locales'.
2794 The data read from the system are decoded using `locale-coding-system'. */)
2798 #ifdef HAVE_LANGINFO_CODESET
2800 if (EQ (item
, Qcodeset
))
2802 str
= nl_langinfo (CODESET
);
2803 return build_string (str
);
2806 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2808 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2809 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2811 struct gcpro gcpro1
;
2813 synchronize_system_time_locale ();
2814 for (i
= 0; i
< 7; i
++)
2816 str
= nl_langinfo (days
[i
]);
2817 val
= build_unibyte_string (str
);
2818 /* Fixme: Is this coding system necessarily right, even if
2819 it is consistent with CODESET? If not, what to do? */
2820 Faset (v
, make_number (i
),
2821 code_convert_string_norecord (val
, Vlocale_coding_system
,
2829 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2831 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2832 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2833 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2835 struct gcpro gcpro1
;
2837 synchronize_system_time_locale ();
2838 for (i
= 0; i
< 12; i
++)
2840 str
= nl_langinfo (months
[i
]);
2841 val
= build_unibyte_string (str
);
2842 Faset (v
, make_number (i
),
2843 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2849 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2850 but is in the locale files. This could be used by ps-print. */
2852 else if (EQ (item
, Qpaper
))
2854 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2855 make_number (nl_langinfo (PAPER_HEIGHT
)));
2857 #endif /* PAPER_WIDTH */
2858 #endif /* HAVE_LANGINFO_CODESET*/
2862 /* base64 encode/decode functions (RFC 2045).
2863 Based on code from GNU recode. */
2865 #define MIME_LINE_LENGTH 76
2867 #define IS_ASCII(Character) \
2869 #define IS_BASE64(Character) \
2870 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2871 #define IS_BASE64_IGNORABLE(Character) \
2872 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2873 || (Character) == '\f' || (Character) == '\r')
2875 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2876 character or return retval if there are no characters left to
2878 #define READ_QUADRUPLET_BYTE(retval) \
2883 if (nchars_return) \
2884 *nchars_return = nchars; \
2889 while (IS_BASE64_IGNORABLE (c))
2891 /* Table of characters coding the 64 values. */
2892 static const char base64_value_to_char
[64] =
2894 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2895 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2896 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2897 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2898 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2899 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2900 '8', '9', '+', '/' /* 60-63 */
2903 /* Table of base64 values for first 128 characters. */
2904 static const short base64_char_to_value
[128] =
2906 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2907 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2908 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2909 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2910 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2911 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2912 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2913 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2914 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2915 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2916 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2917 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2918 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2921 /* The following diagram shows the logical steps by which three octets
2922 get transformed into four base64 characters.
2924 .--------. .--------. .--------.
2925 |aaaaaabb| |bbbbcccc| |ccdddddd|
2926 `--------' `--------' `--------'
2928 .--------+--------+--------+--------.
2929 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2930 `--------+--------+--------+--------'
2932 .--------+--------+--------+--------.
2933 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2934 `--------+--------+--------+--------'
2936 The octets are divided into 6 bit chunks, which are then encoded into
2937 base64 characters. */
2940 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, int, int);
2941 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, int,
2944 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2946 doc
: /* Base64-encode the region between BEG and END.
2947 Return the length of the encoded text.
2948 Optional third argument NO-LINE-BREAK means do not break long lines
2949 into shorter lines. */)
2950 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2953 ptrdiff_t allength
, length
;
2954 ptrdiff_t ibeg
, iend
, encoded_length
;
2955 ptrdiff_t old_pos
= PT
;
2958 validate_region (&beg
, &end
);
2960 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2961 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2962 move_gap_both (XFASTINT (beg
), ibeg
);
2964 /* We need to allocate enough room for encoding the text.
2965 We need 33 1/3% more space, plus a newline every 76
2966 characters, and then we round up. */
2967 length
= iend
- ibeg
;
2968 allength
= length
+ length
/3 + 1;
2969 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2971 encoded
= SAFE_ALLOCA (allength
);
2972 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2973 encoded
, length
, NILP (no_line_break
),
2974 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2975 if (encoded_length
> allength
)
2978 if (encoded_length
< 0)
2980 /* The encoding wasn't possible. */
2982 error ("Multibyte character in data for base64 encoding");
2985 /* Now we have encoded the region, so we insert the new contents
2986 and delete the old. (Insert first in order to preserve markers.) */
2987 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2988 insert (encoded
, encoded_length
);
2990 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2992 /* If point was outside of the region, restore it exactly; else just
2993 move to the beginning of the region. */
2994 if (old_pos
>= XFASTINT (end
))
2995 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2996 else if (old_pos
> XFASTINT (beg
))
2997 old_pos
= XFASTINT (beg
);
3000 /* We return the length of the encoded text. */
3001 return make_number (encoded_length
);
3004 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3006 doc
: /* Base64-encode STRING and return the result.
3007 Optional second argument NO-LINE-BREAK means do not break long lines
3008 into shorter lines. */)
3009 (Lisp_Object string
, Lisp_Object no_line_break
)
3011 ptrdiff_t allength
, length
, encoded_length
;
3013 Lisp_Object encoded_string
;
3016 CHECK_STRING (string
);
3018 /* We need to allocate enough room for encoding the text.
3019 We need 33 1/3% more space, plus a newline every 76
3020 characters, and then we round up. */
3021 length
= SBYTES (string
);
3022 allength
= length
+ length
/3 + 1;
3023 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3025 /* We need to allocate enough room for decoding the text. */
3026 encoded
= SAFE_ALLOCA (allength
);
3028 encoded_length
= base64_encode_1 (SSDATA (string
),
3029 encoded
, length
, NILP (no_line_break
),
3030 STRING_MULTIBYTE (string
));
3031 if (encoded_length
> allength
)
3034 if (encoded_length
< 0)
3036 /* The encoding wasn't possible. */
3038 error ("Multibyte character in data for base64 encoding");
3041 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3044 return encoded_string
;
3048 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3049 int line_break
, int multibyte
)
3062 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3063 if (CHAR_BYTE8_P (c
))
3064 c
= CHAR_TO_BYTE8 (c
);
3072 /* Wrap line every 76 characters. */
3076 if (counter
< MIME_LINE_LENGTH
/ 4)
3085 /* Process first byte of a triplet. */
3087 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3088 value
= (0x03 & c
) << 4;
3090 /* Process second byte of a triplet. */
3094 *e
++ = base64_value_to_char
[value
];
3102 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3103 if (CHAR_BYTE8_P (c
))
3104 c
= CHAR_TO_BYTE8 (c
);
3112 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3113 value
= (0x0f & c
) << 2;
3115 /* Process third byte of a triplet. */
3119 *e
++ = base64_value_to_char
[value
];
3126 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3127 if (CHAR_BYTE8_P (c
))
3128 c
= CHAR_TO_BYTE8 (c
);
3136 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3137 *e
++ = base64_value_to_char
[0x3f & c
];
3144 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3146 doc
: /* Base64-decode the region between BEG and END.
3147 Return the length of the decoded text.
3148 If the region can't be decoded, signal an error and don't modify the buffer. */)
3149 (Lisp_Object beg
, Lisp_Object end
)
3151 ptrdiff_t ibeg
, iend
, length
, allength
;
3153 ptrdiff_t old_pos
= PT
;
3154 ptrdiff_t decoded_length
;
3155 ptrdiff_t inserted_chars
;
3156 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3159 validate_region (&beg
, &end
);
3161 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3162 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3164 length
= iend
- ibeg
;
3166 /* We need to allocate enough room for decoding the text. If we are
3167 working on a multibyte buffer, each decoded code may occupy at
3169 allength
= multibyte
? length
* 2 : length
;
3170 decoded
= SAFE_ALLOCA (allength
);
3172 move_gap_both (XFASTINT (beg
), ibeg
);
3173 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3175 multibyte
, &inserted_chars
);
3176 if (decoded_length
> allength
)
3179 if (decoded_length
< 0)
3181 /* The decoding wasn't possible. */
3183 error ("Invalid base64 data");
3186 /* Now we have decoded the region, so we insert the new contents
3187 and delete the old. (Insert first in order to preserve markers.) */
3188 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3189 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3192 /* Delete the original text. */
3193 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3194 iend
+ decoded_length
, 1);
3196 /* If point was outside of the region, restore it exactly; else just
3197 move to the beginning of the region. */
3198 if (old_pos
>= XFASTINT (end
))
3199 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3200 else if (old_pos
> XFASTINT (beg
))
3201 old_pos
= XFASTINT (beg
);
3202 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3204 return make_number (inserted_chars
);
3207 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3209 doc
: /* Base64-decode STRING and return the result. */)
3210 (Lisp_Object string
)
3213 ptrdiff_t length
, decoded_length
;
3214 Lisp_Object decoded_string
;
3217 CHECK_STRING (string
);
3219 length
= SBYTES (string
);
3220 /* We need to allocate enough room for decoding the text. */
3221 decoded
= SAFE_ALLOCA (length
);
3223 /* The decoded result should be unibyte. */
3224 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3226 if (decoded_length
> length
)
3228 else if (decoded_length
>= 0)
3229 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3231 decoded_string
= Qnil
;
3234 if (!STRINGP (decoded_string
))
3235 error ("Invalid base64 data");
3237 return decoded_string
;
3240 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3241 MULTIBYTE is nonzero, the decoded result should be in multibyte
3242 form. If NCHARS_RETURN is not NULL, store the number of produced
3243 characters in *NCHARS_RETURN. */
3246 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3247 int multibyte
, ptrdiff_t *nchars_return
)
3249 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3252 unsigned long value
;
3253 ptrdiff_t nchars
= 0;
3257 /* Process first byte of a quadruplet. */
3259 READ_QUADRUPLET_BYTE (e
-to
);
3263 value
= base64_char_to_value
[c
] << 18;
3265 /* Process second byte of a quadruplet. */
3267 READ_QUADRUPLET_BYTE (-1);
3271 value
|= base64_char_to_value
[c
] << 12;
3273 c
= (unsigned char) (value
>> 16);
3274 if (multibyte
&& c
>= 128)
3275 e
+= BYTE8_STRING (c
, e
);
3280 /* Process third byte of a quadruplet. */
3282 READ_QUADRUPLET_BYTE (-1);
3286 READ_QUADRUPLET_BYTE (-1);
3295 value
|= base64_char_to_value
[c
] << 6;
3297 c
= (unsigned char) (0xff & value
>> 8);
3298 if (multibyte
&& c
>= 128)
3299 e
+= BYTE8_STRING (c
, e
);
3304 /* Process fourth byte of a quadruplet. */
3306 READ_QUADRUPLET_BYTE (-1);
3313 value
|= base64_char_to_value
[c
];
3315 c
= (unsigned char) (0xff & value
);
3316 if (multibyte
&& c
>= 128)
3317 e
+= BYTE8_STRING (c
, e
);
3326 /***********************************************************************
3328 ***** Hash Tables *****
3330 ***********************************************************************/
3332 /* Implemented by gerd@gnu.org. This hash table implementation was
3333 inspired by CMUCL hash tables. */
3337 1. For small tables, association lists are probably faster than
3338 hash tables because they have lower overhead.
3340 For uses of hash tables where the O(1) behavior of table
3341 operations is not a requirement, it might therefore be a good idea
3342 not to hash. Instead, we could just do a linear search in the
3343 key_and_value vector of the hash table. This could be done
3344 if a `:linear-search t' argument is given to make-hash-table. */
3347 /* The list of all weak hash tables. Don't staticpro this one. */
3349 static struct Lisp_Hash_Table
*weak_hash_tables
;
3351 /* Various symbols. */
3353 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3354 Lisp_Object Qeq
, Qeql
, Qequal
;
3355 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3356 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3358 /* Function prototypes. */
3360 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3361 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3362 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3363 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3367 /***********************************************************************
3369 ***********************************************************************/
3371 /* If OBJ is a Lisp hash table, return a pointer to its struct
3372 Lisp_Hash_Table. Otherwise, signal an error. */
3374 static struct Lisp_Hash_Table
*
3375 check_hash_table (Lisp_Object obj
)
3377 CHECK_HASH_TABLE (obj
);
3378 return XHASH_TABLE (obj
);
3382 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3383 number. A number is "almost" a prime number if it is not divisible
3384 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3387 next_almost_prime (EMACS_INT n
)
3389 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3390 for (n
|= 1; ; n
+= 2)
3391 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3396 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3397 which USED[I] is non-zero. If found at index I in ARGS, set
3398 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3399 0. This function is used to extract a keyword/argument pair from
3400 a DEFUN parameter list. */
3403 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3407 for (i
= 1; i
< nargs
; i
++)
3408 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3419 /* Return a Lisp vector which has the same contents as VEC but has
3420 at least INCR_MIN more entries, where INCR_MIN is positive.
3421 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3422 than NITEMS_MAX. Entries in the resulting
3423 vector that are not copied from VEC are set to nil. */
3426 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3428 struct Lisp_Vector
*v
;
3429 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3430 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3431 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3432 ? nitems_max
: C_language_max
);
3433 eassert (VECTORP (vec
));
3434 eassert (0 < incr_min
&& -1 <= nitems_max
);
3435 old_size
= ASIZE (vec
);
3436 incr_max
= n_max
- old_size
;
3437 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3438 if (incr_max
< incr
)
3439 memory_full (SIZE_MAX
);
3440 new_size
= old_size
+ incr
;
3441 v
= allocate_vector (new_size
);
3442 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3443 for (i
= old_size
; i
< new_size
; ++i
)
3444 v
->contents
[i
] = Qnil
;
3445 XSETVECTOR (vec
, v
);
3450 /***********************************************************************
3452 ***********************************************************************/
3454 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3455 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3456 KEY2 are the same. */
3459 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3460 Lisp_Object key1
, EMACS_UINT hash1
,
3461 Lisp_Object key2
, EMACS_UINT hash2
)
3463 return (FLOATP (key1
)
3465 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3469 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3470 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3471 KEY2 are the same. */
3474 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3475 Lisp_Object key1
, EMACS_UINT hash1
,
3476 Lisp_Object key2
, EMACS_UINT hash2
)
3478 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3482 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3483 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3484 if KEY1 and KEY2 are the same. */
3487 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3488 Lisp_Object key1
, EMACS_UINT hash1
,
3489 Lisp_Object key2
, EMACS_UINT hash2
)
3493 Lisp_Object args
[3];
3495 args
[0] = h
->user_cmp_function
;
3498 return !NILP (Ffuncall (3, args
));
3505 /* Value is a hash code for KEY for use in hash table H which uses
3506 `eq' to compare keys. The hash code returned is guaranteed to fit
3507 in a Lisp integer. */
3510 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3512 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3513 eassert ((hash
& ~INTMASK
) == 0);
3518 /* Value is a hash code for KEY for use in hash table H which uses
3519 `eql' to compare keys. The hash code returned is guaranteed to fit
3520 in a Lisp integer. */
3523 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3527 hash
= sxhash (key
, 0);
3529 hash
= XUINT (key
) ^ XTYPE (key
);
3530 eassert ((hash
& ~INTMASK
) == 0);
3535 /* Value is a hash code for KEY for use in hash table H which uses
3536 `equal' to compare keys. The hash code returned is guaranteed to fit
3537 in a Lisp integer. */
3540 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3542 EMACS_UINT hash
= sxhash (key
, 0);
3543 eassert ((hash
& ~INTMASK
) == 0);
3548 /* Value is a hash code for KEY for use in hash table H which uses as
3549 user-defined function to compare keys. The hash code returned is
3550 guaranteed to fit in a Lisp integer. */
3553 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3555 Lisp_Object args
[2], hash
;
3557 args
[0] = h
->user_hash_function
;
3559 hash
= Ffuncall (2, args
);
3560 if (!INTEGERP (hash
))
3561 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3562 return XUINT (hash
);
3565 /* An upper bound on the size of a hash table index. It must fit in
3566 ptrdiff_t and be a valid Emacs fixnum. */
3567 #define INDEX_SIZE_BOUND \
3568 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3570 /* Create and initialize a new hash table.
3572 TEST specifies the test the hash table will use to compare keys.
3573 It must be either one of the predefined tests `eq', `eql' or
3574 `equal' or a symbol denoting a user-defined test named TEST with
3575 test and hash functions USER_TEST and USER_HASH.
3577 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3579 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3580 new size when it becomes full is computed by adding REHASH_SIZE to
3581 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3582 table's new size is computed by multiplying its old size with
3585 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3586 be resized when the ratio of (number of entries in the table) /
3587 (table size) is >= REHASH_THRESHOLD.
3589 WEAK specifies the weakness of the table. If non-nil, it must be
3590 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3593 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3594 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3595 Lisp_Object user_test
, Lisp_Object user_hash
)
3597 struct Lisp_Hash_Table
*h
;
3599 EMACS_INT index_size
, sz
;
3603 /* Preconditions. */
3604 eassert (SYMBOLP (test
));
3605 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3606 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3607 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3608 eassert (FLOATP (rehash_threshold
)
3609 && 0 < XFLOAT_DATA (rehash_threshold
)
3610 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3612 if (XFASTINT (size
) == 0)
3613 size
= make_number (1);
3615 sz
= XFASTINT (size
);
3616 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3617 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3618 ? next_almost_prime (index_float
)
3619 : INDEX_SIZE_BOUND
+ 1);
3620 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3621 error ("Hash table too large");
3623 /* Allocate a table and initialize it. */
3624 h
= allocate_hash_table ();
3626 /* Initialize hash table slots. */
3628 if (EQ (test
, Qeql
))
3630 h
->cmpfn
= cmpfn_eql
;
3631 h
->hashfn
= hashfn_eql
;
3633 else if (EQ (test
, Qeq
))
3636 h
->hashfn
= hashfn_eq
;
3638 else if (EQ (test
, Qequal
))
3640 h
->cmpfn
= cmpfn_equal
;
3641 h
->hashfn
= hashfn_equal
;
3645 h
->user_cmp_function
= user_test
;
3646 h
->user_hash_function
= user_hash
;
3647 h
->cmpfn
= cmpfn_user_defined
;
3648 h
->hashfn
= hashfn_user_defined
;
3652 h
->rehash_threshold
= rehash_threshold
;
3653 h
->rehash_size
= rehash_size
;
3655 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3656 h
->hash
= Fmake_vector (size
, Qnil
);
3657 h
->next
= Fmake_vector (size
, Qnil
);
3658 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3660 /* Set up the free list. */
3661 for (i
= 0; i
< sz
- 1; ++i
)
3662 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3663 h
->next_free
= make_number (0);
3665 XSET_HASH_TABLE (table
, h
);
3666 eassert (HASH_TABLE_P (table
));
3667 eassert (XHASH_TABLE (table
) == h
);
3669 /* Maybe add this hash table to the list of all weak hash tables. */
3671 h
->next_weak
= NULL
;
3674 h
->next_weak
= weak_hash_tables
;
3675 weak_hash_tables
= h
;
3682 /* Return a copy of hash table H1. Keys and values are not copied,
3683 only the table itself is. */
3686 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3689 struct Lisp_Hash_Table
*h2
;
3690 struct Lisp_Vector
*next
;
3692 h2
= allocate_hash_table ();
3693 next
= h2
->header
.next
.vector
;
3694 memcpy (h2
, h1
, sizeof *h2
);
3695 h2
->header
.next
.vector
= next
;
3696 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3697 h2
->hash
= Fcopy_sequence (h1
->hash
);
3698 h2
->next
= Fcopy_sequence (h1
->next
);
3699 h2
->index
= Fcopy_sequence (h1
->index
);
3700 XSET_HASH_TABLE (table
, h2
);
3702 /* Maybe add this hash table to the list of all weak hash tables. */
3703 if (!NILP (h2
->weak
))
3705 h2
->next_weak
= weak_hash_tables
;
3706 weak_hash_tables
= h2
;
3713 /* Resize hash table H if it's too full. If H cannot be resized
3714 because it's already too large, throw an error. */
3717 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3719 if (NILP (h
->next_free
))
3721 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3722 EMACS_INT new_size
, index_size
, nsize
;
3726 if (INTEGERP (h
->rehash_size
))
3727 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3730 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3731 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3733 new_size
= float_new_size
;
3734 if (new_size
<= old_size
)
3735 new_size
= old_size
+ 1;
3738 new_size
= INDEX_SIZE_BOUND
+ 1;
3740 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3741 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3742 ? next_almost_prime (index_float
)
3743 : INDEX_SIZE_BOUND
+ 1);
3744 nsize
= max (index_size
, 2 * new_size
);
3745 if (INDEX_SIZE_BOUND
< nsize
)
3746 error ("Hash table too large to resize");
3748 #ifdef ENABLE_CHECKING
3749 if (HASH_TABLE_P (Vpurify_flag
)
3750 && XHASH_TABLE (Vpurify_flag
) == h
)
3752 Lisp_Object args
[2];
3753 args
[0] = build_string ("Growing hash table to: %d");
3754 args
[1] = make_number (new_size
);
3759 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3760 2 * (new_size
- old_size
), -1));
3761 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3762 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3763 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3765 /* Update the free list. Do it so that new entries are added at
3766 the end of the free list. This makes some operations like
3768 for (i
= old_size
; i
< new_size
- 1; ++i
)
3769 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3771 if (!NILP (h
->next_free
))
3773 Lisp_Object last
, next
;
3775 last
= h
->next_free
;
3776 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3780 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3783 XSETFASTINT (h
->next_free
, old_size
);
3786 for (i
= 0; i
< old_size
; ++i
)
3787 if (!NILP (HASH_HASH (h
, i
)))
3789 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3790 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3791 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3792 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3798 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3799 the hash code of KEY. Value is the index of the entry in H
3800 matching KEY, or -1 if not found. */
3803 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3805 EMACS_UINT hash_code
;
3806 ptrdiff_t start_of_bucket
;
3809 hash_code
= h
->hashfn (h
, key
);
3813 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3814 idx
= HASH_INDEX (h
, start_of_bucket
);
3816 /* We need not gcpro idx since it's either an integer or nil. */
3819 ptrdiff_t i
= XFASTINT (idx
);
3820 if (EQ (key
, HASH_KEY (h
, i
))
3822 && h
->cmpfn (h
, key
, hash_code
,
3823 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3825 idx
= HASH_NEXT (h
, i
);
3828 return NILP (idx
) ? -1 : XFASTINT (idx
);
3832 /* Put an entry into hash table H that associates KEY with VALUE.
3833 HASH is a previously computed hash code of KEY.
3834 Value is the index of the entry in H matching KEY. */
3837 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3840 ptrdiff_t start_of_bucket
, i
;
3842 eassert ((hash
& ~INTMASK
) == 0);
3844 /* Increment count after resizing because resizing may fail. */
3845 maybe_resize_hash_table (h
);
3848 /* Store key/value in the key_and_value vector. */
3849 i
= XFASTINT (h
->next_free
);
3850 h
->next_free
= HASH_NEXT (h
, i
);
3851 set_hash_key_slot (h
, i
, key
);
3852 set_hash_value_slot (h
, i
, value
);
3854 /* Remember its hash code. */
3855 set_hash_hash_slot (h
, i
, make_number (hash
));
3857 /* Add new entry to its collision chain. */
3858 start_of_bucket
= hash
% ASIZE (h
->index
);
3859 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3860 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3865 /* Remove the entry matching KEY from hash table H, if there is one. */
3868 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3870 EMACS_UINT hash_code
;
3871 ptrdiff_t start_of_bucket
;
3872 Lisp_Object idx
, prev
;
3874 hash_code
= h
->hashfn (h
, key
);
3875 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3876 idx
= HASH_INDEX (h
, start_of_bucket
);
3879 /* We need not gcpro idx, prev since they're either integers or nil. */
3882 ptrdiff_t i
= XFASTINT (idx
);
3884 if (EQ (key
, HASH_KEY (h
, i
))
3886 && h
->cmpfn (h
, key
, hash_code
,
3887 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3889 /* Take entry out of collision chain. */
3891 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3893 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3895 /* Clear slots in key_and_value and add the slots to
3897 set_hash_key_slot (h
, i
, Qnil
);
3898 set_hash_value_slot (h
, i
, Qnil
);
3899 set_hash_hash_slot (h
, i
, Qnil
);
3900 set_hash_next_slot (h
, i
, h
->next_free
);
3901 h
->next_free
= make_number (i
);
3903 eassert (h
->count
>= 0);
3909 idx
= HASH_NEXT (h
, i
);
3915 /* Clear hash table H. */
3918 hash_clear (struct Lisp_Hash_Table
*h
)
3922 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3924 for (i
= 0; i
< size
; ++i
)
3926 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3927 set_hash_key_slot (h
, i
, Qnil
);
3928 set_hash_value_slot (h
, i
, Qnil
);
3929 set_hash_hash_slot (h
, i
, Qnil
);
3932 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3933 ASET (h
->index
, i
, Qnil
);
3935 h
->next_free
= make_number (0);
3942 /************************************************************************
3944 ************************************************************************/
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 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3971 bool 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 set_hash_index_slot (h
, bucket
, next
);
3995 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3997 /* Add to free list. */
3998 set_hash_next_slot (h
, i
, h
->next_free
);
4001 /* Clear key, value, and hash. */
4002 set_hash_key_slot (h
, i
, Qnil
);
4003 set_hash_value_slot (h
, i
, Qnil
);
4004 set_hash_hash_slot (h
, i
, Qnil
);
4017 /* Make sure key and value survive. */
4018 if (!key_known_to_survive_p
)
4020 mark_object (HASH_KEY (h
, i
));
4024 if (!value_known_to_survive_p
)
4026 mark_object (HASH_VALUE (h
, i
));
4037 /* Remove elements from weak hash tables that don't survive the
4038 current garbage collection. Remove weak tables that don't survive
4039 from Vweak_hash_tables. Called from gc_sweep. */
4042 sweep_weak_hash_tables (void)
4044 struct Lisp_Hash_Table
*h
, *used
, *next
;
4047 /* Mark all keys and values that are in use. Keep on marking until
4048 there is no more change. This is necessary for cases like
4049 value-weak table A containing an entry X -> Y, where Y is used in a
4050 key-weak table B, Z -> Y. If B comes after A in the list of weak
4051 tables, X -> Y might be removed from A, although when looking at B
4052 one finds that it shouldn't. */
4056 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4058 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4059 marked
|= sweep_weak_table (h
, 0);
4064 /* Remove tables and entries that aren't used. */
4065 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4067 next
= h
->next_weak
;
4069 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4071 /* TABLE is marked as used. Sweep its contents. */
4073 sweep_weak_table (h
, 1);
4075 /* Add table to the list of used weak hash tables. */
4076 h
->next_weak
= used
;
4081 weak_hash_tables
= used
;
4086 /***********************************************************************
4087 Hash Code Computation
4088 ***********************************************************************/
4090 /* Maximum depth up to which to dive into Lisp structures. */
4092 #define SXHASH_MAX_DEPTH 3
4094 /* Maximum length up to which to take list and vector elements into
4097 #define SXHASH_MAX_LEN 7
4099 /* Combine two integers X and Y for hashing. The result might not fit
4100 into a Lisp integer. */
4102 #define SXHASH_COMBINE(X, Y) \
4103 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4106 /* Hash X, returning a value that fits into a Lisp integer. */
4107 #define SXHASH_REDUCE(X) \
4108 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4110 /* Return a hash for string PTR which has length LEN. The hash value
4111 can be any EMACS_UINT value. */
4114 hash_string (char const *ptr
, ptrdiff_t len
)
4116 char const *p
= ptr
;
4117 char const *end
= p
+ len
;
4119 EMACS_UINT hash
= 0;
4124 hash
= SXHASH_COMBINE (hash
, c
);
4130 /* Return a hash for string PTR which has length LEN. The hash
4131 code returned is guaranteed to fit in a Lisp integer. */
4134 sxhash_string (char const *ptr
, ptrdiff_t len
)
4136 EMACS_UINT hash
= hash_string (ptr
, len
);
4137 return SXHASH_REDUCE (hash
);
4140 /* Return a hash for the floating point value VAL. */
4143 sxhash_float (double val
)
4145 EMACS_UINT hash
= 0;
4147 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4148 + (sizeof val
% sizeof hash
!= 0))
4152 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4156 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4157 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4158 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4159 return SXHASH_REDUCE (hash
);
4162 /* Return a hash for list LIST. DEPTH is the current depth in the
4163 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4166 sxhash_list (Lisp_Object list
, int depth
)
4168 EMACS_UINT hash
= 0;
4171 if (depth
< SXHASH_MAX_DEPTH
)
4173 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4174 list
= XCDR (list
), ++i
)
4176 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4177 hash
= SXHASH_COMBINE (hash
, hash2
);
4182 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4183 hash
= SXHASH_COMBINE (hash
, hash2
);
4186 return SXHASH_REDUCE (hash
);
4190 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4191 the Lisp structure. */
4194 sxhash_vector (Lisp_Object vec
, int depth
)
4196 EMACS_UINT hash
= ASIZE (vec
);
4199 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4200 for (i
= 0; i
< n
; ++i
)
4202 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4203 hash
= SXHASH_COMBINE (hash
, hash2
);
4206 return SXHASH_REDUCE (hash
);
4209 /* Return a hash for bool-vector VECTOR. */
4212 sxhash_bool_vector (Lisp_Object vec
)
4214 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4217 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4218 for (i
= 0; i
< n
; ++i
)
4219 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4221 return SXHASH_REDUCE (hash
);
4225 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4226 structure. Value is an unsigned integer clipped to INTMASK. */
4229 sxhash (Lisp_Object obj
, int depth
)
4233 if (depth
> SXHASH_MAX_DEPTH
)
4236 switch (XTYPE (obj
))
4247 obj
= SYMBOL_NAME (obj
);
4251 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4254 /* This can be everything from a vector to an overlay. */
4255 case Lisp_Vectorlike
:
4257 /* According to the CL HyperSpec, two arrays are equal only if
4258 they are `eq', except for strings and bit-vectors. In
4259 Emacs, this works differently. We have to compare element
4261 hash
= sxhash_vector (obj
, depth
);
4262 else if (BOOL_VECTOR_P (obj
))
4263 hash
= sxhash_bool_vector (obj
);
4265 /* Others are `equal' if they are `eq', so let's take their
4271 hash
= sxhash_list (obj
, depth
);
4275 hash
= sxhash_float (XFLOAT_DATA (obj
));
4287 /***********************************************************************
4289 ***********************************************************************/
4292 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4293 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4296 EMACS_UINT hash
= sxhash (obj
, 0);
4297 return make_number (hash
);
4301 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4302 doc
: /* Create and return a new hash table.
4304 Arguments are specified as keyword/argument pairs. The following
4305 arguments are defined:
4307 :test TEST -- TEST must be a symbol that specifies how to compare
4308 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4309 `equal'. User-supplied test and hash functions can be specified via
4310 `define-hash-table-test'.
4312 :size SIZE -- A hint as to how many elements will be put in the table.
4315 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4316 fills up. If REHASH-SIZE is an integer, increase the size by that
4317 amount. If it is a float, it must be > 1.0, and the new size is the
4318 old size multiplied by that factor. Default is 1.5.
4320 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4321 Resize the hash table when the ratio (number of entries / table size)
4322 is greater than or equal to THRESHOLD. Default is 0.8.
4324 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4325 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4326 returned is a weak table. Key/value pairs are removed from a weak
4327 hash table when there are no non-weak references pointing to their
4328 key, value, one of key or value, or both key and value, depending on
4329 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4332 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4333 (ptrdiff_t nargs
, Lisp_Object
*args
)
4335 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4336 Lisp_Object user_test
, user_hash
;
4340 /* The vector `used' is used to keep track of arguments that
4341 have been consumed. */
4342 used
= alloca (nargs
* sizeof *used
);
4343 memset (used
, 0, nargs
* sizeof *used
);
4345 /* See if there's a `:test TEST' among the arguments. */
4346 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4347 test
= i
? args
[i
] : Qeql
;
4348 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4350 /* See if it is a user-defined test. */
4353 prop
= Fget (test
, Qhash_table_test
);
4354 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4355 signal_error ("Invalid hash table test", test
);
4356 user_test
= XCAR (prop
);
4357 user_hash
= XCAR (XCDR (prop
));
4360 user_test
= user_hash
= Qnil
;
4362 /* See if there's a `:size SIZE' argument. */
4363 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4364 size
= i
? args
[i
] : Qnil
;
4366 size
= make_number (DEFAULT_HASH_SIZE
);
4367 else if (!INTEGERP (size
) || XINT (size
) < 0)
4368 signal_error ("Invalid hash table size", size
);
4370 /* Look for `:rehash-size SIZE'. */
4371 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4372 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4373 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4374 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4375 signal_error ("Invalid hash table rehash size", rehash_size
);
4377 /* Look for `:rehash-threshold THRESHOLD'. */
4378 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4379 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4380 if (! (FLOATP (rehash_threshold
)
4381 && 0 < XFLOAT_DATA (rehash_threshold
)
4382 && XFLOAT_DATA (rehash_threshold
) <= 1))
4383 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4385 /* Look for `:weakness WEAK'. */
4386 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4387 weak
= i
? args
[i
] : Qnil
;
4389 weak
= Qkey_and_value
;
4392 && !EQ (weak
, Qvalue
)
4393 && !EQ (weak
, Qkey_or_value
)
4394 && !EQ (weak
, Qkey_and_value
))
4395 signal_error ("Invalid hash table weakness", weak
);
4397 /* Now, all args should have been used up, or there's a problem. */
4398 for (i
= 0; i
< nargs
; ++i
)
4400 signal_error ("Invalid argument list", args
[i
]);
4402 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4403 user_test
, user_hash
);
4407 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4408 doc
: /* Return a copy of hash table TABLE. */)
4411 return copy_hash_table (check_hash_table (table
));
4415 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4416 doc
: /* Return the number of elements in TABLE. */)
4419 return make_number (check_hash_table (table
)->count
);
4423 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4424 Shash_table_rehash_size
, 1, 1, 0,
4425 doc
: /* Return the current rehash size of TABLE. */)
4428 return check_hash_table (table
)->rehash_size
;
4432 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4433 Shash_table_rehash_threshold
, 1, 1, 0,
4434 doc
: /* Return the current rehash threshold of TABLE. */)
4437 return check_hash_table (table
)->rehash_threshold
;
4441 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4442 doc
: /* Return the size of TABLE.
4443 The size can be used as an argument to `make-hash-table' to create
4444 a hash table than can hold as many elements as TABLE holds
4445 without need for resizing. */)
4448 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4449 return make_number (HASH_TABLE_SIZE (h
));
4453 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4454 doc
: /* Return the test TABLE uses. */)
4457 return check_hash_table (table
)->test
;
4461 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4463 doc
: /* Return the weakness of TABLE. */)
4466 return check_hash_table (table
)->weak
;
4470 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4471 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4474 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4478 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4479 doc
: /* Clear hash table TABLE and return it. */)
4482 hash_clear (check_hash_table (table
));
4483 /* Be compatible with XEmacs. */
4488 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4489 doc
: /* Look up KEY in TABLE and return its associated value.
4490 If KEY is not found, return DFLT which defaults to nil. */)
4491 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4493 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4494 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4495 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4499 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4500 doc
: /* Associate KEY with VALUE in hash table TABLE.
4501 If KEY is already present in table, replace its current value with
4502 VALUE. In any case, return VALUE. */)
4503 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4505 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4509 i
= hash_lookup (h
, key
, &hash
);
4511 set_hash_value_slot (h
, i
, value
);
4513 hash_put (h
, key
, value
, hash
);
4519 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4520 doc
: /* Remove KEY from TABLE. */)
4521 (Lisp_Object key
, Lisp_Object table
)
4523 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4524 hash_remove_from_table (h
, key
);
4529 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4530 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4531 FUNCTION is called with two arguments, KEY and VALUE. */)
4532 (Lisp_Object function
, Lisp_Object table
)
4534 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4535 Lisp_Object args
[3];
4538 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4539 if (!NILP (HASH_HASH (h
, i
)))
4542 args
[1] = HASH_KEY (h
, i
);
4543 args
[2] = HASH_VALUE (h
, i
);
4551 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4552 Sdefine_hash_table_test
, 3, 3, 0,
4553 doc
: /* Define a new hash table test with name NAME, a symbol.
4555 In hash tables created with NAME specified as test, use TEST to
4556 compare keys, and HASH for computing hash codes of keys.
4558 TEST must be a function taking two arguments and returning non-nil if
4559 both arguments are the same. HASH must be a function taking one
4560 argument and return an integer that is the hash code of the argument.
4561 Hash code computation should use the whole value range of integers,
4562 including negative integers. */)
4563 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4565 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4570 /************************************************************************
4571 MD5, SHA-1, and SHA-2
4572 ************************************************************************/
4579 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4582 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4586 EMACS_INT start_char
= 0, end_char
= 0;
4587 ptrdiff_t start_byte
, end_byte
;
4588 register EMACS_INT b
, e
;
4589 register struct buffer
*bp
;
4592 void *(*hash_func
) (const char *, size_t, void *);
4595 CHECK_SYMBOL (algorithm
);
4597 if (STRINGP (object
))
4599 if (NILP (coding_system
))
4601 /* Decide the coding-system to encode the data with. */
4603 if (STRING_MULTIBYTE (object
))
4604 /* use default, we can't guess correct value */
4605 coding_system
= preferred_coding_system ();
4607 coding_system
= Qraw_text
;
4610 if (NILP (Fcoding_system_p (coding_system
)))
4612 /* Invalid coding system. */
4614 if (!NILP (noerror
))
4615 coding_system
= Qraw_text
;
4617 xsignal1 (Qcoding_system_error
, coding_system
);
4620 if (STRING_MULTIBYTE (object
))
4621 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4623 size
= SCHARS (object
);
4627 CHECK_NUMBER (start
);
4629 start_char
= XINT (start
);
4641 end_char
= XINT (end
);
4647 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4648 args_out_of_range_3 (object
, make_number (start_char
),
4649 make_number (end_char
));
4651 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4653 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4657 struct buffer
*prev
= current_buffer
;
4659 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4661 CHECK_BUFFER (object
);
4663 bp
= XBUFFER (object
);
4664 if (bp
!= current_buffer
)
4665 set_buffer_internal (bp
);
4671 CHECK_NUMBER_COERCE_MARKER (start
);
4679 CHECK_NUMBER_COERCE_MARKER (end
);
4684 temp
= b
, b
= e
, e
= temp
;
4686 if (!(BEGV
<= b
&& e
<= ZV
))
4687 args_out_of_range (start
, end
);
4689 if (NILP (coding_system
))
4691 /* Decide the coding-system to encode the data with.
4692 See fileio.c:Fwrite-region */
4694 if (!NILP (Vcoding_system_for_write
))
4695 coding_system
= Vcoding_system_for_write
;
4698 int force_raw_text
= 0;
4700 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4701 if (NILP (coding_system
)
4702 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4704 coding_system
= Qnil
;
4705 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4709 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4711 /* Check file-coding-system-alist. */
4712 Lisp_Object args
[4], val
;
4714 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4715 args
[3] = Fbuffer_file_name (object
);
4716 val
= Ffind_operation_coding_system (4, args
);
4717 if (CONSP (val
) && !NILP (XCDR (val
)))
4718 coding_system
= XCDR (val
);
4721 if (NILP (coding_system
)
4722 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4724 /* If we still have not decided a coding system, use the
4725 default value of buffer-file-coding-system. */
4726 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4730 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4731 /* Confirm that VAL can surely encode the current region. */
4732 coding_system
= call4 (Vselect_safe_coding_system_function
,
4733 make_number (b
), make_number (e
),
4734 coding_system
, Qnil
);
4737 coding_system
= Qraw_text
;
4740 if (NILP (Fcoding_system_p (coding_system
)))
4742 /* Invalid coding system. */
4744 if (!NILP (noerror
))
4745 coding_system
= Qraw_text
;
4747 xsignal1 (Qcoding_system_error
, coding_system
);
4751 object
= make_buffer_string (b
, e
, 0);
4752 if (prev
!= current_buffer
)
4753 set_buffer_internal (prev
);
4754 /* Discard the unwind protect for recovering the current
4758 if (STRING_MULTIBYTE (object
))
4759 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4761 end_byte
= SBYTES (object
);
4764 if (EQ (algorithm
, Qmd5
))
4766 digest_size
= MD5_DIGEST_SIZE
;
4767 hash_func
= md5_buffer
;
4769 else if (EQ (algorithm
, Qsha1
))
4771 digest_size
= SHA1_DIGEST_SIZE
;
4772 hash_func
= sha1_buffer
;
4774 else if (EQ (algorithm
, Qsha224
))
4776 digest_size
= SHA224_DIGEST_SIZE
;
4777 hash_func
= sha224_buffer
;
4779 else if (EQ (algorithm
, Qsha256
))
4781 digest_size
= SHA256_DIGEST_SIZE
;
4782 hash_func
= sha256_buffer
;
4784 else if (EQ (algorithm
, Qsha384
))
4786 digest_size
= SHA384_DIGEST_SIZE
;
4787 hash_func
= sha384_buffer
;
4789 else if (EQ (algorithm
, Qsha512
))
4791 digest_size
= SHA512_DIGEST_SIZE
;
4792 hash_func
= sha512_buffer
;
4795 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4797 /* allocate 2 x digest_size so that it can be re-used to hold the
4799 digest
= make_uninit_string (digest_size
* 2);
4801 hash_func (SSDATA (object
) + start_byte
,
4802 end_byte
- start_byte
,
4807 unsigned char *p
= SDATA (digest
);
4808 for (i
= digest_size
- 1; i
>= 0; i
--)
4810 static char const hexdigit
[16] = "0123456789abcdef";
4812 p
[2 * i
] = hexdigit
[p_i
>> 4];
4813 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4818 return make_unibyte_string (SSDATA (digest
), digest_size
);
4821 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4822 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4824 A message digest is a cryptographic checksum of a document, and the
4825 algorithm to calculate it is defined in RFC 1321.
4827 The two optional arguments START and END are character positions
4828 specifying for which part of OBJECT the message digest should be
4829 computed. If nil or omitted, the digest is computed for the whole
4832 The MD5 message digest is computed from the result of encoding the
4833 text in a coding system, not directly from the internal Emacs form of
4834 the text. The optional fourth argument CODING-SYSTEM specifies which
4835 coding system to encode the text with. It should be the same coding
4836 system that you used or will use when actually writing the text into a
4839 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4840 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4841 system would be chosen by default for writing this text into a file.
4843 If OBJECT is a string, the most preferred coding system (see the
4844 command `prefer-coding-system') is used.
4846 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4847 guesswork fails. Normally, an error is signaled in such case. */)
4848 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4850 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4853 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4854 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4855 ALGORITHM is a symbol specifying the hash to use:
4856 md5, sha1, sha224, sha256, sha384 or sha512.
4858 The two optional arguments START and END are positions specifying for
4859 which part of OBJECT to compute the hash. If nil or omitted, uses the
4862 If BINARY is non-nil, returns a string in binary form. */)
4863 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4865 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4871 DEFSYM (Qmd5
, "md5");
4872 DEFSYM (Qsha1
, "sha1");
4873 DEFSYM (Qsha224
, "sha224");
4874 DEFSYM (Qsha256
, "sha256");
4875 DEFSYM (Qsha384
, "sha384");
4876 DEFSYM (Qsha512
, "sha512");
4878 /* Hash table stuff. */
4879 DEFSYM (Qhash_table_p
, "hash-table-p");
4881 DEFSYM (Qeql
, "eql");
4882 DEFSYM (Qequal
, "equal");
4883 DEFSYM (QCtest
, ":test");
4884 DEFSYM (QCsize
, ":size");
4885 DEFSYM (QCrehash_size
, ":rehash-size");
4886 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4887 DEFSYM (QCweakness
, ":weakness");
4888 DEFSYM (Qkey
, "key");
4889 DEFSYM (Qvalue
, "value");
4890 DEFSYM (Qhash_table_test
, "hash-table-test");
4891 DEFSYM (Qkey_or_value
, "key-or-value");
4892 DEFSYM (Qkey_and_value
, "key-and-value");
4895 defsubr (&Smake_hash_table
);
4896 defsubr (&Scopy_hash_table
);
4897 defsubr (&Shash_table_count
);
4898 defsubr (&Shash_table_rehash_size
);
4899 defsubr (&Shash_table_rehash_threshold
);
4900 defsubr (&Shash_table_size
);
4901 defsubr (&Shash_table_test
);
4902 defsubr (&Shash_table_weakness
);
4903 defsubr (&Shash_table_p
);
4904 defsubr (&Sclrhash
);
4905 defsubr (&Sgethash
);
4906 defsubr (&Sputhash
);
4907 defsubr (&Sremhash
);
4908 defsubr (&Smaphash
);
4909 defsubr (&Sdefine_hash_table_test
);
4911 DEFSYM (Qstring_lessp
, "string-lessp");
4912 DEFSYM (Qprovide
, "provide");
4913 DEFSYM (Qrequire
, "require");
4914 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4915 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4916 DEFSYM (Qwidget_type
, "widget-type");
4918 staticpro (&string_char_byte_cache_string
);
4919 string_char_byte_cache_string
= Qnil
;
4921 require_nesting_list
= Qnil
;
4922 staticpro (&require_nesting_list
);
4924 Fset (Qyes_or_no_p_history
, Qnil
);
4926 DEFVAR_LISP ("features", Vfeatures
,
4927 doc
: /* A list of symbols which are the features of the executing Emacs.
4928 Used by `featurep' and `require', and altered by `provide'. */);
4929 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4930 DEFSYM (Qsubfeatures
, "subfeatures");
4932 #ifdef HAVE_LANGINFO_CODESET
4933 DEFSYM (Qcodeset
, "codeset");
4934 DEFSYM (Qdays
, "days");
4935 DEFSYM (Qmonths
, "months");
4936 DEFSYM (Qpaper
, "paper");
4937 #endif /* HAVE_LANGINFO_CODESET */
4939 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4940 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4941 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4942 invoked by mouse clicks and mouse menu items.
4944 On some platforms, file selection dialogs are also enabled if this is
4948 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4949 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4950 This applies to commands from menus and tool bar buttons even when
4951 they are initiated from the keyboard. If `use-dialog-box' is nil,
4952 that disables the use of a file dialog, regardless of the value of
4954 use_file_dialog
= 1;
4956 defsubr (&Sidentity
);
4959 defsubr (&Ssafe_length
);
4960 defsubr (&Sstring_bytes
);
4961 defsubr (&Sstring_equal
);
4962 defsubr (&Scompare_strings
);
4963 defsubr (&Sstring_lessp
);
4966 defsubr (&Svconcat
);
4967 defsubr (&Scopy_sequence
);
4968 defsubr (&Sstring_make_multibyte
);
4969 defsubr (&Sstring_make_unibyte
);
4970 defsubr (&Sstring_as_multibyte
);
4971 defsubr (&Sstring_as_unibyte
);
4972 defsubr (&Sstring_to_multibyte
);
4973 defsubr (&Sstring_to_unibyte
);
4974 defsubr (&Scopy_alist
);
4975 defsubr (&Ssubstring
);
4976 defsubr (&Ssubstring_no_properties
);
4989 defsubr (&Snreverse
);
4990 defsubr (&Sreverse
);
4992 defsubr (&Splist_get
);
4994 defsubr (&Splist_put
);
4996 defsubr (&Slax_plist_get
);
4997 defsubr (&Slax_plist_put
);
5000 defsubr (&Sequal_including_properties
);
5001 defsubr (&Sfillarray
);
5002 defsubr (&Sclear_string
);
5006 defsubr (&Smapconcat
);
5007 defsubr (&Syes_or_no_p
);
5008 defsubr (&Sload_average
);
5009 defsubr (&Sfeaturep
);
5010 defsubr (&Srequire
);
5011 defsubr (&Sprovide
);
5012 defsubr (&Splist_member
);
5013 defsubr (&Swidget_put
);
5014 defsubr (&Swidget_get
);
5015 defsubr (&Swidget_apply
);
5016 defsubr (&Sbase64_encode_region
);
5017 defsubr (&Sbase64_decode_region
);
5018 defsubr (&Sbase64_encode_string
);
5019 defsubr (&Sbase64_decode_string
);
5021 defsubr (&Ssecure_hash
);
5022 defsubr (&Slocale_info
);