1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
43 #endif /* HAVE_MENUS */
46 #define NULL ((POINTER_TYPE *)0)
49 Lisp_Object Qstring_lessp
;
50 static Lisp_Object Qprovide
, Qrequire
;
51 static Lisp_Object Qyes_or_no_p_history
;
52 Lisp_Object Qcursor_in_echo_area
;
53 static Lisp_Object Qwidget_type
;
54 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
56 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
58 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
64 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
65 doc
: /* Return the argument unchanged. */)
71 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
72 doc
: /* Return a pseudo-random number.
73 All integers representable in Lisp are equally likely.
74 On most systems, this is 29 bits' worth.
75 With positive integer LIMIT, return random number in interval [0,LIMIT).
76 With argument t, set the random number seed from the current time and pid.
77 Other values of LIMIT are ignored. */)
81 Lisp_Object lispy_val
;
82 EMACS_UINT denominator
;
85 seed_random (getpid () + time (NULL
));
86 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
88 /* Try to take our random number from the higher bits of VAL,
89 not the lower, since (says Gentzel) the low bits of `random'
90 are less random than the higher ones. We do this by using the
91 quotient rather than the remainder. At the high end of the RNG
92 it's possible to get a quotient larger than n; discarding
93 these values eliminates the bias that would otherwise appear
94 when using a large n. */
95 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
97 val
= get_random () / denominator
;
98 while (val
>= XFASTINT (limit
));
102 XSETINT (lispy_val
, val
);
106 /* Heuristic on how many iterations of a tight loop can be safely done
107 before it's time to do a QUIT. This must be a power of 2. */
108 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
110 /* Random data-structure functions */
112 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
113 doc
: /* Return the length of vector, list or string SEQUENCE.
114 A byte-code function object is also allowed.
115 If the string contains multibyte characters, this is not necessarily
116 the number of bytes in the string; it is the number of characters.
117 To get the number of bytes, use `string-bytes'. */)
118 (register Lisp_Object sequence
)
120 register Lisp_Object val
;
122 if (STRINGP (sequence
))
123 XSETFASTINT (val
, SCHARS (sequence
));
124 else if (VECTORP (sequence
))
125 XSETFASTINT (val
, ASIZE (sequence
));
126 else if (CHAR_TABLE_P (sequence
))
127 XSETFASTINT (val
, MAX_CHAR
);
128 else if (BOOL_VECTOR_P (sequence
))
129 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
130 else if (COMPILEDP (sequence
))
131 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
132 else if (CONSP (sequence
))
139 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
141 if (MOST_POSITIVE_FIXNUM
< i
)
142 error ("List too long");
145 sequence
= XCDR (sequence
);
147 while (CONSP (sequence
));
149 CHECK_LIST_END (sequence
, sequence
);
151 val
= make_number (i
);
153 else if (NILP (sequence
))
154 XSETFASTINT (val
, 0);
156 wrong_type_argument (Qsequencep
, sequence
);
161 /* This does not check for quits. That is safe since it must terminate. */
163 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
164 doc
: /* Return the length of a list, but avoid error or infinite loop.
165 This function never gets an error. If LIST is not really a list,
166 it returns 0. If LIST is circular, it returns a finite value
167 which is at least the number of distinct elements. */)
170 Lisp_Object tail
, halftail
;
175 return make_number (0);
177 /* halftail is used to detect circular lists. */
178 for (tail
= halftail
= list
; ; )
183 if (EQ (tail
, halftail
))
186 if ((lolen
& 1) == 0)
188 halftail
= XCDR (halftail
);
189 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
193 hilen
+= UINTMAX_MAX
+ 1.0;
198 /* If the length does not fit into a fixnum, return a float.
199 On all known practical machines this returns an upper bound on
201 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
204 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
205 doc
: /* Return the number of bytes in STRING.
206 If STRING is multibyte, this may be greater than the length of STRING. */)
209 CHECK_STRING (string
);
210 return make_number (SBYTES (string
));
213 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
214 doc
: /* Return t if two strings have identical contents.
215 Case is significant, but text properties are ignored.
216 Symbols are also allowed; their print names are used instead. */)
217 (register Lisp_Object s1
, Lisp_Object s2
)
220 s1
= SYMBOL_NAME (s1
);
222 s2
= SYMBOL_NAME (s2
);
226 if (SCHARS (s1
) != SCHARS (s2
)
227 || SBYTES (s1
) != SBYTES (s2
)
228 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
233 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
234 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
235 In string STR1, skip the first START1 characters and stop at END1.
236 In string STR2, skip the first START2 characters and stop at END2.
237 END1 and END2 default to the full lengths of the respective strings.
239 Case is significant in this comparison if IGNORE-CASE is nil.
240 Unibyte strings are converted to multibyte for comparison.
242 The value is t if the strings (or specified portions) match.
243 If string STR1 is less, the value is a negative number N;
244 - 1 - N is the number of characters that match at the beginning.
245 If string STR1 is greater, the value is a positive number N;
246 N - 1 is the number of characters that match at the beginning. */)
247 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
249 register EMACS_INT end1_char
, end2_char
;
250 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
255 start1
= make_number (0);
257 start2
= make_number (0);
258 CHECK_NATNUM (start1
);
259 CHECK_NATNUM (start2
);
268 i1_byte
= string_char_to_byte (str1
, i1
);
269 i2_byte
= string_char_to_byte (str2
, i2
);
271 end1_char
= SCHARS (str1
);
272 if (! NILP (end1
) && end1_char
> XINT (end1
))
273 end1_char
= XINT (end1
);
275 end2_char
= SCHARS (str2
);
276 if (! NILP (end2
) && end2_char
> XINT (end2
))
277 end2_char
= XINT (end2
);
279 while (i1
< end1_char
&& i2
< end2_char
)
281 /* When we find a mismatch, we must compare the
282 characters, not just the bytes. */
285 if (STRING_MULTIBYTE (str1
))
286 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
289 c1
= SREF (str1
, i1
++);
290 MAKE_CHAR_MULTIBYTE (c1
);
293 if (STRING_MULTIBYTE (str2
))
294 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
297 c2
= SREF (str2
, i2
++);
298 MAKE_CHAR_MULTIBYTE (c2
);
304 if (! NILP (ignore_case
))
308 tem
= Fupcase (make_number (c1
));
310 tem
= Fupcase (make_number (c2
));
317 /* Note that I1 has already been incremented
318 past the character that we are comparing;
319 hence we don't add or subtract 1 here. */
321 return make_number (- i1
+ XINT (start1
));
323 return make_number (i1
- XINT (start1
));
327 return make_number (i1
- XINT (start1
) + 1);
329 return make_number (- i1
+ XINT (start1
) - 1);
334 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
335 doc
: /* Return t if first arg string is less than second in lexicographic order.
337 Symbols are also allowed; their print names are used instead. */)
338 (register Lisp_Object s1
, Lisp_Object s2
)
340 register EMACS_INT end
;
341 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
344 s1
= SYMBOL_NAME (s1
);
346 s2
= SYMBOL_NAME (s2
);
350 i1
= i1_byte
= i2
= i2_byte
= 0;
353 if (end
> SCHARS (s2
))
358 /* When we find a mismatch, we must compare the
359 characters, not just the bytes. */
362 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
363 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
366 return c1
< c2
? Qt
: Qnil
;
368 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
371 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
372 enum Lisp_Type target_type
, int last_special
);
376 concat2 (Lisp_Object s1
, Lisp_Object s2
)
381 return concat (2, args
, Lisp_String
, 0);
386 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
392 return concat (3, args
, Lisp_String
, 0);
395 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
396 doc
: /* Concatenate all the arguments and make the result a list.
397 The result is a list whose elements are the elements of all the arguments.
398 Each argument may be a list, vector or string.
399 The last argument is not copied, just used as the tail of the new list.
400 usage: (append &rest SEQUENCES) */)
401 (ptrdiff_t nargs
, Lisp_Object
*args
)
403 return concat (nargs
, args
, Lisp_Cons
, 1);
406 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
407 doc
: /* Concatenate all the arguments and make the result a string.
408 The result is a string whose elements are the elements of all the arguments.
409 Each argument may be a string or a list or vector of characters (integers).
410 usage: (concat &rest SEQUENCES) */)
411 (ptrdiff_t nargs
, Lisp_Object
*args
)
413 return concat (nargs
, args
, Lisp_String
, 0);
416 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
417 doc
: /* Concatenate all the arguments and make the result a vector.
418 The result is a vector whose elements are the elements of all the arguments.
419 Each argument may be a list, vector or string.
420 usage: (vconcat &rest SEQUENCES) */)
421 (ptrdiff_t nargs
, Lisp_Object
*args
)
423 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
427 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
428 doc
: /* Return a copy of a list, vector, string or char-table.
429 The elements of a list or vector are not copied; they are shared
430 with the original. */)
433 if (NILP (arg
)) return arg
;
435 if (CHAR_TABLE_P (arg
))
437 return copy_char_table (arg
);
440 if (BOOL_VECTOR_P (arg
))
443 ptrdiff_t size_in_chars
444 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
445 / BOOL_VECTOR_BITS_PER_CHAR
);
447 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
448 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
453 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
454 wrong_type_argument (Qsequencep
, arg
);
456 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
459 /* This structure holds information of an argument of `concat' that is
460 a string and has text properties to be copied. */
463 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
464 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
465 EMACS_INT to
; /* refer to VAL (the target string) */
469 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
470 enum Lisp_Type target_type
, int last_special
)
473 register Lisp_Object tail
;
474 register Lisp_Object
this;
476 EMACS_INT toindex_byte
= 0;
477 register EMACS_INT result_len
;
478 register EMACS_INT result_len_byte
;
480 Lisp_Object last_tail
;
483 /* When we make a multibyte string, we can't copy text properties
484 while concatenating each string because the length of resulting
485 string can't be decided until we finish the whole concatenation.
486 So, we record strings that have text properties to be copied
487 here, and copy the text properties after the concatenation. */
488 struct textprop_rec
*textprops
= NULL
;
489 /* Number of elements in textprops. */
490 ptrdiff_t num_textprops
= 0;
495 /* In append, the last arg isn't treated like the others */
496 if (last_special
&& nargs
> 0)
499 last_tail
= args
[nargs
];
504 /* Check each argument. */
505 for (argnum
= 0; argnum
< nargs
; argnum
++)
508 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
509 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
510 wrong_type_argument (Qsequencep
, this);
513 /* Compute total length in chars of arguments in RESULT_LEN.
514 If desired output is a string, also compute length in bytes
515 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
516 whether the result should be a multibyte string. */
520 for (argnum
= 0; argnum
< nargs
; argnum
++)
524 len
= XFASTINT (Flength (this));
525 if (target_type
== Lisp_String
)
527 /* We must count the number of bytes needed in the string
528 as well as the number of characters. */
532 EMACS_INT this_len_byte
;
534 if (VECTORP (this) || COMPILEDP (this))
535 for (i
= 0; i
< len
; i
++)
538 CHECK_CHARACTER (ch
);
540 this_len_byte
= CHAR_BYTES (c
);
541 result_len_byte
+= this_len_byte
;
542 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
545 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
546 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
547 else if (CONSP (this))
548 for (; CONSP (this); this = XCDR (this))
551 CHECK_CHARACTER (ch
);
553 this_len_byte
= CHAR_BYTES (c
);
554 result_len_byte
+= this_len_byte
;
555 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
558 else if (STRINGP (this))
560 if (STRING_MULTIBYTE (this))
563 result_len_byte
+= SBYTES (this);
566 result_len_byte
+= count_size_as_multibyte (SDATA (this),
572 if (STRING_BYTES_BOUND
< result_len
)
576 if (! some_multibyte
)
577 result_len_byte
= result_len
;
579 /* Create the output object. */
580 if (target_type
== Lisp_Cons
)
581 val
= Fmake_list (make_number (result_len
), Qnil
);
582 else if (target_type
== Lisp_Vectorlike
)
583 val
= Fmake_vector (make_number (result_len
), Qnil
);
584 else if (some_multibyte
)
585 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
587 val
= make_uninit_string (result_len
);
589 /* In `append', if all but last arg are nil, return last arg. */
590 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
593 /* Copy the contents of the args into the result. */
595 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
597 toindex
= 0, toindex_byte
= 0;
601 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
603 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 EMACS_INT thisleni
= 0;
607 register EMACS_INT thisindex
= 0;
608 register EMACS_INT thisindex_byte
= 0;
612 thislen
= Flength (this), thisleni
= XINT (thislen
);
614 /* Between strings of the same kind, copy fast. */
615 if (STRINGP (this) && STRINGP (val
)
616 && STRING_MULTIBYTE (this) == some_multibyte
)
618 EMACS_INT thislen_byte
= SBYTES (this);
620 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
621 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
623 textprops
[num_textprops
].argnum
= argnum
;
624 textprops
[num_textprops
].from
= 0;
625 textprops
[num_textprops
++].to
= toindex
;
627 toindex_byte
+= thislen_byte
;
630 /* Copy a single-byte string to a multibyte string. */
631 else if (STRINGP (this) && STRINGP (val
))
633 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
635 textprops
[num_textprops
].argnum
= argnum
;
636 textprops
[num_textprops
].from
= 0;
637 textprops
[num_textprops
++].to
= toindex
;
639 toindex_byte
+= copy_text (SDATA (this),
640 SDATA (val
) + toindex_byte
,
641 SCHARS (this), 0, 1);
645 /* Copy element by element. */
648 register Lisp_Object elt
;
650 /* Fetch next element of `this' arg into `elt', or break if
651 `this' is exhausted. */
652 if (NILP (this)) break;
654 elt
= XCAR (this), this = XCDR (this);
655 else if (thisindex
>= thisleni
)
657 else if (STRINGP (this))
660 if (STRING_MULTIBYTE (this))
661 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
666 c
= SREF (this, thisindex
); thisindex
++;
667 if (some_multibyte
&& !ASCII_CHAR_P (c
))
668 c
= BYTE8_TO_CHAR (c
);
670 XSETFASTINT (elt
, c
);
672 else if (BOOL_VECTOR_P (this))
675 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
676 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
684 elt
= AREF (this, thisindex
);
688 /* Store this element into the result. */
695 else if (VECTORP (val
))
697 ASET (val
, toindex
, elt
);
703 CHECK_CHARACTER (elt
);
706 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
708 SSET (val
, toindex_byte
++, c
);
714 XSETCDR (prev
, last_tail
);
716 if (num_textprops
> 0)
719 EMACS_INT last_to_end
= -1;
721 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
723 this = args
[textprops
[argnum
].argnum
];
724 props
= text_property_list (this,
726 make_number (SCHARS (this)),
728 /* If successive arguments have properties, be sure that the
729 value of `composition' property be the copy. */
730 if (last_to_end
== textprops
[argnum
].to
)
731 make_composition_value_copy (props
);
732 add_text_properties_from_list (val
, props
,
733 make_number (textprops
[argnum
].to
));
734 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
742 static Lisp_Object string_char_byte_cache_string
;
743 static EMACS_INT string_char_byte_cache_charpos
;
744 static EMACS_INT string_char_byte_cache_bytepos
;
747 clear_string_char_byte_cache (void)
749 string_char_byte_cache_string
= Qnil
;
752 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
755 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
758 EMACS_INT best_below
, best_below_byte
;
759 EMACS_INT best_above
, best_above_byte
;
761 best_below
= best_below_byte
= 0;
762 best_above
= SCHARS (string
);
763 best_above_byte
= SBYTES (string
);
764 if (best_above
== best_above_byte
)
767 if (EQ (string
, string_char_byte_cache_string
))
769 if (string_char_byte_cache_charpos
< char_index
)
771 best_below
= string_char_byte_cache_charpos
;
772 best_below_byte
= string_char_byte_cache_bytepos
;
776 best_above
= string_char_byte_cache_charpos
;
777 best_above_byte
= string_char_byte_cache_bytepos
;
781 if (char_index
- best_below
< best_above
- char_index
)
783 unsigned char *p
= SDATA (string
) + best_below_byte
;
785 while (best_below
< char_index
)
787 p
+= BYTES_BY_CHAR_HEAD (*p
);
790 i_byte
= p
- SDATA (string
);
794 unsigned char *p
= SDATA (string
) + best_above_byte
;
796 while (best_above
> char_index
)
799 while (!CHAR_HEAD_P (*p
)) p
--;
802 i_byte
= p
- SDATA (string
);
805 string_char_byte_cache_bytepos
= i_byte
;
806 string_char_byte_cache_charpos
= char_index
;
807 string_char_byte_cache_string
= string
;
812 /* Return the character index corresponding to BYTE_INDEX in STRING. */
815 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
818 EMACS_INT best_below
, best_below_byte
;
819 EMACS_INT best_above
, best_above_byte
;
821 best_below
= best_below_byte
= 0;
822 best_above
= SCHARS (string
);
823 best_above_byte
= SBYTES (string
);
824 if (best_above
== best_above_byte
)
827 if (EQ (string
, string_char_byte_cache_string
))
829 if (string_char_byte_cache_bytepos
< byte_index
)
831 best_below
= string_char_byte_cache_charpos
;
832 best_below_byte
= string_char_byte_cache_bytepos
;
836 best_above
= string_char_byte_cache_charpos
;
837 best_above_byte
= string_char_byte_cache_bytepos
;
841 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
843 unsigned char *p
= SDATA (string
) + best_below_byte
;
844 unsigned char *pend
= SDATA (string
) + byte_index
;
848 p
+= BYTES_BY_CHAR_HEAD (*p
);
852 i_byte
= p
- SDATA (string
);
856 unsigned char *p
= SDATA (string
) + best_above_byte
;
857 unsigned char *pbeg
= SDATA (string
) + byte_index
;
862 while (!CHAR_HEAD_P (*p
)) p
--;
866 i_byte
= p
- SDATA (string
);
869 string_char_byte_cache_bytepos
= i_byte
;
870 string_char_byte_cache_charpos
= i
;
871 string_char_byte_cache_string
= string
;
876 /* Convert STRING to a multibyte string. */
879 string_make_multibyte (Lisp_Object string
)
886 if (STRING_MULTIBYTE (string
))
889 nbytes
= count_size_as_multibyte (SDATA (string
),
891 /* If all the chars are ASCII, they won't need any more bytes
892 once converted. In that case, we can return STRING itself. */
893 if (nbytes
== SBYTES (string
))
896 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
897 copy_text (SDATA (string
), buf
, SBYTES (string
),
900 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
907 /* Convert STRING (if unibyte) to a multibyte string without changing
908 the number of characters. Characters 0200 trough 0237 are
909 converted to eight-bit characters. */
912 string_to_multibyte (Lisp_Object string
)
919 if (STRING_MULTIBYTE (string
))
922 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
923 /* If all the chars are ASCII, they won't need any more bytes once
925 if (nbytes
== SBYTES (string
))
926 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
928 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
929 memcpy (buf
, SDATA (string
), SBYTES (string
));
930 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
932 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
939 /* Convert STRING to a single-byte string. */
942 string_make_unibyte (Lisp_Object string
)
949 if (! STRING_MULTIBYTE (string
))
952 nchars
= SCHARS (string
);
954 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
955 copy_text (SDATA (string
), buf
, SBYTES (string
),
958 ret
= make_unibyte_string ((char *) buf
, nchars
);
964 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
966 doc
: /* Return the multibyte equivalent of STRING.
967 If STRING is unibyte and contains non-ASCII characters, the function
968 `unibyte-char-to-multibyte' is used to convert each unibyte character
969 to a multibyte character. In this case, the returned string is a
970 newly created string with no text properties. If STRING is multibyte
971 or entirely ASCII, it is returned unchanged. In particular, when
972 STRING is unibyte and entirely ASCII, the returned string is unibyte.
973 \(When the characters are all ASCII, Emacs primitives will treat the
974 string the same way whether it is unibyte or multibyte.) */)
977 CHECK_STRING (string
);
979 return string_make_multibyte (string
);
982 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
984 doc
: /* Return the unibyte equivalent of STRING.
985 Multibyte character codes are converted to unibyte according to
986 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
987 If the lookup in the translation table fails, this function takes just
988 the low 8 bits of each character. */)
991 CHECK_STRING (string
);
993 return string_make_unibyte (string
);
996 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
998 doc
: /* Return a unibyte string with the same individual bytes as STRING.
999 If STRING is unibyte, the result is STRING itself.
1000 Otherwise it is a newly created string, with no text properties.
1001 If STRING is multibyte and contains a character of charset
1002 `eight-bit', it is converted to the corresponding single byte. */)
1003 (Lisp_Object string
)
1005 CHECK_STRING (string
);
1007 if (STRING_MULTIBYTE (string
))
1009 EMACS_INT bytes
= SBYTES (string
);
1010 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1012 memcpy (str
, SDATA (string
), bytes
);
1013 bytes
= str_as_unibyte (str
, bytes
);
1014 string
= make_unibyte_string ((char *) str
, bytes
);
1020 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1022 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1023 If STRING is multibyte, the result is STRING itself.
1024 Otherwise it is a newly created string, with no text properties.
1026 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1027 part of a correct utf-8 sequence), it is converted to the corresponding
1028 multibyte character of charset `eight-bit'.
1029 See also `string-to-multibyte'.
1031 Beware, this often doesn't really do what you think it does.
1032 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1033 If you're not sure, whether to use `string-as-multibyte' or
1034 `string-to-multibyte', use `string-to-multibyte'. */)
1035 (Lisp_Object string
)
1037 CHECK_STRING (string
);
1039 if (! STRING_MULTIBYTE (string
))
1041 Lisp_Object new_string
;
1042 EMACS_INT nchars
, nbytes
;
1044 parse_str_as_multibyte (SDATA (string
),
1047 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1048 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1049 if (nbytes
!= SBYTES (string
))
1050 str_as_multibyte (SDATA (new_string
), nbytes
,
1051 SBYTES (string
), NULL
);
1052 string
= new_string
;
1053 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1058 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1060 doc
: /* Return a multibyte string with the same individual chars as STRING.
1061 If STRING is multibyte, the result is STRING itself.
1062 Otherwise it is a newly created string, with no text properties.
1064 If STRING is unibyte and contains an 8-bit byte, it is converted to
1065 the corresponding multibyte character of charset `eight-bit'.
1067 This differs from `string-as-multibyte' by converting each byte of a correct
1068 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1069 correct sequence. */)
1070 (Lisp_Object string
)
1072 CHECK_STRING (string
);
1074 return string_to_multibyte (string
);
1077 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1079 doc
: /* Return a unibyte string with the same individual chars as STRING.
1080 If STRING is unibyte, the result is STRING itself.
1081 Otherwise it is a newly created string, with no text properties,
1082 where each `eight-bit' character is converted to the corresponding byte.
1083 If STRING contains a non-ASCII, non-`eight-bit' character,
1084 an error is signaled. */)
1085 (Lisp_Object string
)
1087 CHECK_STRING (string
);
1089 if (STRING_MULTIBYTE (string
))
1091 EMACS_INT chars
= SCHARS (string
);
1092 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1093 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1095 if (converted
< chars
)
1096 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1097 string
= make_unibyte_string ((char *) str
, chars
);
1104 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1105 doc
: /* Return a copy of ALIST.
1106 This is an alist which represents the same mapping from objects to objects,
1107 but does not share the alist structure with ALIST.
1108 The objects mapped (cars and cdrs of elements of the alist)
1109 are shared, however.
1110 Elements of ALIST that are not conses are also shared. */)
1113 register Lisp_Object tem
;
1118 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1119 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1121 register Lisp_Object car
;
1125 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1130 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1131 doc
: /* Return a new string whose contents are a substring of STRING.
1132 The returned string consists of the characters between index FROM
1133 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1134 zero-indexed: 0 means the first character of STRING. Negative values
1135 are counted from the end of STRING. If TO is nil, the substring runs
1136 to the end of STRING.
1138 The STRING argument may also be a vector. In that case, the return
1139 value is a new vector that contains the elements between index FROM
1140 \(inclusive) and index TO (exclusive) of that vector argument. */)
1141 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1145 EMACS_INT size_byte
= 0;
1146 EMACS_INT from_char
, to_char
;
1147 EMACS_INT from_byte
= 0, to_byte
= 0;
1149 CHECK_VECTOR_OR_STRING (string
);
1150 CHECK_NUMBER (from
);
1152 if (STRINGP (string
))
1154 size
= SCHARS (string
);
1155 size_byte
= SBYTES (string
);
1158 size
= ASIZE (string
);
1163 to_byte
= size_byte
;
1169 to_char
= XINT (to
);
1173 if (STRINGP (string
))
1174 to_byte
= string_char_to_byte (string
, to_char
);
1177 from_char
= XINT (from
);
1180 if (STRINGP (string
))
1181 from_byte
= string_char_to_byte (string
, from_char
);
1183 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1184 args_out_of_range_3 (string
, make_number (from_char
),
1185 make_number (to_char
));
1187 if (STRINGP (string
))
1189 res
= make_specified_string (SSDATA (string
) + from_byte
,
1190 to_char
- from_char
, to_byte
- from_byte
,
1191 STRING_MULTIBYTE (string
));
1192 copy_text_properties (make_number (from_char
), make_number (to_char
),
1193 string
, make_number (0), res
, Qnil
);
1196 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1202 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1203 doc
: /* Return a substring of STRING, without text properties.
1204 It starts at index FROM and ends before TO.
1205 TO may be nil or omitted; then the substring runs to the end of STRING.
1206 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1207 If FROM or TO is negative, it counts from the end.
1209 With one argument, just copy STRING without its properties. */)
1210 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1212 EMACS_INT size
, size_byte
;
1213 EMACS_INT from_char
, to_char
;
1214 EMACS_INT from_byte
, to_byte
;
1216 CHECK_STRING (string
);
1218 size
= SCHARS (string
);
1219 size_byte
= SBYTES (string
);
1222 from_char
= from_byte
= 0;
1225 CHECK_NUMBER (from
);
1226 from_char
= XINT (from
);
1230 from_byte
= string_char_to_byte (string
, from_char
);
1236 to_byte
= size_byte
;
1242 to_char
= XINT (to
);
1246 to_byte
= string_char_to_byte (string
, to_char
);
1249 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1250 args_out_of_range_3 (string
, make_number (from_char
),
1251 make_number (to_char
));
1253 return make_specified_string (SSDATA (string
) + from_byte
,
1254 to_char
- from_char
, to_byte
- from_byte
,
1255 STRING_MULTIBYTE (string
));
1258 /* Extract a substring of STRING, giving start and end positions
1259 both in characters and in bytes. */
1262 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1263 EMACS_INT to
, EMACS_INT to_byte
)
1268 CHECK_VECTOR_OR_STRING (string
);
1270 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1272 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1273 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1275 if (STRINGP (string
))
1277 res
= make_specified_string (SSDATA (string
) + from_byte
,
1278 to
- from
, to_byte
- from_byte
,
1279 STRING_MULTIBYTE (string
));
1280 copy_text_properties (make_number (from
), make_number (to
),
1281 string
, make_number (0), res
, Qnil
);
1284 res
= Fvector (to
- from
, &AREF (string
, from
));
1289 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1290 doc
: /* Take cdr N times on LIST, return the result. */)
1291 (Lisp_Object n
, Lisp_Object list
)
1296 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1299 CHECK_LIST_CONS (list
, list
);
1305 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1306 doc
: /* Return the Nth element of LIST.
1307 N counts from zero. If LIST is not that long, nil is returned. */)
1308 (Lisp_Object n
, Lisp_Object list
)
1310 return Fcar (Fnthcdr (n
, list
));
1313 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1314 doc
: /* Return element of SEQUENCE at index N. */)
1315 (register Lisp_Object sequence
, Lisp_Object n
)
1318 if (CONSP (sequence
) || NILP (sequence
))
1319 return Fcar (Fnthcdr (n
, sequence
));
1321 /* Faref signals a "not array" error, so check here. */
1322 CHECK_ARRAY (sequence
, Qsequencep
);
1323 return Faref (sequence
, n
);
1326 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1327 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1328 The value is actually the tail of LIST whose car is ELT. */)
1329 (register Lisp_Object elt
, Lisp_Object list
)
1331 register Lisp_Object tail
;
1332 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1334 register Lisp_Object tem
;
1335 CHECK_LIST_CONS (tail
, list
);
1337 if (! NILP (Fequal (elt
, tem
)))
1344 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1345 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1346 The value is actually the tail of LIST whose car is ELT. */)
1347 (register Lisp_Object elt
, Lisp_Object list
)
1351 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1355 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1359 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1370 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1371 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1372 The value is actually the tail of LIST whose car is ELT. */)
1373 (register Lisp_Object elt
, Lisp_Object list
)
1375 register Lisp_Object tail
;
1378 return Fmemq (elt
, list
);
1380 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1382 register Lisp_Object tem
;
1383 CHECK_LIST_CONS (tail
, list
);
1385 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1392 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1393 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1394 The value is actually the first element of LIST whose car is KEY.
1395 Elements of LIST that are not conses are ignored. */)
1396 (Lisp_Object key
, Lisp_Object list
)
1401 || (CONSP (XCAR (list
))
1402 && EQ (XCAR (XCAR (list
)), key
)))
1407 || (CONSP (XCAR (list
))
1408 && EQ (XCAR (XCAR (list
)), key
)))
1413 || (CONSP (XCAR (list
))
1414 && EQ (XCAR (XCAR (list
)), key
)))
1424 /* Like Fassq but never report an error and do not allow quits.
1425 Use only on lists known never to be circular. */
1428 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1431 && (!CONSP (XCAR (list
))
1432 || !EQ (XCAR (XCAR (list
)), key
)))
1435 return CAR_SAFE (list
);
1438 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1439 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1440 The value is actually the first element of LIST whose car equals KEY. */)
1441 (Lisp_Object key
, Lisp_Object list
)
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
)))))
1462 || (CONSP (XCAR (list
))
1463 && (car
= XCAR (XCAR (list
)),
1464 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1474 /* Like Fassoc but never report an error and do not allow quits.
1475 Use only on lists known never to be circular. */
1478 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1481 && (!CONSP (XCAR (list
))
1482 || (!EQ (XCAR (XCAR (list
)), key
)
1483 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1486 return CONSP (list
) ? XCAR (list
) : Qnil
;
1489 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1490 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1491 The value is actually the first element of LIST whose cdr is KEY. */)
1492 (register Lisp_Object key
, Lisp_Object list
)
1497 || (CONSP (XCAR (list
))
1498 && EQ (XCDR (XCAR (list
)), key
)))
1503 || (CONSP (XCAR (list
))
1504 && EQ (XCDR (XCAR (list
)), key
)))
1509 || (CONSP (XCAR (list
))
1510 && EQ (XCDR (XCAR (list
)), key
)))
1520 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1521 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1522 The value is actually the first element of LIST whose cdr equals KEY. */)
1523 (Lisp_Object key
, Lisp_Object list
)
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
)))))
1544 || (CONSP (XCAR (list
))
1545 && (cdr
= XCDR (XCAR (list
)),
1546 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1556 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1557 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1558 The modified LIST is returned. Comparison is done with `eq'.
1559 If the first member of LIST is ELT, there is no way to remove it by side effect;
1560 therefore, write `(setq foo (delq element foo))'
1561 to be sure of changing the value of `foo'. */)
1562 (register Lisp_Object elt
, Lisp_Object list
)
1564 register Lisp_Object tail
, prev
;
1565 register Lisp_Object tem
;
1569 while (!NILP (tail
))
1571 CHECK_LIST_CONS (tail
, list
);
1578 Fsetcdr (prev
, XCDR (tail
));
1588 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1589 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1590 SEQ must be a list, a vector, or a string.
1591 The modified SEQ is returned. Comparison is done with `equal'.
1592 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1593 is not a side effect; it is simply using a different sequence.
1594 Therefore, write `(setq foo (delete element foo))'
1595 to be sure of changing the value of `foo'. */)
1596 (Lisp_Object elt
, Lisp_Object seq
)
1602 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1603 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1606 if (n
!= ASIZE (seq
))
1608 struct Lisp_Vector
*p
= allocate_vector (n
);
1610 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1611 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1612 p
->contents
[n
++] = AREF (seq
, i
);
1614 XSETVECTOR (seq
, p
);
1617 else if (STRINGP (seq
))
1619 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1622 for (i
= nchars
= nbytes
= ibyte
= 0;
1624 ++i
, ibyte
+= cbytes
)
1626 if (STRING_MULTIBYTE (seq
))
1628 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1629 cbytes
= CHAR_BYTES (c
);
1637 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1644 if (nchars
!= SCHARS (seq
))
1648 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1649 if (!STRING_MULTIBYTE (seq
))
1650 STRING_SET_UNIBYTE (tem
);
1652 for (i
= nchars
= nbytes
= ibyte
= 0;
1654 ++i
, ibyte
+= cbytes
)
1656 if (STRING_MULTIBYTE (seq
))
1658 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1659 cbytes
= CHAR_BYTES (c
);
1667 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1669 unsigned char *from
= SDATA (seq
) + ibyte
;
1670 unsigned char *to
= SDATA (tem
) + nbytes
;
1676 for (n
= cbytes
; n
--; )
1686 Lisp_Object tail
, prev
;
1688 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1690 CHECK_LIST_CONS (tail
, seq
);
1692 if (!NILP (Fequal (elt
, XCAR (tail
))))
1697 Fsetcdr (prev
, XCDR (tail
));
1708 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1709 doc
: /* Reverse LIST by modifying cdr pointers.
1710 Return the reversed list. */)
1713 register Lisp_Object prev
, tail
, next
;
1715 if (NILP (list
)) return list
;
1718 while (!NILP (tail
))
1721 CHECK_LIST_CONS (tail
, list
);
1723 Fsetcdr (tail
, prev
);
1730 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1731 doc
: /* Reverse LIST, copying. Return the reversed list.
1732 See also the function `nreverse', which is used more often. */)
1737 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1740 new = Fcons (XCAR (list
), new);
1742 CHECK_LIST_END (list
, list
);
1746 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1748 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1749 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1750 Returns the sorted list. LIST is modified by side effects.
1751 PREDICATE is called with two elements of LIST, and should return non-nil
1752 if the first element should sort before the second. */)
1753 (Lisp_Object list
, Lisp_Object predicate
)
1755 Lisp_Object front
, back
;
1756 register Lisp_Object len
, tem
;
1757 struct gcpro gcpro1
, gcpro2
;
1761 len
= Flength (list
);
1762 length
= XINT (len
);
1766 XSETINT (len
, (length
/ 2) - 1);
1767 tem
= Fnthcdr (len
, list
);
1769 Fsetcdr (tem
, Qnil
);
1771 GCPRO2 (front
, back
);
1772 front
= Fsort (front
, predicate
);
1773 back
= Fsort (back
, predicate
);
1775 return merge (front
, back
, predicate
);
1779 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1782 register Lisp_Object tail
;
1784 register Lisp_Object l1
, l2
;
1785 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1792 /* It is sufficient to protect org_l1 and org_l2.
1793 When l1 and l2 are updated, we copy the new values
1794 back into the org_ vars. */
1795 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1815 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1831 Fsetcdr (tail
, tem
);
1837 /* This does not check for quits. That is safe since it must terminate. */
1839 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1840 doc
: /* Extract a value from a property list.
1841 PLIST is a property list, which is a list of the form
1842 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1843 corresponding to the given PROP, or nil if PROP is not one of the
1844 properties on the list. This function never signals an error. */)
1845 (Lisp_Object plist
, Lisp_Object prop
)
1847 Lisp_Object tail
, halftail
;
1849 /* halftail is used to detect circular lists. */
1850 tail
= halftail
= plist
;
1851 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1853 if (EQ (prop
, XCAR (tail
)))
1854 return XCAR (XCDR (tail
));
1856 tail
= XCDR (XCDR (tail
));
1857 halftail
= XCDR (halftail
);
1858 if (EQ (tail
, halftail
))
1861 #if 0 /* Unsafe version. */
1862 /* This function can be called asynchronously
1863 (setup_coding_system). Don't QUIT in that case. */
1864 if (!interrupt_input_blocked
)
1872 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1873 doc
: /* Return the value of SYMBOL's PROPNAME property.
1874 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1875 (Lisp_Object symbol
, Lisp_Object propname
)
1877 CHECK_SYMBOL (symbol
);
1878 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1881 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1882 doc
: /* Change value in PLIST of PROP to VAL.
1883 PLIST is a property list, which is a list of the form
1884 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1885 If PROP is already a property on the list, its value is set to VAL,
1886 otherwise the new PROP VAL pair is added. The new plist is returned;
1887 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1888 The PLIST is modified by side effects. */)
1889 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1891 register Lisp_Object tail
, prev
;
1892 Lisp_Object newcell
;
1894 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1895 tail
= XCDR (XCDR (tail
)))
1897 if (EQ (prop
, XCAR (tail
)))
1899 Fsetcar (XCDR (tail
), val
);
1906 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1910 Fsetcdr (XCDR (prev
), newcell
);
1914 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1915 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1916 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1917 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1919 CHECK_SYMBOL (symbol
);
1920 XSYMBOL (symbol
)->plist
1921 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1925 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1926 doc
: /* Extract a value from a property list, comparing with `equal'.
1927 PLIST is a property list, which is a list of the form
1928 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1929 corresponding to the given PROP, or nil if PROP is not
1930 one of the properties on the list. */)
1931 (Lisp_Object plist
, Lisp_Object prop
)
1936 CONSP (tail
) && CONSP (XCDR (tail
));
1937 tail
= XCDR (XCDR (tail
)))
1939 if (! NILP (Fequal (prop
, XCAR (tail
))))
1940 return XCAR (XCDR (tail
));
1945 CHECK_LIST_END (tail
, prop
);
1950 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1951 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1952 PLIST is a property list, which is a list of the form
1953 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1954 If PROP is already a property on the list, its value is set to VAL,
1955 otherwise the new PROP VAL pair is added. The new plist is returned;
1956 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1957 The PLIST is modified by side effects. */)
1958 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1960 register Lisp_Object tail
, prev
;
1961 Lisp_Object newcell
;
1963 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1964 tail
= XCDR (XCDR (tail
)))
1966 if (! NILP (Fequal (prop
, XCAR (tail
))))
1968 Fsetcar (XCDR (tail
), val
);
1975 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1979 Fsetcdr (XCDR (prev
), newcell
);
1983 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1984 doc
: /* Return t if the two args are the same Lisp object.
1985 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1986 (Lisp_Object obj1
, Lisp_Object obj2
)
1989 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1991 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1994 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1995 doc
: /* Return t if two Lisp objects have similar structure and contents.
1996 They must have the same data type.
1997 Conses are compared by comparing the cars and the cdrs.
1998 Vectors and strings are compared element by element.
1999 Numbers are compared by value, but integers cannot equal floats.
2000 (Use `=' if you want integers and floats to be able to be equal.)
2001 Symbols must match exactly. */)
2002 (register Lisp_Object o1
, Lisp_Object o2
)
2004 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2007 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2008 doc
: /* Return t if two Lisp objects have similar structure and contents.
2009 This is like `equal' except that it compares the text properties
2010 of strings. (`equal' ignores text properties.) */)
2011 (register Lisp_Object o1
, Lisp_Object o2
)
2013 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2016 /* DEPTH is current depth of recursion. Signal an error if it
2018 PROPS, if non-nil, means compare string text properties too. */
2021 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2024 error ("Stack overflow in equal");
2030 if (XTYPE (o1
) != XTYPE (o2
))
2039 d1
= extract_float (o1
);
2040 d2
= extract_float (o2
);
2041 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2042 though they are not =. */
2043 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2047 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2054 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2058 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2060 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2063 o1
= XOVERLAY (o1
)->plist
;
2064 o2
= XOVERLAY (o2
)->plist
;
2069 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2070 && (XMARKER (o1
)->buffer
== 0
2071 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2075 case Lisp_Vectorlike
:
2078 EMACS_INT size
= ASIZE (o1
);
2079 /* Pseudovectors have the type encoded in the size field, so this test
2080 actually checks that the objects have the same type as well as the
2082 if (ASIZE (o2
) != size
)
2084 /* Boolvectors are compared much like strings. */
2085 if (BOOL_VECTOR_P (o1
))
2087 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2089 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2090 ((XBOOL_VECTOR (o1
)->size
2091 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2092 / BOOL_VECTOR_BITS_PER_CHAR
)))
2096 if (WINDOW_CONFIGURATIONP (o1
))
2097 return compare_window_configurations (o1
, o2
, 0);
2099 /* Aside from them, only true vectors, char-tables, compiled
2100 functions, and fonts (font-spec, font-entity, font-object)
2101 are sensible to compare, so eliminate the others now. */
2102 if (size
& PSEUDOVECTOR_FLAG
)
2104 if (!(size
& (PVEC_COMPILED
2105 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2107 size
&= PSEUDOVECTOR_SIZE_MASK
;
2109 for (i
= 0; i
< size
; i
++)
2114 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2122 if (SCHARS (o1
) != SCHARS (o2
))
2124 if (SBYTES (o1
) != SBYTES (o2
))
2126 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2128 if (props
&& !compare_string_intervals (o1
, o2
))
2140 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2141 doc
: /* Store each element of ARRAY with ITEM.
2142 ARRAY is a vector, string, char-table, or bool-vector. */)
2143 (Lisp_Object array
, Lisp_Object item
)
2145 register EMACS_INT size
, idx
;
2147 if (VECTORP (array
))
2149 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2150 size
= ASIZE (array
);
2151 for (idx
= 0; idx
< size
; idx
++)
2154 else if (CHAR_TABLE_P (array
))
2158 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2159 XCHAR_TABLE (array
)->contents
[i
] = item
;
2160 XCHAR_TABLE (array
)->defalt
= item
;
2162 else if (STRINGP (array
))
2164 register unsigned char *p
= SDATA (array
);
2166 CHECK_CHARACTER (item
);
2167 charval
= XFASTINT (item
);
2168 size
= SCHARS (array
);
2169 if (STRING_MULTIBYTE (array
))
2171 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2172 int len
= CHAR_STRING (charval
, str
);
2173 EMACS_INT size_byte
= SBYTES (array
);
2175 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2176 || SCHARS (array
) * len
!= size_byte
)
2177 error ("Attempt to change byte length of a string");
2178 for (idx
= 0; idx
< size_byte
; idx
++)
2179 *p
++ = str
[idx
% len
];
2182 for (idx
= 0; idx
< size
; idx
++)
2185 else if (BOOL_VECTOR_P (array
))
2187 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2188 EMACS_INT size_in_chars
;
2189 size
= XBOOL_VECTOR (array
)->size
;
2191 = ((size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2192 / BOOL_VECTOR_BITS_PER_CHAR
);
2196 memset (p
, ! NILP (item
) ? -1 : 0, size_in_chars
);
2198 /* Clear any extraneous bits in the last byte. */
2199 p
[size_in_chars
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2203 wrong_type_argument (Qarrayp
, array
);
2207 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2209 doc
: /* Clear the contents of STRING.
2210 This makes STRING unibyte and may change its length. */)
2211 (Lisp_Object string
)
2214 CHECK_STRING (string
);
2215 len
= SBYTES (string
);
2216 memset (SDATA (string
), 0, len
);
2217 STRING_SET_CHARS (string
, len
);
2218 STRING_SET_UNIBYTE (string
);
2224 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2226 Lisp_Object args
[2];
2229 return Fnconc (2, args
);
2232 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2233 doc
: /* Concatenate any number of lists by altering them.
2234 Only the last argument is not altered, and need not be a list.
2235 usage: (nconc &rest LISTS) */)
2236 (ptrdiff_t nargs
, Lisp_Object
*args
)
2239 register Lisp_Object tail
, tem
, val
;
2243 for (argnum
= 0; argnum
< nargs
; argnum
++)
2246 if (NILP (tem
)) continue;
2251 if (argnum
+ 1 == nargs
) break;
2253 CHECK_LIST_CONS (tem
, tem
);
2262 tem
= args
[argnum
+ 1];
2263 Fsetcdr (tail
, tem
);
2265 args
[argnum
+ 1] = tail
;
2271 /* This is the guts of all mapping functions.
2272 Apply FN to each element of SEQ, one by one,
2273 storing the results into elements of VALS, a C vector of Lisp_Objects.
2274 LENI is the length of VALS, which should also be the length of SEQ. */
2277 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2279 register Lisp_Object tail
;
2281 register EMACS_INT i
;
2282 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2286 /* Don't let vals contain any garbage when GC happens. */
2287 for (i
= 0; i
< leni
; i
++)
2290 GCPRO3 (dummy
, fn
, seq
);
2292 gcpro1
.nvars
= leni
;
2296 /* We need not explicitly protect `tail' because it is used only on lists, and
2297 1) lists are not relocated and 2) the list is marked via `seq' so will not
2300 if (VECTORP (seq
) || COMPILEDP (seq
))
2302 for (i
= 0; i
< leni
; i
++)
2304 dummy
= call1 (fn
, AREF (seq
, i
));
2309 else if (BOOL_VECTOR_P (seq
))
2311 for (i
= 0; i
< leni
; i
++)
2314 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2315 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2316 dummy
= call1 (fn
, dummy
);
2321 else if (STRINGP (seq
))
2325 for (i
= 0, i_byte
= 0; i
< leni
;)
2328 EMACS_INT i_before
= i
;
2330 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2331 XSETFASTINT (dummy
, c
);
2332 dummy
= call1 (fn
, dummy
);
2334 vals
[i_before
] = dummy
;
2337 else /* Must be a list, since Flength did not get an error */
2340 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2342 dummy
= call1 (fn
, XCAR (tail
));
2352 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2353 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2354 In between each pair of results, stick in SEPARATOR. Thus, " " as
2355 SEPARATOR results in spaces between the values returned by FUNCTION.
2356 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2357 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2360 register EMACS_INT leni
;
2362 register Lisp_Object
*args
;
2363 struct gcpro gcpro1
;
2367 len
= Flength (sequence
);
2368 if (CHAR_TABLE_P (sequence
))
2369 wrong_type_argument (Qlistp
, sequence
);
2371 nargs
= leni
+ leni
- 1;
2372 if (nargs
< 0) return empty_unibyte_string
;
2374 SAFE_ALLOCA_LISP (args
, nargs
);
2377 mapcar1 (leni
, args
, function
, sequence
);
2380 for (i
= leni
- 1; i
> 0; i
--)
2381 args
[i
+ i
] = args
[i
];
2383 for (i
= 1; i
< nargs
; i
+= 2)
2384 args
[i
] = separator
;
2386 ret
= Fconcat (nargs
, args
);
2392 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2393 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2394 The result is a list just as long as SEQUENCE.
2395 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2396 (Lisp_Object function
, Lisp_Object sequence
)
2398 register Lisp_Object len
;
2399 register EMACS_INT leni
;
2400 register Lisp_Object
*args
;
2404 len
= Flength (sequence
);
2405 if (CHAR_TABLE_P (sequence
))
2406 wrong_type_argument (Qlistp
, sequence
);
2407 leni
= XFASTINT (len
);
2409 SAFE_ALLOCA_LISP (args
, leni
);
2411 mapcar1 (leni
, args
, function
, sequence
);
2413 ret
= Flist (leni
, args
);
2419 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2420 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2421 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2422 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2423 (Lisp_Object function
, Lisp_Object sequence
)
2425 register EMACS_INT leni
;
2427 leni
= XFASTINT (Flength (sequence
));
2428 if (CHAR_TABLE_P (sequence
))
2429 wrong_type_argument (Qlistp
, sequence
);
2430 mapcar1 (leni
, 0, function
, sequence
);
2435 /* This is how C code calls `yes-or-no-p' and allows the user
2438 Anything that calls this function must protect from GC! */
2441 do_yes_or_no_p (Lisp_Object prompt
)
2443 return call1 (intern ("yes-or-no-p"), prompt
);
2446 /* Anything that calls this function must protect from GC! */
2448 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2449 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2450 PROMPT is the string to display to ask the question. It should end in
2451 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2453 The user must confirm the answer with RET, and can edit it until it
2456 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2457 is nil, and `use-dialog-box' is non-nil. */)
2458 (Lisp_Object prompt
)
2460 register Lisp_Object ans
;
2461 Lisp_Object args
[2];
2462 struct gcpro gcpro1
;
2464 CHECK_STRING (prompt
);
2467 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2468 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2472 Lisp_Object pane
, menu
, obj
;
2473 redisplay_preserve_echo_area (4);
2474 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2475 Fcons (Fcons (build_string ("No"), Qnil
),
2478 menu
= Fcons (prompt
, pane
);
2479 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2483 #endif /* HAVE_MENUS */
2486 args
[1] = build_string ("(yes or no) ");
2487 prompt
= Fconcat (2, args
);
2493 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2494 Qyes_or_no_p_history
, Qnil
,
2496 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2501 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2509 message ("Please answer yes or no.");
2510 Fsleep_for (make_number (2), Qnil
);
2514 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2515 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2517 Each of the three load averages is multiplied by 100, then converted
2520 When USE-FLOATS is non-nil, floats will be used instead of integers.
2521 These floats are not multiplied by 100.
2523 If the 5-minute or 15-minute load averages are not available, return a
2524 shortened list, containing only those averages which are available.
2526 An error is thrown if the load average can't be obtained. In some
2527 cases making it work would require Emacs being installed setuid or
2528 setgid so that it can read kernel information, and that usually isn't
2530 (Lisp_Object use_floats
)
2533 int loads
= getloadavg (load_ave
, 3);
2534 Lisp_Object ret
= Qnil
;
2537 error ("load-average not implemented for this operating system");
2541 Lisp_Object load
= (NILP (use_floats
)
2542 ? make_number (100.0 * load_ave
[loads
])
2543 : make_float (load_ave
[loads
]));
2544 ret
= Fcons (load
, ret
);
2550 static Lisp_Object Qsubfeatures
;
2552 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2553 doc
: /* Return t if FEATURE is present in this Emacs.
2555 Use this to conditionalize execution of lisp code based on the
2556 presence or absence of Emacs or environment extensions.
2557 Use `provide' to declare that a feature is available. This function
2558 looks at the value of the variable `features'. The optional argument
2559 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2560 (Lisp_Object feature
, Lisp_Object subfeature
)
2562 register Lisp_Object tem
;
2563 CHECK_SYMBOL (feature
);
2564 tem
= Fmemq (feature
, Vfeatures
);
2565 if (!NILP (tem
) && !NILP (subfeature
))
2566 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2567 return (NILP (tem
)) ? Qnil
: Qt
;
2570 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2571 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2572 The optional argument SUBFEATURES should be a list of symbols listing
2573 particular subfeatures supported in this version of FEATURE. */)
2574 (Lisp_Object feature
, Lisp_Object subfeatures
)
2576 register Lisp_Object tem
;
2577 CHECK_SYMBOL (feature
);
2578 CHECK_LIST (subfeatures
);
2579 if (!NILP (Vautoload_queue
))
2580 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2582 tem
= Fmemq (feature
, Vfeatures
);
2584 Vfeatures
= Fcons (feature
, Vfeatures
);
2585 if (!NILP (subfeatures
))
2586 Fput (feature
, Qsubfeatures
, subfeatures
);
2587 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2589 /* Run any load-hooks for this file. */
2590 tem
= Fassq (feature
, Vafter_load_alist
);
2592 Fprogn (XCDR (tem
));
2597 /* `require' and its subroutines. */
2599 /* List of features currently being require'd, innermost first. */
2601 static Lisp_Object require_nesting_list
;
2604 require_unwind (Lisp_Object old_value
)
2606 return require_nesting_list
= old_value
;
2609 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2610 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2611 If FEATURE is not a member of the list `features', then the feature
2612 is not loaded; so load the file FILENAME.
2613 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2614 and `load' will try to load this name appended with the suffix `.elc' or
2615 `.el', in that order. The name without appended suffix will not be used.
2616 If the optional third argument NOERROR is non-nil,
2617 then return nil if the file is not found instead of signaling an error.
2618 Normally the return value is FEATURE.
2619 The normal messages at start and end of loading FILENAME are suppressed. */)
2620 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2622 register Lisp_Object tem
;
2623 struct gcpro gcpro1
, gcpro2
;
2624 int from_file
= load_in_progress
;
2626 CHECK_SYMBOL (feature
);
2628 /* Record the presence of `require' in this file
2629 even if the feature specified is already loaded.
2630 But not more than once in any file,
2631 and not when we aren't loading or reading from a file. */
2633 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2634 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2639 tem
= Fcons (Qrequire
, feature
);
2640 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2641 LOADHIST_ATTACH (tem
);
2643 tem
= Fmemq (feature
, Vfeatures
);
2647 int count
= SPECPDL_INDEX ();
2650 /* This is to make sure that loadup.el gives a clear picture
2651 of what files are preloaded and when. */
2652 if (! NILP (Vpurify_flag
))
2653 error ("(require %s) while preparing to dump",
2654 SDATA (SYMBOL_NAME (feature
)));
2656 /* A certain amount of recursive `require' is legitimate,
2657 but if we require the same feature recursively 3 times,
2659 tem
= require_nesting_list
;
2660 while (! NILP (tem
))
2662 if (! NILP (Fequal (feature
, XCAR (tem
))))
2667 error ("Recursive `require' for feature `%s'",
2668 SDATA (SYMBOL_NAME (feature
)));
2670 /* Update the list for any nested `require's that occur. */
2671 record_unwind_protect (require_unwind
, require_nesting_list
);
2672 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2674 /* Value saved here is to be restored into Vautoload_queue */
2675 record_unwind_protect (un_autoload
, Vautoload_queue
);
2676 Vautoload_queue
= Qt
;
2678 /* Load the file. */
2679 GCPRO2 (feature
, filename
);
2680 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2681 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2684 /* If load failed entirely, return nil. */
2686 return unbind_to (count
, Qnil
);
2688 tem
= Fmemq (feature
, Vfeatures
);
2690 error ("Required feature `%s' was not provided",
2691 SDATA (SYMBOL_NAME (feature
)));
2693 /* Once loading finishes, don't undo it. */
2694 Vautoload_queue
= Qt
;
2695 feature
= unbind_to (count
, feature
);
2701 /* Primitives for work of the "widget" library.
2702 In an ideal world, this section would not have been necessary.
2703 However, lisp function calls being as slow as they are, it turns
2704 out that some functions in the widget library (wid-edit.el) are the
2705 bottleneck of Widget operation. Here is their translation to C,
2706 for the sole reason of efficiency. */
2708 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2709 doc
: /* Return non-nil if PLIST has the property PROP.
2710 PLIST is a property list, which is a list of the form
2711 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2712 Unlike `plist-get', this allows you to distinguish between a missing
2713 property and a property with the value nil.
2714 The value is actually the tail of PLIST whose car is PROP. */)
2715 (Lisp_Object plist
, Lisp_Object prop
)
2717 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2720 plist
= XCDR (plist
);
2721 plist
= CDR (plist
);
2726 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2727 doc
: /* In WIDGET, set PROPERTY to VALUE.
2728 The value can later be retrieved with `widget-get'. */)
2729 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2731 CHECK_CONS (widget
);
2732 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2736 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2737 doc
: /* In WIDGET, get the value of PROPERTY.
2738 The value could either be specified when the widget was created, or
2739 later with `widget-put'. */)
2740 (Lisp_Object widget
, Lisp_Object property
)
2748 CHECK_CONS (widget
);
2749 tmp
= Fplist_member (XCDR (widget
), property
);
2755 tmp
= XCAR (widget
);
2758 widget
= Fget (tmp
, Qwidget_type
);
2762 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2763 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2764 ARGS are passed as extra arguments to the function.
2765 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2766 (ptrdiff_t nargs
, Lisp_Object
*args
)
2768 /* This function can GC. */
2769 Lisp_Object newargs
[3];
2770 struct gcpro gcpro1
, gcpro2
;
2773 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2774 newargs
[1] = args
[0];
2775 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2776 GCPRO2 (newargs
[0], newargs
[2]);
2777 result
= Fapply (3, newargs
);
2782 #ifdef HAVE_LANGINFO_CODESET
2783 #include <langinfo.h>
2786 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2787 doc
: /* Access locale data ITEM for the current C locale, if available.
2788 ITEM should be one of the following:
2790 `codeset', returning the character set as a string (locale item CODESET);
2792 `days', returning a 7-element vector of day names (locale items DAY_n);
2794 `months', returning a 12-element vector of month names (locale items MON_n);
2796 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2797 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2799 If the system can't provide such information through a call to
2800 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2802 See also Info node `(libc)Locales'.
2804 The data read from the system are decoded using `locale-coding-system'. */)
2808 #ifdef HAVE_LANGINFO_CODESET
2810 if (EQ (item
, Qcodeset
))
2812 str
= nl_langinfo (CODESET
);
2813 return build_string (str
);
2816 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2818 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2819 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2821 struct gcpro gcpro1
;
2823 synchronize_system_time_locale ();
2824 for (i
= 0; i
< 7; i
++)
2826 str
= nl_langinfo (days
[i
]);
2827 val
= make_unibyte_string (str
, strlen (str
));
2828 /* Fixme: Is this coding system necessarily right, even if
2829 it is consistent with CODESET? If not, what to do? */
2830 Faset (v
, make_number (i
),
2831 code_convert_string_norecord (val
, Vlocale_coding_system
,
2839 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2841 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2842 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2843 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2845 struct gcpro gcpro1
;
2847 synchronize_system_time_locale ();
2848 for (i
= 0; i
< 12; i
++)
2850 str
= nl_langinfo (months
[i
]);
2851 val
= make_unibyte_string (str
, strlen (str
));
2852 Faset (v
, make_number (i
),
2853 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2859 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2860 but is in the locale files. This could be used by ps-print. */
2862 else if (EQ (item
, Qpaper
))
2864 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2865 make_number (nl_langinfo (PAPER_HEIGHT
)));
2867 #endif /* PAPER_WIDTH */
2868 #endif /* HAVE_LANGINFO_CODESET*/
2872 /* base64 encode/decode functions (RFC 2045).
2873 Based on code from GNU recode. */
2875 #define MIME_LINE_LENGTH 76
2877 #define IS_ASCII(Character) \
2879 #define IS_BASE64(Character) \
2880 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2881 #define IS_BASE64_IGNORABLE(Character) \
2882 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2883 || (Character) == '\f' || (Character) == '\r')
2885 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2886 character or return retval if there are no characters left to
2888 #define READ_QUADRUPLET_BYTE(retval) \
2893 if (nchars_return) \
2894 *nchars_return = nchars; \
2899 while (IS_BASE64_IGNORABLE (c))
2901 /* Table of characters coding the 64 values. */
2902 static const char base64_value_to_char
[64] =
2904 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2905 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2906 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2907 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2908 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2909 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2910 '8', '9', '+', '/' /* 60-63 */
2913 /* Table of base64 values for first 128 characters. */
2914 static const short base64_char_to_value
[128] =
2916 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2917 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2918 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2920 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2921 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2922 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2923 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2924 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2925 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2926 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2927 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2928 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2931 /* The following diagram shows the logical steps by which three octets
2932 get transformed into four base64 characters.
2934 .--------. .--------. .--------.
2935 |aaaaaabb| |bbbbcccc| |ccdddddd|
2936 `--------' `--------' `--------'
2938 .--------+--------+--------+--------.
2939 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2940 `--------+--------+--------+--------'
2942 .--------+--------+--------+--------.
2943 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2944 `--------+--------+--------+--------'
2946 The octets are divided into 6 bit chunks, which are then encoded into
2947 base64 characters. */
2950 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2951 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2954 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2956 doc
: /* Base64-encode the region between BEG and END.
2957 Return the length of the encoded text.
2958 Optional third argument NO-LINE-BREAK means do not break long lines
2959 into shorter lines. */)
2960 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2963 EMACS_INT allength
, length
;
2964 EMACS_INT ibeg
, iend
, encoded_length
;
2965 EMACS_INT old_pos
= PT
;
2968 validate_region (&beg
, &end
);
2970 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2971 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2972 move_gap_both (XFASTINT (beg
), ibeg
);
2974 /* We need to allocate enough room for encoding the text.
2975 We need 33 1/3% more space, plus a newline every 76
2976 characters, and then we round up. */
2977 length
= iend
- ibeg
;
2978 allength
= length
+ length
/3 + 1;
2979 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2981 SAFE_ALLOCA (encoded
, char *, allength
);
2982 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2983 encoded
, length
, NILP (no_line_break
),
2984 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2985 if (encoded_length
> allength
)
2988 if (encoded_length
< 0)
2990 /* The encoding wasn't possible. */
2992 error ("Multibyte character in data for base64 encoding");
2995 /* Now we have encoded the region, so we insert the new contents
2996 and delete the old. (Insert first in order to preserve markers.) */
2997 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2998 insert (encoded
, encoded_length
);
3000 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3002 /* If point was outside of the region, restore it exactly; else just
3003 move to the beginning of the region. */
3004 if (old_pos
>= XFASTINT (end
))
3005 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3006 else if (old_pos
> XFASTINT (beg
))
3007 old_pos
= XFASTINT (beg
);
3010 /* We return the length of the encoded text. */
3011 return make_number (encoded_length
);
3014 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3016 doc
: /* Base64-encode STRING and return the result.
3017 Optional second argument NO-LINE-BREAK means do not break long lines
3018 into shorter lines. */)
3019 (Lisp_Object string
, Lisp_Object no_line_break
)
3021 EMACS_INT allength
, length
, encoded_length
;
3023 Lisp_Object encoded_string
;
3026 CHECK_STRING (string
);
3028 /* We need to allocate enough room for encoding the text.
3029 We need 33 1/3% more space, plus a newline every 76
3030 characters, and then we round up. */
3031 length
= SBYTES (string
);
3032 allength
= length
+ length
/3 + 1;
3033 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3035 /* We need to allocate enough room for decoding the text. */
3036 SAFE_ALLOCA (encoded
, char *, allength
);
3038 encoded_length
= base64_encode_1 (SSDATA (string
),
3039 encoded
, length
, NILP (no_line_break
),
3040 STRING_MULTIBYTE (string
));
3041 if (encoded_length
> allength
)
3044 if (encoded_length
< 0)
3046 /* The encoding wasn't possible. */
3048 error ("Multibyte character in data for base64 encoding");
3051 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3054 return encoded_string
;
3058 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3059 int line_break
, int multibyte
)
3072 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3073 if (CHAR_BYTE8_P (c
))
3074 c
= CHAR_TO_BYTE8 (c
);
3082 /* Wrap line every 76 characters. */
3086 if (counter
< MIME_LINE_LENGTH
/ 4)
3095 /* Process first byte of a triplet. */
3097 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3098 value
= (0x03 & c
) << 4;
3100 /* Process second byte of a triplet. */
3104 *e
++ = base64_value_to_char
[value
];
3112 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3113 if (CHAR_BYTE8_P (c
))
3114 c
= CHAR_TO_BYTE8 (c
);
3122 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3123 value
= (0x0f & c
) << 2;
3125 /* Process third byte of a triplet. */
3129 *e
++ = base64_value_to_char
[value
];
3136 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3137 if (CHAR_BYTE8_P (c
))
3138 c
= CHAR_TO_BYTE8 (c
);
3146 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3147 *e
++ = base64_value_to_char
[0x3f & c
];
3154 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3156 doc
: /* Base64-decode the region between BEG and END.
3157 Return the length of the decoded text.
3158 If the region can't be decoded, signal an error and don't modify the buffer. */)
3159 (Lisp_Object beg
, Lisp_Object end
)
3161 EMACS_INT ibeg
, iend
, length
, allength
;
3163 EMACS_INT old_pos
= PT
;
3164 EMACS_INT decoded_length
;
3165 EMACS_INT inserted_chars
;
3166 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3169 validate_region (&beg
, &end
);
3171 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3172 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3174 length
= iend
- ibeg
;
3176 /* We need to allocate enough room for decoding the text. If we are
3177 working on a multibyte buffer, each decoded code may occupy at
3179 allength
= multibyte
? length
* 2 : length
;
3180 SAFE_ALLOCA (decoded
, char *, allength
);
3182 move_gap_both (XFASTINT (beg
), ibeg
);
3183 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3185 multibyte
, &inserted_chars
);
3186 if (decoded_length
> allength
)
3189 if (decoded_length
< 0)
3191 /* The decoding wasn't possible. */
3193 error ("Invalid base64 data");
3196 /* Now we have decoded the region, so we insert the new contents
3197 and delete the old. (Insert first in order to preserve markers.) */
3198 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3199 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3202 /* Delete the original text. */
3203 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3204 iend
+ decoded_length
, 1);
3206 /* If point was outside of the region, restore it exactly; else just
3207 move to the beginning of the region. */
3208 if (old_pos
>= XFASTINT (end
))
3209 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3210 else if (old_pos
> XFASTINT (beg
))
3211 old_pos
= XFASTINT (beg
);
3212 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3214 return make_number (inserted_chars
);
3217 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3219 doc
: /* Base64-decode STRING and return the result. */)
3220 (Lisp_Object string
)
3223 EMACS_INT length
, decoded_length
;
3224 Lisp_Object decoded_string
;
3227 CHECK_STRING (string
);
3229 length
= SBYTES (string
);
3230 /* We need to allocate enough room for decoding the text. */
3231 SAFE_ALLOCA (decoded
, char *, length
);
3233 /* The decoded result should be unibyte. */
3234 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3236 if (decoded_length
> length
)
3238 else if (decoded_length
>= 0)
3239 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3241 decoded_string
= Qnil
;
3244 if (!STRINGP (decoded_string
))
3245 error ("Invalid base64 data");
3247 return decoded_string
;
3250 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3251 MULTIBYTE is nonzero, the decoded result should be in multibyte
3252 form. If NCHARS_RETRUN is not NULL, store the number of produced
3253 characters in *NCHARS_RETURN. */
3256 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3257 int multibyte
, EMACS_INT
*nchars_return
)
3259 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3262 unsigned long value
;
3263 EMACS_INT nchars
= 0;
3267 /* Process first byte of a quadruplet. */
3269 READ_QUADRUPLET_BYTE (e
-to
);
3273 value
= base64_char_to_value
[c
] << 18;
3275 /* Process second byte of a quadruplet. */
3277 READ_QUADRUPLET_BYTE (-1);
3281 value
|= base64_char_to_value
[c
] << 12;
3283 c
= (unsigned char) (value
>> 16);
3284 if (multibyte
&& c
>= 128)
3285 e
+= BYTE8_STRING (c
, e
);
3290 /* Process third byte of a quadruplet. */
3292 READ_QUADRUPLET_BYTE (-1);
3296 READ_QUADRUPLET_BYTE (-1);
3305 value
|= base64_char_to_value
[c
] << 6;
3307 c
= (unsigned char) (0xff & value
>> 8);
3308 if (multibyte
&& c
>= 128)
3309 e
+= BYTE8_STRING (c
, e
);
3314 /* Process fourth byte of a quadruplet. */
3316 READ_QUADRUPLET_BYTE (-1);
3323 value
|= base64_char_to_value
[c
];
3325 c
= (unsigned char) (0xff & value
);
3326 if (multibyte
&& c
>= 128)
3327 e
+= BYTE8_STRING (c
, e
);
3336 /***********************************************************************
3338 ***** Hash Tables *****
3340 ***********************************************************************/
3342 /* Implemented by gerd@gnu.org. This hash table implementation was
3343 inspired by CMUCL hash tables. */
3347 1. For small tables, association lists are probably faster than
3348 hash tables because they have lower overhead.
3350 For uses of hash tables where the O(1) behavior of table
3351 operations is not a requirement, it might therefore be a good idea
3352 not to hash. Instead, we could just do a linear search in the
3353 key_and_value vector of the hash table. This could be done
3354 if a `:linear-search t' argument is given to make-hash-table. */
3357 /* The list of all weak hash tables. Don't staticpro this one. */
3359 static struct Lisp_Hash_Table
*weak_hash_tables
;
3361 /* Various symbols. */
3363 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3364 Lisp_Object Qeq
, Qeql
, Qequal
;
3365 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3366 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3368 /* Function prototypes. */
3370 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3371 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3372 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3373 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3377 /***********************************************************************
3379 ***********************************************************************/
3381 /* If OBJ is a Lisp hash table, return a pointer to its struct
3382 Lisp_Hash_Table. Otherwise, signal an error. */
3384 static struct Lisp_Hash_Table
*
3385 check_hash_table (Lisp_Object obj
)
3387 CHECK_HASH_TABLE (obj
);
3388 return XHASH_TABLE (obj
);
3392 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3396 next_almost_prime (EMACS_INT n
)
3398 for (n
|= 1; ; n
+= 2)
3399 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3404 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3405 which USED[I] is non-zero. If found at index I in ARGS, set
3406 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3407 0. This function is used to extract a keyword/argument pair from
3408 a DEFUN parameter list. */
3411 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3415 for (i
= 1; i
< nargs
; i
++)
3416 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3427 /* Return a Lisp vector which has the same contents as VEC but has
3428 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3429 vector that are not copied from VEC are set to INIT. */
3432 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3434 struct Lisp_Vector
*v
;
3435 EMACS_INT i
, old_size
;
3437 xassert (VECTORP (vec
));
3438 old_size
= ASIZE (vec
);
3439 xassert (new_size
>= old_size
);
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
] = init
;
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 xassert ((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 xassert ((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 xassert ((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
);
3566 /* Create and initialize a new hash table.
3568 TEST specifies the test the hash table will use to compare keys.
3569 It must be either one of the predefined tests `eq', `eql' or
3570 `equal' or a symbol denoting a user-defined test named TEST with
3571 test and hash functions USER_TEST and USER_HASH.
3573 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3575 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3576 new size when it becomes full is computed by adding REHASH_SIZE to
3577 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3578 table's new size is computed by multiplying its old size with
3581 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3582 be resized when the ratio of (number of entries in the table) /
3583 (table size) is >= REHASH_THRESHOLD.
3585 WEAK specifies the weakness of the table. If non-nil, it must be
3586 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3589 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3590 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3591 Lisp_Object user_test
, Lisp_Object user_hash
)
3593 struct Lisp_Hash_Table
*h
;
3595 EMACS_INT index_size
, i
, sz
;
3598 /* Preconditions. */
3599 xassert (SYMBOLP (test
));
3600 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3601 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3602 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3603 xassert (FLOATP (rehash_threshold
)
3604 && 0 < XFLOAT_DATA (rehash_threshold
)
3605 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3607 if (XFASTINT (size
) == 0)
3608 size
= make_number (1);
3610 sz
= XFASTINT (size
);
3611 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3612 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3613 ? next_almost_prime (index_float
)
3614 : MOST_POSITIVE_FIXNUM
+ 1);
3615 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3616 error ("Hash table too large");
3618 /* Allocate a table and initialize it. */
3619 h
= allocate_hash_table ();
3621 /* Initialize hash table slots. */
3623 if (EQ (test
, Qeql
))
3625 h
->cmpfn
= cmpfn_eql
;
3626 h
->hashfn
= hashfn_eql
;
3628 else if (EQ (test
, Qeq
))
3631 h
->hashfn
= hashfn_eq
;
3633 else if (EQ (test
, Qequal
))
3635 h
->cmpfn
= cmpfn_equal
;
3636 h
->hashfn
= hashfn_equal
;
3640 h
->user_cmp_function
= user_test
;
3641 h
->user_hash_function
= user_hash
;
3642 h
->cmpfn
= cmpfn_user_defined
;
3643 h
->hashfn
= hashfn_user_defined
;
3647 h
->rehash_threshold
= rehash_threshold
;
3648 h
->rehash_size
= rehash_size
;
3650 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3651 h
->hash
= Fmake_vector (size
, Qnil
);
3652 h
->next
= Fmake_vector (size
, Qnil
);
3653 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3655 /* Set up the free list. */
3656 for (i
= 0; i
< sz
- 1; ++i
)
3657 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3658 h
->next_free
= make_number (0);
3660 XSET_HASH_TABLE (table
, h
);
3661 xassert (HASH_TABLE_P (table
));
3662 xassert (XHASH_TABLE (table
) == h
);
3664 /* Maybe add this hash table to the list of all weak hash tables. */
3666 h
->next_weak
= NULL
;
3669 h
->next_weak
= weak_hash_tables
;
3670 weak_hash_tables
= h
;
3677 /* Return a copy of hash table H1. Keys and values are not copied,
3678 only the table itself is. */
3681 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3684 struct Lisp_Hash_Table
*h2
;
3685 struct Lisp_Vector
*next
;
3687 h2
= allocate_hash_table ();
3688 next
= h2
->header
.next
.vector
;
3689 memcpy (h2
, h1
, sizeof *h2
);
3690 h2
->header
.next
.vector
= next
;
3691 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3692 h2
->hash
= Fcopy_sequence (h1
->hash
);
3693 h2
->next
= Fcopy_sequence (h1
->next
);
3694 h2
->index
= Fcopy_sequence (h1
->index
);
3695 XSET_HASH_TABLE (table
, h2
);
3697 /* Maybe add this hash table to the list of all weak hash tables. */
3698 if (!NILP (h2
->weak
))
3700 h2
->next_weak
= weak_hash_tables
;
3701 weak_hash_tables
= h2
;
3708 /* Resize hash table H if it's too full. If H cannot be resized
3709 because it's already too large, throw an error. */
3712 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3714 if (NILP (h
->next_free
))
3716 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3717 EMACS_INT i
, new_size
, index_size
;
3721 if (INTEGERP (h
->rehash_size
))
3722 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3725 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3726 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3728 new_size
= float_new_size
;
3729 if (new_size
<= old_size
)
3730 new_size
= old_size
+ 1;
3733 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3735 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3736 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3737 ? next_almost_prime (index_float
)
3738 : MOST_POSITIVE_FIXNUM
+ 1);
3739 nsize
= max (index_size
, 2 * new_size
);
3740 if (nsize
> MOST_POSITIVE_FIXNUM
)
3741 error ("Hash table too large to resize");
3743 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3744 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3745 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3746 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3748 /* Update the free list. Do it so that new entries are added at
3749 the end of the free list. This makes some operations like
3751 for (i
= old_size
; i
< new_size
- 1; ++i
)
3752 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3754 if (!NILP (h
->next_free
))
3756 Lisp_Object last
, next
;
3758 last
= h
->next_free
;
3759 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3763 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3766 XSETFASTINT (h
->next_free
, old_size
);
3769 for (i
= 0; i
< old_size
; ++i
)
3770 if (!NILP (HASH_HASH (h
, i
)))
3772 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3773 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3774 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3775 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3781 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3782 the hash code of KEY. Value is the index of the entry in H
3783 matching KEY, or -1 if not found. */
3786 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3788 EMACS_UINT hash_code
;
3789 EMACS_INT start_of_bucket
;
3792 hash_code
= h
->hashfn (h
, key
);
3796 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3797 idx
= HASH_INDEX (h
, start_of_bucket
);
3799 /* We need not gcpro idx since it's either an integer or nil. */
3802 EMACS_INT i
= XFASTINT (idx
);
3803 if (EQ (key
, HASH_KEY (h
, i
))
3805 && h
->cmpfn (h
, key
, hash_code
,
3806 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3808 idx
= HASH_NEXT (h
, i
);
3811 return NILP (idx
) ? -1 : XFASTINT (idx
);
3815 /* Put an entry into hash table H that associates KEY with VALUE.
3816 HASH is a previously computed hash code of KEY.
3817 Value is the index of the entry in H matching KEY. */
3820 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3823 EMACS_INT start_of_bucket
, i
;
3825 xassert ((hash
& ~INTMASK
) == 0);
3827 /* Increment count after resizing because resizing may fail. */
3828 maybe_resize_hash_table (h
);
3831 /* Store key/value in the key_and_value vector. */
3832 i
= XFASTINT (h
->next_free
);
3833 h
->next_free
= HASH_NEXT (h
, i
);
3834 HASH_KEY (h
, i
) = key
;
3835 HASH_VALUE (h
, i
) = value
;
3837 /* Remember its hash code. */
3838 HASH_HASH (h
, i
) = make_number (hash
);
3840 /* Add new entry to its collision chain. */
3841 start_of_bucket
= hash
% ASIZE (h
->index
);
3842 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3843 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3848 /* Remove the entry matching KEY from hash table H, if there is one. */
3851 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3853 EMACS_UINT hash_code
;
3854 EMACS_INT start_of_bucket
;
3855 Lisp_Object idx
, prev
;
3857 hash_code
= h
->hashfn (h
, key
);
3858 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3859 idx
= HASH_INDEX (h
, start_of_bucket
);
3862 /* We need not gcpro idx, prev since they're either integers or nil. */
3865 EMACS_INT i
= XFASTINT (idx
);
3867 if (EQ (key
, HASH_KEY (h
, i
))
3869 && h
->cmpfn (h
, key
, hash_code
,
3870 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3872 /* Take entry out of collision chain. */
3874 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3876 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3878 /* Clear slots in key_and_value and add the slots to
3880 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3881 HASH_NEXT (h
, i
) = h
->next_free
;
3882 h
->next_free
= make_number (i
);
3884 xassert (h
->count
>= 0);
3890 idx
= HASH_NEXT (h
, i
);
3896 /* Clear hash table H. */
3899 hash_clear (struct Lisp_Hash_Table
*h
)
3903 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3905 for (i
= 0; i
< size
; ++i
)
3907 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3908 HASH_KEY (h
, i
) = Qnil
;
3909 HASH_VALUE (h
, i
) = Qnil
;
3910 HASH_HASH (h
, i
) = Qnil
;
3913 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3914 ASET (h
->index
, i
, Qnil
);
3916 h
->next_free
= make_number (0);
3923 /************************************************************************
3925 ************************************************************************/
3928 init_weak_hash_tables (void)
3930 weak_hash_tables
= NULL
;
3933 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3934 entries from the table that don't survive the current GC.
3935 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3936 non-zero if anything was marked. */
3939 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3941 EMACS_INT bucket
, n
;
3944 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3947 for (bucket
= 0; bucket
< n
; ++bucket
)
3949 Lisp_Object idx
, next
, prev
;
3951 /* Follow collision chain, removing entries that
3952 don't survive this garbage collection. */
3954 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3956 EMACS_INT i
= XFASTINT (idx
);
3957 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3958 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3961 if (EQ (h
->weak
, Qkey
))
3962 remove_p
= !key_known_to_survive_p
;
3963 else if (EQ (h
->weak
, Qvalue
))
3964 remove_p
= !value_known_to_survive_p
;
3965 else if (EQ (h
->weak
, Qkey_or_value
))
3966 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3967 else if (EQ (h
->weak
, Qkey_and_value
))
3968 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3972 next
= HASH_NEXT (h
, i
);
3974 if (remove_entries_p
)
3978 /* Take out of collision chain. */
3980 HASH_INDEX (h
, bucket
) = next
;
3982 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3984 /* Add to free list. */
3985 HASH_NEXT (h
, i
) = h
->next_free
;
3988 /* Clear key, value, and hash. */
3989 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3990 HASH_HASH (h
, i
) = Qnil
;
4003 /* Make sure key and value survive. */
4004 if (!key_known_to_survive_p
)
4006 mark_object (HASH_KEY (h
, i
));
4010 if (!value_known_to_survive_p
)
4012 mark_object (HASH_VALUE (h
, i
));
4023 /* Remove elements from weak hash tables that don't survive the
4024 current garbage collection. Remove weak tables that don't survive
4025 from Vweak_hash_tables. Called from gc_sweep. */
4028 sweep_weak_hash_tables (void)
4030 struct Lisp_Hash_Table
*h
, *used
, *next
;
4033 /* Mark all keys and values that are in use. Keep on marking until
4034 there is no more change. This is necessary for cases like
4035 value-weak table A containing an entry X -> Y, where Y is used in a
4036 key-weak table B, Z -> Y. If B comes after A in the list of weak
4037 tables, X -> Y might be removed from A, although when looking at B
4038 one finds that it shouldn't. */
4042 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4044 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4045 marked
|= sweep_weak_table (h
, 0);
4050 /* Remove tables and entries that aren't used. */
4051 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4053 next
= h
->next_weak
;
4055 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4057 /* TABLE is marked as used. Sweep its contents. */
4059 sweep_weak_table (h
, 1);
4061 /* Add table to the list of used weak hash tables. */
4062 h
->next_weak
= used
;
4067 weak_hash_tables
= used
;
4072 /***********************************************************************
4073 Hash Code Computation
4074 ***********************************************************************/
4076 /* Maximum depth up to which to dive into Lisp structures. */
4078 #define SXHASH_MAX_DEPTH 3
4080 /* Maximum length up to which to take list and vector elements into
4083 #define SXHASH_MAX_LEN 7
4085 /* Combine two integers X and Y for hashing. The result might not fit
4086 into a Lisp integer. */
4088 #define SXHASH_COMBINE(X, Y) \
4089 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4092 /* Hash X, returning a value that fits into a Lisp integer. */
4093 #define SXHASH_REDUCE(X) \
4094 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4096 /* Return a hash for string PTR which has length LEN. The hash
4097 code returned is guaranteed to fit in a Lisp integer. */
4100 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4102 unsigned char *p
= ptr
;
4103 unsigned char *end
= p
+ len
;
4105 EMACS_UINT hash
= 0;
4112 hash
= SXHASH_COMBINE (hash
, c
);
4115 return SXHASH_REDUCE (hash
);
4118 /* Return a hash for the floating point value VAL. */
4121 sxhash_float (double val
)
4123 EMACS_UINT hash
= 0;
4125 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4126 + (sizeof val
% sizeof hash
!= 0))
4130 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4134 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4135 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4136 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4137 return SXHASH_REDUCE (hash
);
4140 /* Return a hash for list LIST. DEPTH is the current depth in the
4141 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4144 sxhash_list (Lisp_Object list
, int depth
)
4146 EMACS_UINT hash
= 0;
4149 if (depth
< SXHASH_MAX_DEPTH
)
4151 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4152 list
= XCDR (list
), ++i
)
4154 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4155 hash
= SXHASH_COMBINE (hash
, hash2
);
4160 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4161 hash
= SXHASH_COMBINE (hash
, hash2
);
4164 return SXHASH_REDUCE (hash
);
4168 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4169 the Lisp structure. */
4172 sxhash_vector (Lisp_Object vec
, int depth
)
4174 EMACS_UINT hash
= ASIZE (vec
);
4177 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4178 for (i
= 0; i
< n
; ++i
)
4180 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4181 hash
= SXHASH_COMBINE (hash
, hash2
);
4184 return SXHASH_REDUCE (hash
);
4187 /* Return a hash for bool-vector VECTOR. */
4190 sxhash_bool_vector (Lisp_Object vec
)
4192 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4195 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4196 for (i
= 0; i
< n
; ++i
)
4197 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4199 return SXHASH_REDUCE (hash
);
4203 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4204 structure. Value is an unsigned integer clipped to INTMASK. */
4207 sxhash (Lisp_Object obj
, int depth
)
4211 if (depth
> SXHASH_MAX_DEPTH
)
4214 switch (XTYPE (obj
))
4225 obj
= SYMBOL_NAME (obj
);
4229 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4232 /* This can be everything from a vector to an overlay. */
4233 case Lisp_Vectorlike
:
4235 /* According to the CL HyperSpec, two arrays are equal only if
4236 they are `eq', except for strings and bit-vectors. In
4237 Emacs, this works differently. We have to compare element
4239 hash
= sxhash_vector (obj
, depth
);
4240 else if (BOOL_VECTOR_P (obj
))
4241 hash
= sxhash_bool_vector (obj
);
4243 /* Others are `equal' if they are `eq', so let's take their
4249 hash
= sxhash_list (obj
, depth
);
4253 hash
= sxhash_float (XFLOAT_DATA (obj
));
4265 /***********************************************************************
4267 ***********************************************************************/
4270 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4271 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4274 EMACS_UINT hash
= sxhash (obj
, 0);
4275 return make_number (hash
);
4279 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4280 doc
: /* Create and return a new hash table.
4282 Arguments are specified as keyword/argument pairs. The following
4283 arguments are defined:
4285 :test TEST -- TEST must be a symbol that specifies how to compare
4286 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4287 `equal'. User-supplied test and hash functions can be specified via
4288 `define-hash-table-test'.
4290 :size SIZE -- A hint as to how many elements will be put in the table.
4293 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4294 fills up. If REHASH-SIZE is an integer, increase the size by that
4295 amount. If it is a float, it must be > 1.0, and the new size is the
4296 old size multiplied by that factor. Default is 1.5.
4298 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4299 Resize the hash table when the ratio (number of entries / table size)
4300 is greater than or equal to THRESHOLD. Default is 0.8.
4302 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4303 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4304 returned is a weak table. Key/value pairs are removed from a weak
4305 hash table when there are no non-weak references pointing to their
4306 key, value, one of key or value, or both key and value, depending on
4307 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4310 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4311 (ptrdiff_t nargs
, Lisp_Object
*args
)
4313 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4314 Lisp_Object user_test
, user_hash
;
4318 /* The vector `used' is used to keep track of arguments that
4319 have been consumed. */
4320 used
= (char *) alloca (nargs
* sizeof *used
);
4321 memset (used
, 0, nargs
* sizeof *used
);
4323 /* See if there's a `:test TEST' among the arguments. */
4324 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4325 test
= i
? args
[i
] : Qeql
;
4326 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4328 /* See if it is a user-defined test. */
4331 prop
= Fget (test
, Qhash_table_test
);
4332 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4333 signal_error ("Invalid hash table test", test
);
4334 user_test
= XCAR (prop
);
4335 user_hash
= XCAR (XCDR (prop
));
4338 user_test
= user_hash
= Qnil
;
4340 /* See if there's a `:size SIZE' argument. */
4341 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4342 size
= i
? args
[i
] : Qnil
;
4344 size
= make_number (DEFAULT_HASH_SIZE
);
4345 else if (!INTEGERP (size
) || XINT (size
) < 0)
4346 signal_error ("Invalid hash table size", size
);
4348 /* Look for `:rehash-size SIZE'. */
4349 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4350 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4351 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4352 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4353 signal_error ("Invalid hash table rehash size", rehash_size
);
4355 /* Look for `:rehash-threshold THRESHOLD'. */
4356 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4357 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4358 if (! (FLOATP (rehash_threshold
)
4359 && 0 < XFLOAT_DATA (rehash_threshold
)
4360 && XFLOAT_DATA (rehash_threshold
) <= 1))
4361 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4363 /* Look for `:weakness WEAK'. */
4364 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4365 weak
= i
? args
[i
] : Qnil
;
4367 weak
= Qkey_and_value
;
4370 && !EQ (weak
, Qvalue
)
4371 && !EQ (weak
, Qkey_or_value
)
4372 && !EQ (weak
, Qkey_and_value
))
4373 signal_error ("Invalid hash table weakness", weak
);
4375 /* Now, all args should have been used up, or there's a problem. */
4376 for (i
= 0; i
< nargs
; ++i
)
4378 signal_error ("Invalid argument list", args
[i
]);
4380 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4381 user_test
, user_hash
);
4385 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4386 doc
: /* Return a copy of hash table TABLE. */)
4389 return copy_hash_table (check_hash_table (table
));
4393 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4394 doc
: /* Return the number of elements in TABLE. */)
4397 return make_number (check_hash_table (table
)->count
);
4401 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4402 Shash_table_rehash_size
, 1, 1, 0,
4403 doc
: /* Return the current rehash size of TABLE. */)
4406 return check_hash_table (table
)->rehash_size
;
4410 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4411 Shash_table_rehash_threshold
, 1, 1, 0,
4412 doc
: /* Return the current rehash threshold of TABLE. */)
4415 return check_hash_table (table
)->rehash_threshold
;
4419 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4420 doc
: /* Return the size of TABLE.
4421 The size can be used as an argument to `make-hash-table' to create
4422 a hash table than can hold as many elements as TABLE holds
4423 without need for resizing. */)
4426 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4427 return make_number (HASH_TABLE_SIZE (h
));
4431 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4432 doc
: /* Return the test TABLE uses. */)
4435 return check_hash_table (table
)->test
;
4439 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4441 doc
: /* Return the weakness of TABLE. */)
4444 return check_hash_table (table
)->weak
;
4448 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4449 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4452 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4456 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4457 doc
: /* Clear hash table TABLE and return it. */)
4460 hash_clear (check_hash_table (table
));
4461 /* Be compatible with XEmacs. */
4466 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4467 doc
: /* Look up KEY in TABLE and return its associated value.
4468 If KEY is not found, return DFLT which defaults to nil. */)
4469 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4471 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4472 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4473 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4477 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4478 doc
: /* Associate KEY with VALUE in hash table TABLE.
4479 If KEY is already present in table, replace its current value with
4480 VALUE. In any case, return VALUE. */)
4481 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4483 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4487 i
= hash_lookup (h
, key
, &hash
);
4489 HASH_VALUE (h
, i
) = value
;
4491 hash_put (h
, key
, value
, hash
);
4497 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4498 doc
: /* Remove KEY from TABLE. */)
4499 (Lisp_Object key
, Lisp_Object table
)
4501 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4502 hash_remove_from_table (h
, key
);
4507 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4508 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4509 FUNCTION is called with two arguments, KEY and VALUE. */)
4510 (Lisp_Object function
, Lisp_Object table
)
4512 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4513 Lisp_Object args
[3];
4516 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4517 if (!NILP (HASH_HASH (h
, i
)))
4520 args
[1] = HASH_KEY (h
, i
);
4521 args
[2] = HASH_VALUE (h
, i
);
4529 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4530 Sdefine_hash_table_test
, 3, 3, 0,
4531 doc
: /* Define a new hash table test with name NAME, a symbol.
4533 In hash tables created with NAME specified as test, use TEST to
4534 compare keys, and HASH for computing hash codes of keys.
4536 TEST must be a function taking two arguments and returning non-nil if
4537 both arguments are the same. HASH must be a function taking one
4538 argument and return an integer that is the hash code of the argument.
4539 Hash code computation should use the whole value range of integers,
4540 including negative integers. */)
4541 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4543 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4548 /************************************************************************
4549 MD5, SHA-1, and SHA-2
4550 ************************************************************************/
4557 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4560 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4564 EMACS_INT size_byte
= 0;
4565 EMACS_INT start_char
= 0, end_char
= 0;
4566 EMACS_INT start_byte
= 0, end_byte
= 0;
4567 register EMACS_INT b
, e
;
4568 register struct buffer
*bp
;
4571 void *(*hash_func
) (const char *, size_t, void *);
4574 CHECK_SYMBOL (algorithm
);
4576 if (STRINGP (object
))
4578 if (NILP (coding_system
))
4580 /* Decide the coding-system to encode the data with. */
4582 if (STRING_MULTIBYTE (object
))
4583 /* use default, we can't guess correct value */
4584 coding_system
= preferred_coding_system ();
4586 coding_system
= Qraw_text
;
4589 if (NILP (Fcoding_system_p (coding_system
)))
4591 /* Invalid coding system. */
4593 if (!NILP (noerror
))
4594 coding_system
= Qraw_text
;
4596 xsignal1 (Qcoding_system_error
, coding_system
);
4599 if (STRING_MULTIBYTE (object
))
4600 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4602 size
= SCHARS (object
);
4603 size_byte
= SBYTES (object
);
4607 CHECK_NUMBER (start
);
4609 start_char
= XINT (start
);
4614 start_byte
= string_char_to_byte (object
, start_char
);
4620 end_byte
= size_byte
;
4626 end_char
= XINT (end
);
4631 end_byte
= string_char_to_byte (object
, end_char
);
4634 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4635 args_out_of_range_3 (object
, make_number (start_char
),
4636 make_number (end_char
));
4640 struct buffer
*prev
= current_buffer
;
4642 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4644 CHECK_BUFFER (object
);
4646 bp
= XBUFFER (object
);
4647 if (bp
!= current_buffer
)
4648 set_buffer_internal (bp
);
4654 CHECK_NUMBER_COERCE_MARKER (start
);
4662 CHECK_NUMBER_COERCE_MARKER (end
);
4667 temp
= b
, b
= e
, e
= temp
;
4669 if (!(BEGV
<= b
&& e
<= ZV
))
4670 args_out_of_range (start
, end
);
4672 if (NILP (coding_system
))
4674 /* Decide the coding-system to encode the data with.
4675 See fileio.c:Fwrite-region */
4677 if (!NILP (Vcoding_system_for_write
))
4678 coding_system
= Vcoding_system_for_write
;
4681 int force_raw_text
= 0;
4683 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4684 if (NILP (coding_system
)
4685 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4687 coding_system
= Qnil
;
4688 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4692 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4694 /* Check file-coding-system-alist. */
4695 Lisp_Object args
[4], val
;
4697 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4698 args
[3] = Fbuffer_file_name(object
);
4699 val
= Ffind_operation_coding_system (4, args
);
4700 if (CONSP (val
) && !NILP (XCDR (val
)))
4701 coding_system
= XCDR (val
);
4704 if (NILP (coding_system
)
4705 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4707 /* If we still have not decided a coding system, use the
4708 default value of buffer-file-coding-system. */
4709 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4713 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4714 /* Confirm that VAL can surely encode the current region. */
4715 coding_system
= call4 (Vselect_safe_coding_system_function
,
4716 make_number (b
), make_number (e
),
4717 coding_system
, Qnil
);
4720 coding_system
= Qraw_text
;
4723 if (NILP (Fcoding_system_p (coding_system
)))
4725 /* Invalid coding system. */
4727 if (!NILP (noerror
))
4728 coding_system
= Qraw_text
;
4730 xsignal1 (Qcoding_system_error
, coding_system
);
4734 object
= make_buffer_string (b
, e
, 0);
4735 if (prev
!= current_buffer
)
4736 set_buffer_internal (prev
);
4737 /* Discard the unwind protect for recovering the current
4741 if (STRING_MULTIBYTE (object
))
4742 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4745 if (EQ (algorithm
, Qmd5
))
4747 digest_size
= MD5_DIGEST_SIZE
;
4748 hash_func
= md5_buffer
;
4750 else if (EQ (algorithm
, Qsha1
))
4752 digest_size
= SHA1_DIGEST_SIZE
;
4753 hash_func
= sha1_buffer
;
4755 else if (EQ (algorithm
, Qsha224
))
4757 digest_size
= SHA224_DIGEST_SIZE
;
4758 hash_func
= sha224_buffer
;
4760 else if (EQ (algorithm
, Qsha256
))
4762 digest_size
= SHA256_DIGEST_SIZE
;
4763 hash_func
= sha256_buffer
;
4765 else if (EQ (algorithm
, Qsha384
))
4767 digest_size
= SHA384_DIGEST_SIZE
;
4768 hash_func
= sha384_buffer
;
4770 else if (EQ (algorithm
, Qsha512
))
4772 digest_size
= SHA512_DIGEST_SIZE
;
4773 hash_func
= sha512_buffer
;
4776 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4778 /* allocate 2 x digest_size so that it can be re-used to hold the
4780 digest
= make_uninit_string (digest_size
* 2);
4782 hash_func (SSDATA (object
) + start_byte
,
4783 SBYTES (object
) - (size_byte
- end_byte
),
4788 unsigned char *p
= SDATA (digest
);
4789 for (i
= digest_size
- 1; i
>= 0; i
--)
4791 static char const hexdigit
[16] = "0123456789abcdef";
4793 p
[2 * i
] = hexdigit
[p_i
>> 4];
4794 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4799 return make_unibyte_string (SSDATA (digest
), digest_size
);
4802 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4803 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4805 A message digest is a cryptographic checksum of a document, and the
4806 algorithm to calculate it is defined in RFC 1321.
4808 The two optional arguments START and END are character positions
4809 specifying for which part of OBJECT the message digest should be
4810 computed. If nil or omitted, the digest is computed for the whole
4813 The MD5 message digest is computed from the result of encoding the
4814 text in a coding system, not directly from the internal Emacs form of
4815 the text. The optional fourth argument CODING-SYSTEM specifies which
4816 coding system to encode the text with. It should be the same coding
4817 system that you used or will use when actually writing the text into a
4820 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4821 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4822 system would be chosen by default for writing this text into a file.
4824 If OBJECT is a string, the most preferred coding system (see the
4825 command `prefer-coding-system') is used.
4827 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4828 guesswork fails. Normally, an error is signaled in such case. */)
4829 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4831 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4834 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4835 doc
: /* Return the secure hash of an OBJECT.
4836 ALGORITHM is a symbol: md5, sha1, sha224, sha256, sha384 or sha512.
4837 OBJECT is either a string or a buffer.
4838 Optional arguments START and END are character positions specifying
4839 which portion of OBJECT for computing the hash. If BINARY is non-nil,
4840 return a string in binary form. */)
4841 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4843 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4849 DEFSYM (Qmd5
, "md5");
4850 DEFSYM (Qsha1
, "sha1");
4851 DEFSYM (Qsha224
, "sha224");
4852 DEFSYM (Qsha256
, "sha256");
4853 DEFSYM (Qsha384
, "sha384");
4854 DEFSYM (Qsha512
, "sha512");
4856 /* Hash table stuff. */
4857 DEFSYM (Qhash_table_p
, "hash-table-p");
4859 DEFSYM (Qeql
, "eql");
4860 DEFSYM (Qequal
, "equal");
4861 DEFSYM (QCtest
, ":test");
4862 DEFSYM (QCsize
, ":size");
4863 DEFSYM (QCrehash_size
, ":rehash-size");
4864 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4865 DEFSYM (QCweakness
, ":weakness");
4866 DEFSYM (Qkey
, "key");
4867 DEFSYM (Qvalue
, "value");
4868 DEFSYM (Qhash_table_test
, "hash-table-test");
4869 DEFSYM (Qkey_or_value
, "key-or-value");
4870 DEFSYM (Qkey_and_value
, "key-and-value");
4873 defsubr (&Smake_hash_table
);
4874 defsubr (&Scopy_hash_table
);
4875 defsubr (&Shash_table_count
);
4876 defsubr (&Shash_table_rehash_size
);
4877 defsubr (&Shash_table_rehash_threshold
);
4878 defsubr (&Shash_table_size
);
4879 defsubr (&Shash_table_test
);
4880 defsubr (&Shash_table_weakness
);
4881 defsubr (&Shash_table_p
);
4882 defsubr (&Sclrhash
);
4883 defsubr (&Sgethash
);
4884 defsubr (&Sputhash
);
4885 defsubr (&Sremhash
);
4886 defsubr (&Smaphash
);
4887 defsubr (&Sdefine_hash_table_test
);
4889 DEFSYM (Qstring_lessp
, "string-lessp");
4890 DEFSYM (Qprovide
, "provide");
4891 DEFSYM (Qrequire
, "require");
4892 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4893 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4894 DEFSYM (Qwidget_type
, "widget-type");
4896 staticpro (&string_char_byte_cache_string
);
4897 string_char_byte_cache_string
= Qnil
;
4899 require_nesting_list
= Qnil
;
4900 staticpro (&require_nesting_list
);
4902 Fset (Qyes_or_no_p_history
, Qnil
);
4904 DEFVAR_LISP ("features", Vfeatures
,
4905 doc
: /* A list of symbols which are the features of the executing Emacs.
4906 Used by `featurep' and `require', and altered by `provide'. */);
4907 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4908 DEFSYM (Qsubfeatures
, "subfeatures");
4910 #ifdef HAVE_LANGINFO_CODESET
4911 DEFSYM (Qcodeset
, "codeset");
4912 DEFSYM (Qdays
, "days");
4913 DEFSYM (Qmonths
, "months");
4914 DEFSYM (Qpaper
, "paper");
4915 #endif /* HAVE_LANGINFO_CODESET */
4917 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4918 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4919 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4920 invoked by mouse clicks and mouse menu items.
4922 On some platforms, file selection dialogs are also enabled if this is
4926 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4927 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4928 This applies to commands from menus and tool bar buttons even when
4929 they are initiated from the keyboard. If `use-dialog-box' is nil,
4930 that disables the use of a file dialog, regardless of the value of
4932 use_file_dialog
= 1;
4934 defsubr (&Sidentity
);
4937 defsubr (&Ssafe_length
);
4938 defsubr (&Sstring_bytes
);
4939 defsubr (&Sstring_equal
);
4940 defsubr (&Scompare_strings
);
4941 defsubr (&Sstring_lessp
);
4944 defsubr (&Svconcat
);
4945 defsubr (&Scopy_sequence
);
4946 defsubr (&Sstring_make_multibyte
);
4947 defsubr (&Sstring_make_unibyte
);
4948 defsubr (&Sstring_as_multibyte
);
4949 defsubr (&Sstring_as_unibyte
);
4950 defsubr (&Sstring_to_multibyte
);
4951 defsubr (&Sstring_to_unibyte
);
4952 defsubr (&Scopy_alist
);
4953 defsubr (&Ssubstring
);
4954 defsubr (&Ssubstring_no_properties
);
4967 defsubr (&Snreverse
);
4968 defsubr (&Sreverse
);
4970 defsubr (&Splist_get
);
4972 defsubr (&Splist_put
);
4974 defsubr (&Slax_plist_get
);
4975 defsubr (&Slax_plist_put
);
4978 defsubr (&Sequal_including_properties
);
4979 defsubr (&Sfillarray
);
4980 defsubr (&Sclear_string
);
4984 defsubr (&Smapconcat
);
4985 defsubr (&Syes_or_no_p
);
4986 defsubr (&Sload_average
);
4987 defsubr (&Sfeaturep
);
4988 defsubr (&Srequire
);
4989 defsubr (&Sprovide
);
4990 defsubr (&Splist_member
);
4991 defsubr (&Swidget_put
);
4992 defsubr (&Swidget_get
);
4993 defsubr (&Swidget_apply
);
4994 defsubr (&Sbase64_encode_region
);
4995 defsubr (&Sbase64_decode_region
);
4996 defsubr (&Sbase64_encode_string
);
4997 defsubr (&Sbase64_decode_string
);
4999 defsubr (&Ssecure_hash
);
5000 defsubr (&Slocale_info
);