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/>. */
28 #include "character.h"
33 #include "intervals.h"
36 #include "blockinput.h"
38 #if defined (HAVE_X_WINDOWS)
41 #endif /* HAVE_MENUS */
44 #define NULL ((POINTER_TYPE *)0)
47 Lisp_Object Qstring_lessp
;
48 static Lisp_Object Qprovide
, Qrequire
;
49 static Lisp_Object Qyes_or_no_p_history
;
50 Lisp_Object Qcursor_in_echo_area
;
51 static Lisp_Object Qwidget_type
;
52 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
54 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
60 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
61 doc
: /* Return the argument unchanged. */)
67 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
68 doc
: /* Return a pseudo-random number.
69 All integers representable in Lisp are equally likely.
70 On most systems, this is 29 bits' worth.
71 With positive integer LIMIT, return random number in interval [0,LIMIT).
72 With argument t, set the random number seed from the current time and pid.
73 Other values of LIMIT are ignored. */)
77 Lisp_Object lispy_val
;
78 EMACS_UINT denominator
;
81 seed_random (getpid () + time (NULL
));
82 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
84 /* Try to take our random number from the higher bits of VAL,
85 not the lower, since (says Gentzel) the low bits of `random'
86 are less random than the higher ones. We do this by using the
87 quotient rather than the remainder. At the high end of the RNG
88 it's possible to get a quotient larger than n; discarding
89 these values eliminates the bias that would otherwise appear
90 when using a large n. */
91 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
93 val
= get_random () / denominator
;
94 while (val
>= XFASTINT (limit
));
98 XSETINT (lispy_val
, val
);
102 /* Random data-structure functions */
104 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
105 doc
: /* Return the length of vector, list or string SEQUENCE.
106 A byte-code function object is also allowed.
107 If the string contains multibyte characters, this is not necessarily
108 the number of bytes in the string; it is the number of characters.
109 To get the number of bytes, use `string-bytes'. */)
110 (register Lisp_Object sequence
)
112 register Lisp_Object val
;
115 if (STRINGP (sequence
))
116 XSETFASTINT (val
, SCHARS (sequence
));
117 else if (VECTORP (sequence
))
118 XSETFASTINT (val
, ASIZE (sequence
));
119 else if (CHAR_TABLE_P (sequence
))
120 XSETFASTINT (val
, MAX_CHAR
);
121 else if (BOOL_VECTOR_P (sequence
))
122 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
123 else if (COMPILEDP (sequence
))
124 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
125 else if (CONSP (sequence
))
128 while (CONSP (sequence
))
130 sequence
= XCDR (sequence
);
133 if (!CONSP (sequence
))
136 sequence
= XCDR (sequence
);
141 CHECK_LIST_END (sequence
, sequence
);
143 val
= make_number (i
);
145 else if (NILP (sequence
))
146 XSETFASTINT (val
, 0);
148 wrong_type_argument (Qsequencep
, sequence
);
153 /* This does not check for quits. That is safe since it must terminate. */
155 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
156 doc
: /* Return the length of a list, but avoid error or infinite loop.
157 This function never gets an error. If LIST is not really a list,
158 it returns 0. If LIST is circular, it returns a finite value
159 which is at least the number of distinct elements. */)
162 Lisp_Object tail
, halftail
, length
;
165 /* halftail is used to detect circular lists. */
167 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
169 if (EQ (tail
, halftail
) && len
!= 0)
173 halftail
= XCDR (halftail
);
176 XSETINT (length
, len
);
180 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
181 doc
: /* Return the number of bytes in STRING.
182 If STRING is multibyte, this may be greater than the length of STRING. */)
185 CHECK_STRING (string
);
186 return make_number (SBYTES (string
));
189 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
190 doc
: /* Return t if two strings have identical contents.
191 Case is significant, but text properties are ignored.
192 Symbols are also allowed; their print names are used instead. */)
193 (register Lisp_Object s1
, Lisp_Object s2
)
196 s1
= SYMBOL_NAME (s1
);
198 s2
= SYMBOL_NAME (s2
);
202 if (SCHARS (s1
) != SCHARS (s2
)
203 || SBYTES (s1
) != SBYTES (s2
)
204 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
209 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
210 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
211 In string STR1, skip the first START1 characters and stop at END1.
212 In string STR2, skip the first START2 characters and stop at END2.
213 END1 and END2 default to the full lengths of the respective strings.
215 Case is significant in this comparison if IGNORE-CASE is nil.
216 Unibyte strings are converted to multibyte for comparison.
218 The value is t if the strings (or specified portions) match.
219 If string STR1 is less, the value is a negative number N;
220 - 1 - N is the number of characters that match at the beginning.
221 If string STR1 is greater, the value is a positive number N;
222 N - 1 is the number of characters that match at the beginning. */)
223 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
225 register EMACS_INT end1_char
, end2_char
;
226 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
231 start1
= make_number (0);
233 start2
= make_number (0);
234 CHECK_NATNUM (start1
);
235 CHECK_NATNUM (start2
);
244 i1_byte
= string_char_to_byte (str1
, i1
);
245 i2_byte
= string_char_to_byte (str2
, i2
);
247 end1_char
= SCHARS (str1
);
248 if (! NILP (end1
) && end1_char
> XINT (end1
))
249 end1_char
= XINT (end1
);
251 end2_char
= SCHARS (str2
);
252 if (! NILP (end2
) && end2_char
> XINT (end2
))
253 end2_char
= XINT (end2
);
255 while (i1
< end1_char
&& i2
< end2_char
)
257 /* When we find a mismatch, we must compare the
258 characters, not just the bytes. */
261 if (STRING_MULTIBYTE (str1
))
262 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
265 c1
= SREF (str1
, i1
++);
266 MAKE_CHAR_MULTIBYTE (c1
);
269 if (STRING_MULTIBYTE (str2
))
270 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
273 c2
= SREF (str2
, i2
++);
274 MAKE_CHAR_MULTIBYTE (c2
);
280 if (! NILP (ignore_case
))
284 tem
= Fupcase (make_number (c1
));
286 tem
= Fupcase (make_number (c2
));
293 /* Note that I1 has already been incremented
294 past the character that we are comparing;
295 hence we don't add or subtract 1 here. */
297 return make_number (- i1
+ XINT (start1
));
299 return make_number (i1
- XINT (start1
));
303 return make_number (i1
- XINT (start1
) + 1);
305 return make_number (- i1
+ XINT (start1
) - 1);
310 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
311 doc
: /* Return t if first arg string is less than second in lexicographic order.
313 Symbols are also allowed; their print names are used instead. */)
314 (register Lisp_Object s1
, Lisp_Object s2
)
316 register EMACS_INT end
;
317 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
320 s1
= SYMBOL_NAME (s1
);
322 s2
= SYMBOL_NAME (s2
);
326 i1
= i1_byte
= i2
= i2_byte
= 0;
329 if (end
> SCHARS (s2
))
334 /* When we find a mismatch, we must compare the
335 characters, not just the bytes. */
338 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
339 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
342 return c1
< c2
? Qt
: Qnil
;
344 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
347 static Lisp_Object
concat (size_t nargs
, Lisp_Object
*args
,
348 enum Lisp_Type target_type
, int last_special
);
352 concat2 (Lisp_Object s1
, Lisp_Object s2
)
357 return concat (2, args
, Lisp_String
, 0);
362 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
368 return concat (3, args
, Lisp_String
, 0);
371 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
372 doc
: /* Concatenate all the arguments and make the result a list.
373 The result is a list whose elements are the elements of all the arguments.
374 Each argument may be a list, vector or string.
375 The last argument is not copied, just used as the tail of the new list.
376 usage: (append &rest SEQUENCES) */)
377 (size_t nargs
, Lisp_Object
*args
)
379 return concat (nargs
, args
, Lisp_Cons
, 1);
382 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
383 doc
: /* Concatenate all the arguments and make the result a string.
384 The result is a string whose elements are the elements of all the arguments.
385 Each argument may be a string or a list or vector of characters (integers).
386 usage: (concat &rest SEQUENCES) */)
387 (size_t nargs
, Lisp_Object
*args
)
389 return concat (nargs
, args
, Lisp_String
, 0);
392 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
393 doc
: /* Concatenate all the arguments and make the result a vector.
394 The result is a vector whose elements are the elements of all the arguments.
395 Each argument may be a list, vector or string.
396 usage: (vconcat &rest SEQUENCES) */)
397 (size_t nargs
, Lisp_Object
*args
)
399 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
403 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
404 doc
: /* Return a copy of a list, vector, string or char-table.
405 The elements of a list or vector are not copied; they are shared
406 with the original. */)
409 if (NILP (arg
)) return arg
;
411 if (CHAR_TABLE_P (arg
))
413 return copy_char_table (arg
);
416 if (BOOL_VECTOR_P (arg
))
420 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
421 / BOOL_VECTOR_BITS_PER_CHAR
);
423 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
424 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
429 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
430 wrong_type_argument (Qsequencep
, arg
);
432 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
435 /* This structure holds information of an argument of `concat' that is
436 a string and has text properties to be copied. */
439 int argnum
; /* refer to ARGS (arguments of `concat') */
440 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
441 EMACS_INT to
; /* refer to VAL (the target string) */
445 concat (size_t nargs
, Lisp_Object
*args
,
446 enum Lisp_Type target_type
, int last_special
)
449 register Lisp_Object tail
;
450 register Lisp_Object
this;
452 EMACS_INT toindex_byte
= 0;
453 register EMACS_INT result_len
;
454 register EMACS_INT result_len_byte
;
455 register size_t argnum
;
456 Lisp_Object last_tail
;
459 /* When we make a multibyte string, we can't copy text properties
460 while concatenating each string because the length of resulting
461 string can't be decided until we finish the whole concatenation.
462 So, we record strings that have text properties to be copied
463 here, and copy the text properties after the concatenation. */
464 struct textprop_rec
*textprops
= NULL
;
465 /* Number of elements in textprops. */
466 int num_textprops
= 0;
471 /* In append, the last arg isn't treated like the others */
472 if (last_special
&& nargs
> 0)
475 last_tail
= args
[nargs
];
480 /* Check each argument. */
481 for (argnum
= 0; argnum
< nargs
; argnum
++)
484 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
485 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
486 wrong_type_argument (Qsequencep
, this);
489 /* Compute total length in chars of arguments in RESULT_LEN.
490 If desired output is a string, also compute length in bytes
491 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
492 whether the result should be a multibyte string. */
496 for (argnum
= 0; argnum
< nargs
; argnum
++)
500 len
= XFASTINT (Flength (this));
501 if (target_type
== Lisp_String
)
503 /* We must count the number of bytes needed in the string
504 as well as the number of characters. */
508 EMACS_INT this_len_byte
;
510 if (VECTORP (this) || COMPILEDP (this))
511 for (i
= 0; i
< len
; i
++)
514 CHECK_CHARACTER (ch
);
516 this_len_byte
= CHAR_BYTES (c
);
517 result_len_byte
+= this_len_byte
;
518 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
521 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
522 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
523 else if (CONSP (this))
524 for (; CONSP (this); this = XCDR (this))
527 CHECK_CHARACTER (ch
);
529 this_len_byte
= CHAR_BYTES (c
);
530 result_len_byte
+= this_len_byte
;
531 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
534 else if (STRINGP (this))
536 if (STRING_MULTIBYTE (this))
539 result_len_byte
+= SBYTES (this);
542 result_len_byte
+= count_size_as_multibyte (SDATA (this),
549 error ("String overflow");
552 if (! some_multibyte
)
553 result_len_byte
= result_len
;
555 /* Create the output object. */
556 if (target_type
== Lisp_Cons
)
557 val
= Fmake_list (make_number (result_len
), Qnil
);
558 else if (target_type
== Lisp_Vectorlike
)
559 val
= Fmake_vector (make_number (result_len
), Qnil
);
560 else if (some_multibyte
)
561 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
563 val
= make_uninit_string (result_len
);
565 /* In `append', if all but last arg are nil, return last arg. */
566 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
569 /* Copy the contents of the args into the result. */
571 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
573 toindex
= 0, toindex_byte
= 0;
577 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
579 for (argnum
= 0; argnum
< nargs
; argnum
++)
582 EMACS_INT thisleni
= 0;
583 register EMACS_INT thisindex
= 0;
584 register EMACS_INT thisindex_byte
= 0;
588 thislen
= Flength (this), thisleni
= XINT (thislen
);
590 /* Between strings of the same kind, copy fast. */
591 if (STRINGP (this) && STRINGP (val
)
592 && STRING_MULTIBYTE (this) == some_multibyte
)
594 EMACS_INT thislen_byte
= SBYTES (this);
596 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
597 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
599 textprops
[num_textprops
].argnum
= argnum
;
600 textprops
[num_textprops
].from
= 0;
601 textprops
[num_textprops
++].to
= toindex
;
603 toindex_byte
+= thislen_byte
;
606 /* Copy a single-byte string to a multibyte string. */
607 else if (STRINGP (this) && STRINGP (val
))
609 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
611 textprops
[num_textprops
].argnum
= argnum
;
612 textprops
[num_textprops
].from
= 0;
613 textprops
[num_textprops
++].to
= toindex
;
615 toindex_byte
+= copy_text (SDATA (this),
616 SDATA (val
) + toindex_byte
,
617 SCHARS (this), 0, 1);
621 /* Copy element by element. */
624 register Lisp_Object elt
;
626 /* Fetch next element of `this' arg into `elt', or break if
627 `this' is exhausted. */
628 if (NILP (this)) break;
630 elt
= XCAR (this), this = XCDR (this);
631 else if (thisindex
>= thisleni
)
633 else if (STRINGP (this))
636 if (STRING_MULTIBYTE (this))
637 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
642 c
= SREF (this, thisindex
); thisindex
++;
643 if (some_multibyte
&& !ASCII_CHAR_P (c
))
644 c
= BYTE8_TO_CHAR (c
);
646 XSETFASTINT (elt
, c
);
648 else if (BOOL_VECTOR_P (this))
651 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
652 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
660 elt
= AREF (this, thisindex
);
664 /* Store this element into the result. */
671 else if (VECTORP (val
))
673 ASET (val
, toindex
, elt
);
679 CHECK_CHARACTER (elt
);
682 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
684 SSET (val
, toindex_byte
++, c
);
690 XSETCDR (prev
, last_tail
);
692 if (num_textprops
> 0)
695 EMACS_INT last_to_end
= -1;
697 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
699 this = args
[textprops
[argnum
].argnum
];
700 props
= text_property_list (this,
702 make_number (SCHARS (this)),
704 /* If successive arguments have properties, be sure that the
705 value of `composition' property be the copy. */
706 if (last_to_end
== textprops
[argnum
].to
)
707 make_composition_value_copy (props
);
708 add_text_properties_from_list (val
, props
,
709 make_number (textprops
[argnum
].to
));
710 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
718 static Lisp_Object string_char_byte_cache_string
;
719 static EMACS_INT string_char_byte_cache_charpos
;
720 static EMACS_INT string_char_byte_cache_bytepos
;
723 clear_string_char_byte_cache (void)
725 string_char_byte_cache_string
= Qnil
;
728 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
731 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
734 EMACS_INT best_below
, best_below_byte
;
735 EMACS_INT best_above
, best_above_byte
;
737 best_below
= best_below_byte
= 0;
738 best_above
= SCHARS (string
);
739 best_above_byte
= SBYTES (string
);
740 if (best_above
== best_above_byte
)
743 if (EQ (string
, string_char_byte_cache_string
))
745 if (string_char_byte_cache_charpos
< char_index
)
747 best_below
= string_char_byte_cache_charpos
;
748 best_below_byte
= string_char_byte_cache_bytepos
;
752 best_above
= string_char_byte_cache_charpos
;
753 best_above_byte
= string_char_byte_cache_bytepos
;
757 if (char_index
- best_below
< best_above
- char_index
)
759 unsigned char *p
= SDATA (string
) + best_below_byte
;
761 while (best_below
< char_index
)
763 p
+= BYTES_BY_CHAR_HEAD (*p
);
766 i_byte
= p
- SDATA (string
);
770 unsigned char *p
= SDATA (string
) + best_above_byte
;
772 while (best_above
> char_index
)
775 while (!CHAR_HEAD_P (*p
)) p
--;
778 i_byte
= p
- SDATA (string
);
781 string_char_byte_cache_bytepos
= i_byte
;
782 string_char_byte_cache_charpos
= char_index
;
783 string_char_byte_cache_string
= string
;
788 /* Return the character index corresponding to BYTE_INDEX in STRING. */
791 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
794 EMACS_INT best_below
, best_below_byte
;
795 EMACS_INT best_above
, best_above_byte
;
797 best_below
= best_below_byte
= 0;
798 best_above
= SCHARS (string
);
799 best_above_byte
= SBYTES (string
);
800 if (best_above
== best_above_byte
)
803 if (EQ (string
, string_char_byte_cache_string
))
805 if (string_char_byte_cache_bytepos
< byte_index
)
807 best_below
= string_char_byte_cache_charpos
;
808 best_below_byte
= string_char_byte_cache_bytepos
;
812 best_above
= string_char_byte_cache_charpos
;
813 best_above_byte
= string_char_byte_cache_bytepos
;
817 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
819 unsigned char *p
= SDATA (string
) + best_below_byte
;
820 unsigned char *pend
= SDATA (string
) + byte_index
;
824 p
+= BYTES_BY_CHAR_HEAD (*p
);
828 i_byte
= p
- SDATA (string
);
832 unsigned char *p
= SDATA (string
) + best_above_byte
;
833 unsigned char *pbeg
= SDATA (string
) + byte_index
;
838 while (!CHAR_HEAD_P (*p
)) p
--;
842 i_byte
= p
- SDATA (string
);
845 string_char_byte_cache_bytepos
= i_byte
;
846 string_char_byte_cache_charpos
= i
;
847 string_char_byte_cache_string
= string
;
852 /* Convert STRING to a multibyte string. */
855 string_make_multibyte (Lisp_Object string
)
862 if (STRING_MULTIBYTE (string
))
865 nbytes
= count_size_as_multibyte (SDATA (string
),
867 /* If all the chars are ASCII, they won't need any more bytes
868 once converted. In that case, we can return STRING itself. */
869 if (nbytes
== SBYTES (string
))
872 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
873 copy_text (SDATA (string
), buf
, SBYTES (string
),
876 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
883 /* Convert STRING (if unibyte) to a multibyte string without changing
884 the number of characters. Characters 0200 trough 0237 are
885 converted to eight-bit characters. */
888 string_to_multibyte (Lisp_Object string
)
895 if (STRING_MULTIBYTE (string
))
898 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
899 /* If all the chars are ASCII, they won't need any more bytes once
901 if (nbytes
== SBYTES (string
))
902 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
904 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
905 memcpy (buf
, SDATA (string
), SBYTES (string
));
906 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
908 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
915 /* Convert STRING to a single-byte string. */
918 string_make_unibyte (Lisp_Object string
)
925 if (! STRING_MULTIBYTE (string
))
928 nchars
= SCHARS (string
);
930 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
931 copy_text (SDATA (string
), buf
, SBYTES (string
),
934 ret
= make_unibyte_string ((char *) buf
, nchars
);
940 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
942 doc
: /* Return the multibyte equivalent of STRING.
943 If STRING is unibyte and contains non-ASCII characters, the function
944 `unibyte-char-to-multibyte' is used to convert each unibyte character
945 to a multibyte character. In this case, the returned string is a
946 newly created string with no text properties. If STRING is multibyte
947 or entirely ASCII, it is returned unchanged. In particular, when
948 STRING is unibyte and entirely ASCII, the returned string is unibyte.
949 \(When the characters are all ASCII, Emacs primitives will treat the
950 string the same way whether it is unibyte or multibyte.) */)
953 CHECK_STRING (string
);
955 return string_make_multibyte (string
);
958 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
960 doc
: /* Return the unibyte equivalent of STRING.
961 Multibyte character codes are converted to unibyte according to
962 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
963 If the lookup in the translation table fails, this function takes just
964 the low 8 bits of each character. */)
967 CHECK_STRING (string
);
969 return string_make_unibyte (string
);
972 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
974 doc
: /* Return a unibyte string with the same individual bytes as STRING.
975 If STRING is unibyte, the result is STRING itself.
976 Otherwise it is a newly created string, with no text properties.
977 If STRING is multibyte and contains a character of charset
978 `eight-bit', it is converted to the corresponding single byte. */)
981 CHECK_STRING (string
);
983 if (STRING_MULTIBYTE (string
))
985 EMACS_INT bytes
= SBYTES (string
);
986 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
988 memcpy (str
, SDATA (string
), bytes
);
989 bytes
= str_as_unibyte (str
, bytes
);
990 string
= make_unibyte_string ((char *) str
, bytes
);
996 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
998 doc
: /* Return a multibyte string with the same individual bytes as STRING.
999 If STRING is multibyte, the result is STRING itself.
1000 Otherwise it is a newly created string, with no text properties.
1002 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1003 part of a correct utf-8 sequence), it is converted to the corresponding
1004 multibyte character of charset `eight-bit'.
1005 See also `string-to-multibyte'.
1007 Beware, this often doesn't really do what you think it does.
1008 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1009 If you're not sure, whether to use `string-as-multibyte' or
1010 `string-to-multibyte', use `string-to-multibyte'. */)
1011 (Lisp_Object string
)
1013 CHECK_STRING (string
);
1015 if (! STRING_MULTIBYTE (string
))
1017 Lisp_Object new_string
;
1018 EMACS_INT nchars
, nbytes
;
1020 parse_str_as_multibyte (SDATA (string
),
1023 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1024 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1025 if (nbytes
!= SBYTES (string
))
1026 str_as_multibyte (SDATA (new_string
), nbytes
,
1027 SBYTES (string
), NULL
);
1028 string
= new_string
;
1029 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1034 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1036 doc
: /* Return a multibyte string with the same individual chars as STRING.
1037 If STRING is multibyte, the result is STRING itself.
1038 Otherwise it is a newly created string, with no text properties.
1040 If STRING is unibyte and contains an 8-bit byte, it is converted to
1041 the corresponding multibyte character of charset `eight-bit'.
1043 This differs from `string-as-multibyte' by converting each byte of a correct
1044 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1045 correct sequence. */)
1046 (Lisp_Object string
)
1048 CHECK_STRING (string
);
1050 return string_to_multibyte (string
);
1053 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1055 doc
: /* Return a unibyte string with the same individual chars as STRING.
1056 If STRING is unibyte, the result is STRING itself.
1057 Otherwise it is a newly created string, with no text properties,
1058 where each `eight-bit' character is converted to the corresponding byte.
1059 If STRING contains a non-ASCII, non-`eight-bit' character,
1060 an error is signaled. */)
1061 (Lisp_Object string
)
1063 CHECK_STRING (string
);
1065 if (STRING_MULTIBYTE (string
))
1067 EMACS_INT chars
= SCHARS (string
);
1068 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1069 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1071 if (converted
< chars
)
1072 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1073 string
= make_unibyte_string ((char *) str
, chars
);
1080 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1081 doc
: /* Return a copy of ALIST.
1082 This is an alist which represents the same mapping from objects to objects,
1083 but does not share the alist structure with ALIST.
1084 The objects mapped (cars and cdrs of elements of the alist)
1085 are shared, however.
1086 Elements of ALIST that are not conses are also shared. */)
1089 register Lisp_Object tem
;
1094 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1095 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1097 register Lisp_Object car
;
1101 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1106 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1107 doc
: /* Return a new string whose contents are a substring of STRING.
1108 The returned string consists of the characters between index FROM
1109 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1110 zero-indexed: 0 means the first character of STRING. Negative values
1111 are counted from the end of STRING. If TO is nil, the substring runs
1112 to the end of STRING.
1114 The STRING argument may also be a vector. In that case, the return
1115 value is a new vector that contains the elements between index FROM
1116 \(inclusive) and index TO (exclusive) of that vector argument. */)
1117 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1121 EMACS_INT size_byte
= 0;
1122 EMACS_INT from_char
, to_char
;
1123 EMACS_INT from_byte
= 0, to_byte
= 0;
1125 CHECK_VECTOR_OR_STRING (string
);
1126 CHECK_NUMBER (from
);
1128 if (STRINGP (string
))
1130 size
= SCHARS (string
);
1131 size_byte
= SBYTES (string
);
1134 size
= ASIZE (string
);
1139 to_byte
= size_byte
;
1145 to_char
= XINT (to
);
1149 if (STRINGP (string
))
1150 to_byte
= string_char_to_byte (string
, to_char
);
1153 from_char
= XINT (from
);
1156 if (STRINGP (string
))
1157 from_byte
= string_char_to_byte (string
, from_char
);
1159 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1160 args_out_of_range_3 (string
, make_number (from_char
),
1161 make_number (to_char
));
1163 if (STRINGP (string
))
1165 res
= make_specified_string (SSDATA (string
) + from_byte
,
1166 to_char
- from_char
, to_byte
- from_byte
,
1167 STRING_MULTIBYTE (string
));
1168 copy_text_properties (make_number (from_char
), make_number (to_char
),
1169 string
, make_number (0), res
, Qnil
);
1172 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1178 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1179 doc
: /* Return a substring of STRING, without text properties.
1180 It starts at index FROM and ends before TO.
1181 TO may be nil or omitted; then the substring runs to the end of STRING.
1182 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1183 If FROM or TO is negative, it counts from the end.
1185 With one argument, just copy STRING without its properties. */)
1186 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1188 EMACS_INT size
, size_byte
;
1189 EMACS_INT from_char
, to_char
;
1190 EMACS_INT from_byte
, to_byte
;
1192 CHECK_STRING (string
);
1194 size
= SCHARS (string
);
1195 size_byte
= SBYTES (string
);
1198 from_char
= from_byte
= 0;
1201 CHECK_NUMBER (from
);
1202 from_char
= XINT (from
);
1206 from_byte
= string_char_to_byte (string
, from_char
);
1212 to_byte
= size_byte
;
1218 to_char
= XINT (to
);
1222 to_byte
= string_char_to_byte (string
, to_char
);
1225 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1226 args_out_of_range_3 (string
, make_number (from_char
),
1227 make_number (to_char
));
1229 return make_specified_string (SSDATA (string
) + from_byte
,
1230 to_char
- from_char
, to_byte
- from_byte
,
1231 STRING_MULTIBYTE (string
));
1234 /* Extract a substring of STRING, giving start and end positions
1235 both in characters and in bytes. */
1238 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1239 EMACS_INT to
, EMACS_INT to_byte
)
1244 CHECK_VECTOR_OR_STRING (string
);
1246 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1248 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1249 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1251 if (STRINGP (string
))
1253 res
= make_specified_string (SSDATA (string
) + from_byte
,
1254 to
- from
, to_byte
- from_byte
,
1255 STRING_MULTIBYTE (string
));
1256 copy_text_properties (make_number (from
), make_number (to
),
1257 string
, make_number (0), res
, Qnil
);
1260 res
= Fvector (to
- from
, &AREF (string
, from
));
1265 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1266 doc
: /* Take cdr N times on LIST, return the result. */)
1267 (Lisp_Object n
, Lisp_Object list
)
1269 register int i
, num
;
1272 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1275 CHECK_LIST_CONS (list
, list
);
1281 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1282 doc
: /* Return the Nth element of LIST.
1283 N counts from zero. If LIST is not that long, nil is returned. */)
1284 (Lisp_Object n
, Lisp_Object list
)
1286 return Fcar (Fnthcdr (n
, list
));
1289 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1290 doc
: /* Return element of SEQUENCE at index N. */)
1291 (register Lisp_Object sequence
, Lisp_Object n
)
1294 if (CONSP (sequence
) || NILP (sequence
))
1295 return Fcar (Fnthcdr (n
, sequence
));
1297 /* Faref signals a "not array" error, so check here. */
1298 CHECK_ARRAY (sequence
, Qsequencep
);
1299 return Faref (sequence
, n
);
1302 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1303 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1304 The value is actually the tail of LIST whose car is ELT. */)
1305 (register Lisp_Object elt
, Lisp_Object list
)
1307 register Lisp_Object tail
;
1308 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1310 register Lisp_Object tem
;
1311 CHECK_LIST_CONS (tail
, list
);
1313 if (! NILP (Fequal (elt
, tem
)))
1320 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1321 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1322 The value is actually the tail of LIST whose car is ELT. */)
1323 (register Lisp_Object elt
, Lisp_Object list
)
1327 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1331 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1335 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1346 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1347 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1348 The value is actually the tail of LIST whose car is ELT. */)
1349 (register Lisp_Object elt
, Lisp_Object list
)
1351 register Lisp_Object tail
;
1354 return Fmemq (elt
, list
);
1356 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1358 register Lisp_Object tem
;
1359 CHECK_LIST_CONS (tail
, list
);
1361 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1368 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1369 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1370 The value is actually the first element of LIST whose car is KEY.
1371 Elements of LIST that are not conses are ignored. */)
1372 (Lisp_Object key
, Lisp_Object list
)
1377 || (CONSP (XCAR (list
))
1378 && EQ (XCAR (XCAR (list
)), key
)))
1383 || (CONSP (XCAR (list
))
1384 && EQ (XCAR (XCAR (list
)), key
)))
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1400 /* Like Fassq but never report an error and do not allow quits.
1401 Use only on lists known never to be circular. */
1404 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1407 && (!CONSP (XCAR (list
))
1408 || !EQ (XCAR (XCAR (list
)), key
)))
1411 return CAR_SAFE (list
);
1414 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1415 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1416 The value is actually the first element of LIST whose car equals KEY. */)
1417 (Lisp_Object key
, Lisp_Object list
)
1424 || (CONSP (XCAR (list
))
1425 && (car
= XCAR (XCAR (list
)),
1426 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1431 || (CONSP (XCAR (list
))
1432 && (car
= XCAR (XCAR (list
)),
1433 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1438 || (CONSP (XCAR (list
))
1439 && (car
= XCAR (XCAR (list
)),
1440 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1450 /* Like Fassoc but never report an error and do not allow quits.
1451 Use only on lists known never to be circular. */
1454 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1457 && (!CONSP (XCAR (list
))
1458 || (!EQ (XCAR (XCAR (list
)), key
)
1459 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1462 return CONSP (list
) ? XCAR (list
) : Qnil
;
1465 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1466 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1467 The value is actually the first element of LIST whose cdr is KEY. */)
1468 (register Lisp_Object key
, Lisp_Object list
)
1473 || (CONSP (XCAR (list
))
1474 && EQ (XCDR (XCAR (list
)), key
)))
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCDR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCDR (XCAR (list
)), key
)))
1496 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1497 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1498 The value is actually the first element of LIST whose cdr equals KEY. */)
1499 (Lisp_Object key
, Lisp_Object list
)
1506 || (CONSP (XCAR (list
))
1507 && (cdr
= XCDR (XCAR (list
)),
1508 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1513 || (CONSP (XCAR (list
))
1514 && (cdr
= XCDR (XCAR (list
)),
1515 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1520 || (CONSP (XCAR (list
))
1521 && (cdr
= XCDR (XCAR (list
)),
1522 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1532 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1533 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1534 The modified LIST is returned. Comparison is done with `eq'.
1535 If the first member of LIST is ELT, there is no way to remove it by side effect;
1536 therefore, write `(setq foo (delq element foo))'
1537 to be sure of changing the value of `foo'. */)
1538 (register Lisp_Object elt
, Lisp_Object list
)
1540 register Lisp_Object tail
, prev
;
1541 register Lisp_Object tem
;
1545 while (!NILP (tail
))
1547 CHECK_LIST_CONS (tail
, list
);
1554 Fsetcdr (prev
, XCDR (tail
));
1564 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1565 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1566 SEQ must be a list, a vector, or a string.
1567 The modified SEQ is returned. Comparison is done with `equal'.
1568 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1569 is not a side effect; it is simply using a different sequence.
1570 Therefore, write `(setq foo (delete element foo))'
1571 to be sure of changing the value of `foo'. */)
1572 (Lisp_Object elt
, Lisp_Object seq
)
1578 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1579 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1582 if (n
!= ASIZE (seq
))
1584 struct Lisp_Vector
*p
= allocate_vector (n
);
1586 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1587 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1588 p
->contents
[n
++] = AREF (seq
, i
);
1590 XSETVECTOR (seq
, p
);
1593 else if (STRINGP (seq
))
1595 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1598 for (i
= nchars
= nbytes
= ibyte
= 0;
1600 ++i
, ibyte
+= cbytes
)
1602 if (STRING_MULTIBYTE (seq
))
1604 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1605 cbytes
= CHAR_BYTES (c
);
1613 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1620 if (nchars
!= SCHARS (seq
))
1624 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1625 if (!STRING_MULTIBYTE (seq
))
1626 STRING_SET_UNIBYTE (tem
);
1628 for (i
= nchars
= nbytes
= ibyte
= 0;
1630 ++i
, ibyte
+= cbytes
)
1632 if (STRING_MULTIBYTE (seq
))
1634 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1635 cbytes
= CHAR_BYTES (c
);
1643 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1645 unsigned char *from
= SDATA (seq
) + ibyte
;
1646 unsigned char *to
= SDATA (tem
) + nbytes
;
1652 for (n
= cbytes
; n
--; )
1662 Lisp_Object tail
, prev
;
1664 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1666 CHECK_LIST_CONS (tail
, seq
);
1668 if (!NILP (Fequal (elt
, XCAR (tail
))))
1673 Fsetcdr (prev
, XCDR (tail
));
1684 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1685 doc
: /* Reverse LIST by modifying cdr pointers.
1686 Return the reversed list. */)
1689 register Lisp_Object prev
, tail
, next
;
1691 if (NILP (list
)) return list
;
1694 while (!NILP (tail
))
1697 CHECK_LIST_CONS (tail
, list
);
1699 Fsetcdr (tail
, prev
);
1706 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1707 doc
: /* Reverse LIST, copying. Return the reversed list.
1708 See also the function `nreverse', which is used more often. */)
1713 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1716 new = Fcons (XCAR (list
), new);
1718 CHECK_LIST_END (list
, list
);
1722 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1724 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1725 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1726 Returns the sorted list. LIST is modified by side effects.
1727 PREDICATE is called with two elements of LIST, and should return non-nil
1728 if the first element should sort before the second. */)
1729 (Lisp_Object list
, Lisp_Object predicate
)
1731 Lisp_Object front
, back
;
1732 register Lisp_Object len
, tem
;
1733 struct gcpro gcpro1
, gcpro2
;
1734 register int length
;
1737 len
= Flength (list
);
1738 length
= XINT (len
);
1742 XSETINT (len
, (length
/ 2) - 1);
1743 tem
= Fnthcdr (len
, list
);
1745 Fsetcdr (tem
, Qnil
);
1747 GCPRO2 (front
, back
);
1748 front
= Fsort (front
, predicate
);
1749 back
= Fsort (back
, predicate
);
1751 return merge (front
, back
, predicate
);
1755 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1758 register Lisp_Object tail
;
1760 register Lisp_Object l1
, l2
;
1761 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1768 /* It is sufficient to protect org_l1 and org_l2.
1769 When l1 and l2 are updated, we copy the new values
1770 back into the org_ vars. */
1771 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1791 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1807 Fsetcdr (tail
, tem
);
1813 /* This does not check for quits. That is safe since it must terminate. */
1815 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1816 doc
: /* Extract a value from a property list.
1817 PLIST is a property list, which is a list of the form
1818 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1819 corresponding to the given PROP, or nil if PROP is not one of the
1820 properties on the list. This function never signals an error. */)
1821 (Lisp_Object plist
, Lisp_Object prop
)
1823 Lisp_Object tail
, halftail
;
1825 /* halftail is used to detect circular lists. */
1826 tail
= halftail
= plist
;
1827 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1829 if (EQ (prop
, XCAR (tail
)))
1830 return XCAR (XCDR (tail
));
1832 tail
= XCDR (XCDR (tail
));
1833 halftail
= XCDR (halftail
);
1834 if (EQ (tail
, halftail
))
1837 #if 0 /* Unsafe version. */
1838 /* This function can be called asynchronously
1839 (setup_coding_system). Don't QUIT in that case. */
1840 if (!interrupt_input_blocked
)
1848 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1849 doc
: /* Return the value of SYMBOL's PROPNAME property.
1850 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1851 (Lisp_Object symbol
, Lisp_Object propname
)
1853 CHECK_SYMBOL (symbol
);
1854 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1857 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1858 doc
: /* Change value in PLIST of PROP to VAL.
1859 PLIST is a property list, which is a list of the form
1860 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1861 If PROP is already a property on the list, its value is set to VAL,
1862 otherwise the new PROP VAL pair is added. The new plist is returned;
1863 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1864 The PLIST is modified by side effects. */)
1865 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1867 register Lisp_Object tail
, prev
;
1868 Lisp_Object newcell
;
1870 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1871 tail
= XCDR (XCDR (tail
)))
1873 if (EQ (prop
, XCAR (tail
)))
1875 Fsetcar (XCDR (tail
), val
);
1882 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1886 Fsetcdr (XCDR (prev
), newcell
);
1890 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1891 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1892 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1893 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1895 CHECK_SYMBOL (symbol
);
1896 XSYMBOL (symbol
)->plist
1897 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1901 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1902 doc
: /* Extract a value from a property list, comparing with `equal'.
1903 PLIST is a property list, which is a list of the form
1904 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1905 corresponding to the given PROP, or nil if PROP is not
1906 one of the properties on the list. */)
1907 (Lisp_Object plist
, Lisp_Object prop
)
1912 CONSP (tail
) && CONSP (XCDR (tail
));
1913 tail
= XCDR (XCDR (tail
)))
1915 if (! NILP (Fequal (prop
, XCAR (tail
))))
1916 return XCAR (XCDR (tail
));
1921 CHECK_LIST_END (tail
, prop
);
1926 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1927 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1928 PLIST is a property list, which is a list of the form
1929 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1930 If PROP is already a property on the list, its value is set to VAL,
1931 otherwise the new PROP VAL pair is added. The new plist is returned;
1932 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1933 The PLIST is modified by side effects. */)
1934 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1936 register Lisp_Object tail
, prev
;
1937 Lisp_Object newcell
;
1939 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1940 tail
= XCDR (XCDR (tail
)))
1942 if (! NILP (Fequal (prop
, XCAR (tail
))))
1944 Fsetcar (XCDR (tail
), val
);
1951 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1955 Fsetcdr (XCDR (prev
), newcell
);
1959 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1960 doc
: /* Return t if the two args are the same Lisp object.
1961 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1962 (Lisp_Object obj1
, Lisp_Object obj2
)
1965 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1967 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1970 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1971 doc
: /* Return t if two Lisp objects have similar structure and contents.
1972 They must have the same data type.
1973 Conses are compared by comparing the cars and the cdrs.
1974 Vectors and strings are compared element by element.
1975 Numbers are compared by value, but integers cannot equal floats.
1976 (Use `=' if you want integers and floats to be able to be equal.)
1977 Symbols must match exactly. */)
1978 (register Lisp_Object o1
, Lisp_Object o2
)
1980 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1983 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1984 doc
: /* Return t if two Lisp objects have similar structure and contents.
1985 This is like `equal' except that it compares the text properties
1986 of strings. (`equal' ignores text properties.) */)
1987 (register Lisp_Object o1
, Lisp_Object o2
)
1989 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
1992 /* DEPTH is current depth of recursion. Signal an error if it
1994 PROPS, if non-nil, means compare string text properties too. */
1997 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2000 error ("Stack overflow in equal");
2006 if (XTYPE (o1
) != XTYPE (o2
))
2015 d1
= extract_float (o1
);
2016 d2
= extract_float (o2
);
2017 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2018 though they are not =. */
2019 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2023 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2030 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2034 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2036 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2039 o1
= XOVERLAY (o1
)->plist
;
2040 o2
= XOVERLAY (o2
)->plist
;
2045 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2046 && (XMARKER (o1
)->buffer
== 0
2047 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2051 case Lisp_Vectorlike
:
2054 EMACS_INT size
= ASIZE (o1
);
2055 /* Pseudovectors have the type encoded in the size field, so this test
2056 actually checks that the objects have the same type as well as the
2058 if (ASIZE (o2
) != size
)
2060 /* Boolvectors are compared much like strings. */
2061 if (BOOL_VECTOR_P (o1
))
2063 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2065 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2066 ((XBOOL_VECTOR (o1
)->size
2067 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2068 / BOOL_VECTOR_BITS_PER_CHAR
)))
2072 if (WINDOW_CONFIGURATIONP (o1
))
2073 return compare_window_configurations (o1
, o2
, 0);
2075 /* Aside from them, only true vectors, char-tables, compiled
2076 functions, and fonts (font-spec, font-entity, font-object)
2077 are sensible to compare, so eliminate the others now. */
2078 if (size
& PSEUDOVECTOR_FLAG
)
2080 if (!(size
& (PVEC_COMPILED
2081 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2083 size
&= PSEUDOVECTOR_SIZE_MASK
;
2085 for (i
= 0; i
< size
; i
++)
2090 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2098 if (SCHARS (o1
) != SCHARS (o2
))
2100 if (SBYTES (o1
) != SBYTES (o2
))
2102 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2104 if (props
&& !compare_string_intervals (o1
, o2
))
2116 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2117 doc
: /* Store each element of ARRAY with ITEM.
2118 ARRAY is a vector, string, char-table, or bool-vector. */)
2119 (Lisp_Object array
, Lisp_Object item
)
2121 register EMACS_INT size
, idx
;
2124 if (VECTORP (array
))
2126 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2127 size
= ASIZE (array
);
2128 for (idx
= 0; idx
< size
; idx
++)
2131 else if (CHAR_TABLE_P (array
))
2135 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2136 XCHAR_TABLE (array
)->contents
[i
] = item
;
2137 XCHAR_TABLE (array
)->defalt
= item
;
2139 else if (STRINGP (array
))
2141 register unsigned char *p
= SDATA (array
);
2142 CHECK_NUMBER (item
);
2143 charval
= XINT (item
);
2144 size
= SCHARS (array
);
2145 if (STRING_MULTIBYTE (array
))
2147 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2148 int len
= CHAR_STRING (charval
, str
);
2149 EMACS_INT size_byte
= SBYTES (array
);
2150 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2153 if (size
!= size_byte
)
2156 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2157 if (len
!= this_len
)
2158 error ("Attempt to change byte length of a string");
2161 for (i
= 0; i
< size_byte
; i
++)
2162 *p
++ = str
[i
% len
];
2165 for (idx
= 0; idx
< size
; idx
++)
2168 else if (BOOL_VECTOR_P (array
))
2170 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2172 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2173 / BOOL_VECTOR_BITS_PER_CHAR
);
2175 charval
= (! NILP (item
) ? -1 : 0);
2176 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2178 if (idx
< size_in_chars
)
2180 /* Mask out bits beyond the vector size. */
2181 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2182 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2187 wrong_type_argument (Qarrayp
, array
);
2191 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2193 doc
: /* Clear the contents of STRING.
2194 This makes STRING unibyte and may change its length. */)
2195 (Lisp_Object string
)
2198 CHECK_STRING (string
);
2199 len
= SBYTES (string
);
2200 memset (SDATA (string
), 0, len
);
2201 STRING_SET_CHARS (string
, len
);
2202 STRING_SET_UNIBYTE (string
);
2208 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2210 Lisp_Object args
[2];
2213 return Fnconc (2, args
);
2216 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2217 doc
: /* Concatenate any number of lists by altering them.
2218 Only the last argument is not altered, and need not be a list.
2219 usage: (nconc &rest LISTS) */)
2220 (size_t nargs
, Lisp_Object
*args
)
2222 register size_t argnum
;
2223 register Lisp_Object tail
, tem
, val
;
2227 for (argnum
= 0; argnum
< nargs
; argnum
++)
2230 if (NILP (tem
)) continue;
2235 if (argnum
+ 1 == nargs
) break;
2237 CHECK_LIST_CONS (tem
, tem
);
2246 tem
= args
[argnum
+ 1];
2247 Fsetcdr (tail
, tem
);
2249 args
[argnum
+ 1] = tail
;
2255 /* This is the guts of all mapping functions.
2256 Apply FN to each element of SEQ, one by one,
2257 storing the results into elements of VALS, a C vector of Lisp_Objects.
2258 LENI is the length of VALS, which should also be the length of SEQ. */
2261 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2263 register Lisp_Object tail
;
2265 register EMACS_INT i
;
2266 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2270 /* Don't let vals contain any garbage when GC happens. */
2271 for (i
= 0; i
< leni
; i
++)
2274 GCPRO3 (dummy
, fn
, seq
);
2276 gcpro1
.nvars
= leni
;
2280 /* We need not explicitly protect `tail' because it is used only on lists, and
2281 1) lists are not relocated and 2) the list is marked via `seq' so will not
2284 if (VECTORP (seq
) || COMPILEDP (seq
))
2286 for (i
= 0; i
< leni
; i
++)
2288 dummy
= call1 (fn
, AREF (seq
, i
));
2293 else if (BOOL_VECTOR_P (seq
))
2295 for (i
= 0; i
< leni
; i
++)
2298 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2299 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2300 dummy
= call1 (fn
, dummy
);
2305 else if (STRINGP (seq
))
2309 for (i
= 0, i_byte
= 0; i
< leni
;)
2312 EMACS_INT i_before
= i
;
2314 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2315 XSETFASTINT (dummy
, c
);
2316 dummy
= call1 (fn
, dummy
);
2318 vals
[i_before
] = dummy
;
2321 else /* Must be a list, since Flength did not get an error */
2324 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2326 dummy
= call1 (fn
, XCAR (tail
));
2336 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2337 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2338 In between each pair of results, stick in SEPARATOR. Thus, " " as
2339 SEPARATOR results in spaces between the values returned by FUNCTION.
2340 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2341 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2344 register EMACS_INT leni
;
2346 register Lisp_Object
*args
;
2347 register EMACS_INT i
;
2348 struct gcpro gcpro1
;
2352 len
= Flength (sequence
);
2353 if (CHAR_TABLE_P (sequence
))
2354 wrong_type_argument (Qlistp
, sequence
);
2356 nargs
= leni
+ leni
- 1;
2357 if (nargs
< 0) return empty_unibyte_string
;
2359 SAFE_ALLOCA_LISP (args
, nargs
);
2362 mapcar1 (leni
, args
, function
, sequence
);
2365 for (i
= leni
- 1; i
> 0; i
--)
2366 args
[i
+ i
] = args
[i
];
2368 for (i
= 1; i
< nargs
; i
+= 2)
2369 args
[i
] = separator
;
2371 ret
= Fconcat (nargs
, args
);
2377 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2378 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2379 The result is a list just as long as SEQUENCE.
2380 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2381 (Lisp_Object function
, Lisp_Object sequence
)
2383 register Lisp_Object len
;
2384 register EMACS_INT leni
;
2385 register Lisp_Object
*args
;
2389 len
= Flength (sequence
);
2390 if (CHAR_TABLE_P (sequence
))
2391 wrong_type_argument (Qlistp
, sequence
);
2392 leni
= XFASTINT (len
);
2394 SAFE_ALLOCA_LISP (args
, leni
);
2396 mapcar1 (leni
, args
, function
, sequence
);
2398 ret
= Flist (leni
, args
);
2404 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2405 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2406 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2407 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2408 (Lisp_Object function
, Lisp_Object sequence
)
2410 register EMACS_INT leni
;
2412 leni
= XFASTINT (Flength (sequence
));
2413 if (CHAR_TABLE_P (sequence
))
2414 wrong_type_argument (Qlistp
, sequence
);
2415 mapcar1 (leni
, 0, function
, sequence
);
2420 /* This is how C code calls `yes-or-no-p' and allows the user
2423 Anything that calls this function must protect from GC! */
2426 do_yes_or_no_p (Lisp_Object prompt
)
2428 return call1 (intern ("yes-or-no-p"), prompt
);
2431 /* Anything that calls this function must protect from GC! */
2433 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2434 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2435 PROMPT is the string to display to ask the question. It should end in
2436 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2438 The user must confirm the answer with RET, and can edit it until it
2441 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2442 is nil, and `use-dialog-box' is non-nil. */)
2443 (Lisp_Object prompt
)
2445 register Lisp_Object ans
;
2446 Lisp_Object args
[2];
2447 struct gcpro gcpro1
;
2449 CHECK_STRING (prompt
);
2452 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2453 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2457 Lisp_Object pane
, menu
, obj
;
2458 redisplay_preserve_echo_area (4);
2459 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2460 Fcons (Fcons (build_string ("No"), Qnil
),
2463 menu
= Fcons (prompt
, pane
);
2464 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2468 #endif /* HAVE_MENUS */
2471 args
[1] = build_string ("(yes or no) ");
2472 prompt
= Fconcat (2, args
);
2478 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2479 Qyes_or_no_p_history
, Qnil
,
2481 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2486 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2494 message ("Please answer yes or no.");
2495 Fsleep_for (make_number (2), Qnil
);
2499 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2500 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2502 Each of the three load averages is multiplied by 100, then converted
2505 When USE-FLOATS is non-nil, floats will be used instead of integers.
2506 These floats are not multiplied by 100.
2508 If the 5-minute or 15-minute load averages are not available, return a
2509 shortened list, containing only those averages which are available.
2511 An error is thrown if the load average can't be obtained. In some
2512 cases making it work would require Emacs being installed setuid or
2513 setgid so that it can read kernel information, and that usually isn't
2515 (Lisp_Object use_floats
)
2518 int loads
= getloadavg (load_ave
, 3);
2519 Lisp_Object ret
= Qnil
;
2522 error ("load-average not implemented for this operating system");
2526 Lisp_Object load
= (NILP (use_floats
) ?
2527 make_number ((int) (100.0 * load_ave
[loads
]))
2528 : make_float (load_ave
[loads
]));
2529 ret
= Fcons (load
, ret
);
2535 static Lisp_Object Qsubfeatures
;
2537 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2538 doc
: /* Return t if FEATURE is present in this Emacs.
2540 Use this to conditionalize execution of lisp code based on the
2541 presence or absence of Emacs or environment extensions.
2542 Use `provide' to declare that a feature is available. This function
2543 looks at the value of the variable `features'. The optional argument
2544 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2545 (Lisp_Object feature
, Lisp_Object subfeature
)
2547 register Lisp_Object tem
;
2548 CHECK_SYMBOL (feature
);
2549 tem
= Fmemq (feature
, Vfeatures
);
2550 if (!NILP (tem
) && !NILP (subfeature
))
2551 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2552 return (NILP (tem
)) ? Qnil
: Qt
;
2555 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2556 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2557 The optional argument SUBFEATURES should be a list of symbols listing
2558 particular subfeatures supported in this version of FEATURE. */)
2559 (Lisp_Object feature
, Lisp_Object subfeatures
)
2561 register Lisp_Object tem
;
2562 CHECK_SYMBOL (feature
);
2563 CHECK_LIST (subfeatures
);
2564 if (!NILP (Vautoload_queue
))
2565 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2567 tem
= Fmemq (feature
, Vfeatures
);
2569 Vfeatures
= Fcons (feature
, Vfeatures
);
2570 if (!NILP (subfeatures
))
2571 Fput (feature
, Qsubfeatures
, subfeatures
);
2572 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2574 /* Run any load-hooks for this file. */
2575 tem
= Fassq (feature
, Vafter_load_alist
);
2577 Fprogn (XCDR (tem
));
2582 /* `require' and its subroutines. */
2584 /* List of features currently being require'd, innermost first. */
2586 static Lisp_Object require_nesting_list
;
2589 require_unwind (Lisp_Object old_value
)
2591 return require_nesting_list
= old_value
;
2594 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2595 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2596 If FEATURE is not a member of the list `features', then the feature
2597 is not loaded; so load the file FILENAME.
2598 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2599 and `load' will try to load this name appended with the suffix `.elc' or
2600 `.el', in that order. The name without appended suffix will not be used.
2601 If the optional third argument NOERROR is non-nil,
2602 then return nil if the file is not found instead of signaling an error.
2603 Normally the return value is FEATURE.
2604 The normal messages at start and end of loading FILENAME are suppressed. */)
2605 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2607 register Lisp_Object tem
;
2608 struct gcpro gcpro1
, gcpro2
;
2609 int from_file
= load_in_progress
;
2611 CHECK_SYMBOL (feature
);
2613 /* Record the presence of `require' in this file
2614 even if the feature specified is already loaded.
2615 But not more than once in any file,
2616 and not when we aren't loading or reading from a file. */
2618 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2619 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2624 tem
= Fcons (Qrequire
, feature
);
2625 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2626 LOADHIST_ATTACH (tem
);
2628 tem
= Fmemq (feature
, Vfeatures
);
2632 int count
= SPECPDL_INDEX ();
2635 /* This is to make sure that loadup.el gives a clear picture
2636 of what files are preloaded and when. */
2637 if (! NILP (Vpurify_flag
))
2638 error ("(require %s) while preparing to dump",
2639 SDATA (SYMBOL_NAME (feature
)));
2641 /* A certain amount of recursive `require' is legitimate,
2642 but if we require the same feature recursively 3 times,
2644 tem
= require_nesting_list
;
2645 while (! NILP (tem
))
2647 if (! NILP (Fequal (feature
, XCAR (tem
))))
2652 error ("Recursive `require' for feature `%s'",
2653 SDATA (SYMBOL_NAME (feature
)));
2655 /* Update the list for any nested `require's that occur. */
2656 record_unwind_protect (require_unwind
, require_nesting_list
);
2657 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2659 /* Value saved here is to be restored into Vautoload_queue */
2660 record_unwind_protect (un_autoload
, Vautoload_queue
);
2661 Vautoload_queue
= Qt
;
2663 /* Load the file. */
2664 GCPRO2 (feature
, filename
);
2665 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2666 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2669 /* If load failed entirely, return nil. */
2671 return unbind_to (count
, Qnil
);
2673 tem
= Fmemq (feature
, Vfeatures
);
2675 error ("Required feature `%s' was not provided",
2676 SDATA (SYMBOL_NAME (feature
)));
2678 /* Once loading finishes, don't undo it. */
2679 Vautoload_queue
= Qt
;
2680 feature
= unbind_to (count
, feature
);
2686 /* Primitives for work of the "widget" library.
2687 In an ideal world, this section would not have been necessary.
2688 However, lisp function calls being as slow as they are, it turns
2689 out that some functions in the widget library (wid-edit.el) are the
2690 bottleneck of Widget operation. Here is their translation to C,
2691 for the sole reason of efficiency. */
2693 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2694 doc
: /* Return non-nil if PLIST has the property PROP.
2695 PLIST is a property list, which is a list of the form
2696 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2697 Unlike `plist-get', this allows you to distinguish between a missing
2698 property and a property with the value nil.
2699 The value is actually the tail of PLIST whose car is PROP. */)
2700 (Lisp_Object plist
, Lisp_Object prop
)
2702 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2705 plist
= XCDR (plist
);
2706 plist
= CDR (plist
);
2711 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2712 doc
: /* In WIDGET, set PROPERTY to VALUE.
2713 The value can later be retrieved with `widget-get'. */)
2714 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2716 CHECK_CONS (widget
);
2717 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2721 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2722 doc
: /* In WIDGET, get the value of PROPERTY.
2723 The value could either be specified when the widget was created, or
2724 later with `widget-put'. */)
2725 (Lisp_Object widget
, Lisp_Object property
)
2733 CHECK_CONS (widget
);
2734 tmp
= Fplist_member (XCDR (widget
), property
);
2740 tmp
= XCAR (widget
);
2743 widget
= Fget (tmp
, Qwidget_type
);
2747 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2748 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2749 ARGS are passed as extra arguments to the function.
2750 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2751 (size_t nargs
, Lisp_Object
*args
)
2753 /* This function can GC. */
2754 Lisp_Object newargs
[3];
2755 struct gcpro gcpro1
, gcpro2
;
2758 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2759 newargs
[1] = args
[0];
2760 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2761 GCPRO2 (newargs
[0], newargs
[2]);
2762 result
= Fapply (3, newargs
);
2767 #ifdef HAVE_LANGINFO_CODESET
2768 #include <langinfo.h>
2771 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2772 doc
: /* Access locale data ITEM for the current C locale, if available.
2773 ITEM should be one of the following:
2775 `codeset', returning the character set as a string (locale item CODESET);
2777 `days', returning a 7-element vector of day names (locale items DAY_n);
2779 `months', returning a 12-element vector of month names (locale items MON_n);
2781 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2782 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2784 If the system can't provide such information through a call to
2785 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2787 See also Info node `(libc)Locales'.
2789 The data read from the system are decoded using `locale-coding-system'. */)
2793 #ifdef HAVE_LANGINFO_CODESET
2795 if (EQ (item
, Qcodeset
))
2797 str
= nl_langinfo (CODESET
);
2798 return build_string (str
);
2801 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2803 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2804 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2806 struct gcpro gcpro1
;
2808 synchronize_system_time_locale ();
2809 for (i
= 0; i
< 7; i
++)
2811 str
= nl_langinfo (days
[i
]);
2812 val
= make_unibyte_string (str
, strlen (str
));
2813 /* Fixme: Is this coding system necessarily right, even if
2814 it is consistent with CODESET? If not, what to do? */
2815 Faset (v
, make_number (i
),
2816 code_convert_string_norecord (val
, Vlocale_coding_system
,
2824 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2826 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2827 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2828 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2830 struct gcpro gcpro1
;
2832 synchronize_system_time_locale ();
2833 for (i
= 0; i
< 12; i
++)
2835 str
= nl_langinfo (months
[i
]);
2836 val
= make_unibyte_string (str
, strlen (str
));
2837 Faset (v
, make_number (i
),
2838 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2844 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2845 but is in the locale files. This could be used by ps-print. */
2847 else if (EQ (item
, Qpaper
))
2849 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2850 make_number (nl_langinfo (PAPER_HEIGHT
)));
2852 #endif /* PAPER_WIDTH */
2853 #endif /* HAVE_LANGINFO_CODESET*/
2857 /* base64 encode/decode functions (RFC 2045).
2858 Based on code from GNU recode. */
2860 #define MIME_LINE_LENGTH 76
2862 #define IS_ASCII(Character) \
2864 #define IS_BASE64(Character) \
2865 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2866 #define IS_BASE64_IGNORABLE(Character) \
2867 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2868 || (Character) == '\f' || (Character) == '\r')
2870 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2871 character or return retval if there are no characters left to
2873 #define READ_QUADRUPLET_BYTE(retval) \
2878 if (nchars_return) \
2879 *nchars_return = nchars; \
2884 while (IS_BASE64_IGNORABLE (c))
2886 /* Table of characters coding the 64 values. */
2887 static const char base64_value_to_char
[64] =
2889 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2890 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2891 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2892 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2893 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2894 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2895 '8', '9', '+', '/' /* 60-63 */
2898 /* Table of base64 values for first 128 characters. */
2899 static const short base64_char_to_value
[128] =
2901 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2902 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2903 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2904 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2905 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2906 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2907 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2908 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2909 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2910 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2911 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2912 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2913 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2916 /* The following diagram shows the logical steps by which three octets
2917 get transformed into four base64 characters.
2919 .--------. .--------. .--------.
2920 |aaaaaabb| |bbbbcccc| |ccdddddd|
2921 `--------' `--------' `--------'
2923 .--------+--------+--------+--------.
2924 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2925 `--------+--------+--------+--------'
2927 .--------+--------+--------+--------.
2928 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2929 `--------+--------+--------+--------'
2931 The octets are divided into 6 bit chunks, which are then encoded into
2932 base64 characters. */
2935 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2936 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2939 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2941 doc
: /* Base64-encode the region between BEG and END.
2942 Return the length of the encoded text.
2943 Optional third argument NO-LINE-BREAK means do not break long lines
2944 into shorter lines. */)
2945 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2948 EMACS_INT allength
, length
;
2949 EMACS_INT ibeg
, iend
, encoded_length
;
2950 EMACS_INT old_pos
= PT
;
2953 validate_region (&beg
, &end
);
2955 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2956 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2957 move_gap_both (XFASTINT (beg
), ibeg
);
2959 /* We need to allocate enough room for encoding the text.
2960 We need 33 1/3% more space, plus a newline every 76
2961 characters, and then we round up. */
2962 length
= iend
- ibeg
;
2963 allength
= length
+ length
/3 + 1;
2964 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2966 SAFE_ALLOCA (encoded
, char *, allength
);
2967 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2968 encoded
, length
, NILP (no_line_break
),
2969 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2970 if (encoded_length
> allength
)
2973 if (encoded_length
< 0)
2975 /* The encoding wasn't possible. */
2977 error ("Multibyte character in data for base64 encoding");
2980 /* Now we have encoded the region, so we insert the new contents
2981 and delete the old. (Insert first in order to preserve markers.) */
2982 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2983 insert (encoded
, encoded_length
);
2985 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2987 /* If point was outside of the region, restore it exactly; else just
2988 move to the beginning of the region. */
2989 if (old_pos
>= XFASTINT (end
))
2990 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2991 else if (old_pos
> XFASTINT (beg
))
2992 old_pos
= XFASTINT (beg
);
2995 /* We return the length of the encoded text. */
2996 return make_number (encoded_length
);
2999 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3001 doc
: /* Base64-encode STRING and return the result.
3002 Optional second argument NO-LINE-BREAK means do not break long lines
3003 into shorter lines. */)
3004 (Lisp_Object string
, Lisp_Object no_line_break
)
3006 EMACS_INT allength
, length
, encoded_length
;
3008 Lisp_Object encoded_string
;
3011 CHECK_STRING (string
);
3013 /* We need to allocate enough room for encoding the text.
3014 We need 33 1/3% more space, plus a newline every 76
3015 characters, and then we round up. */
3016 length
= SBYTES (string
);
3017 allength
= length
+ length
/3 + 1;
3018 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3020 /* We need to allocate enough room for decoding the text. */
3021 SAFE_ALLOCA (encoded
, char *, allength
);
3023 encoded_length
= base64_encode_1 (SSDATA (string
),
3024 encoded
, length
, NILP (no_line_break
),
3025 STRING_MULTIBYTE (string
));
3026 if (encoded_length
> allength
)
3029 if (encoded_length
< 0)
3031 /* The encoding wasn't possible. */
3033 error ("Multibyte character in data for base64 encoding");
3036 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3039 return encoded_string
;
3043 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3044 int line_break
, int multibyte
)
3057 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3058 if (CHAR_BYTE8_P (c
))
3059 c
= CHAR_TO_BYTE8 (c
);
3067 /* Wrap line every 76 characters. */
3071 if (counter
< MIME_LINE_LENGTH
/ 4)
3080 /* Process first byte of a triplet. */
3082 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3083 value
= (0x03 & c
) << 4;
3085 /* Process second byte of a triplet. */
3089 *e
++ = base64_value_to_char
[value
];
3097 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3098 if (CHAR_BYTE8_P (c
))
3099 c
= CHAR_TO_BYTE8 (c
);
3107 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3108 value
= (0x0f & c
) << 2;
3110 /* Process third byte of a triplet. */
3114 *e
++ = base64_value_to_char
[value
];
3121 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3122 if (CHAR_BYTE8_P (c
))
3123 c
= CHAR_TO_BYTE8 (c
);
3131 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3132 *e
++ = base64_value_to_char
[0x3f & c
];
3139 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3141 doc
: /* Base64-decode the region between BEG and END.
3142 Return the length of the decoded text.
3143 If the region can't be decoded, signal an error and don't modify the buffer. */)
3144 (Lisp_Object beg
, Lisp_Object end
)
3146 EMACS_INT ibeg
, iend
, length
, allength
;
3148 EMACS_INT old_pos
= PT
;
3149 EMACS_INT decoded_length
;
3150 EMACS_INT inserted_chars
;
3151 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3154 validate_region (&beg
, &end
);
3156 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3157 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3159 length
= iend
- ibeg
;
3161 /* We need to allocate enough room for decoding the text. If we are
3162 working on a multibyte buffer, each decoded code may occupy at
3164 allength
= multibyte
? length
* 2 : length
;
3165 SAFE_ALLOCA (decoded
, char *, allength
);
3167 move_gap_both (XFASTINT (beg
), ibeg
);
3168 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3170 multibyte
, &inserted_chars
);
3171 if (decoded_length
> allength
)
3174 if (decoded_length
< 0)
3176 /* The decoding wasn't possible. */
3178 error ("Invalid base64 data");
3181 /* Now we have decoded the region, so we insert the new contents
3182 and delete the old. (Insert first in order to preserve markers.) */
3183 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3184 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3187 /* Delete the original text. */
3188 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3189 iend
+ decoded_length
, 1);
3191 /* If point was outside of the region, restore it exactly; else just
3192 move to the beginning of the region. */
3193 if (old_pos
>= XFASTINT (end
))
3194 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3195 else if (old_pos
> XFASTINT (beg
))
3196 old_pos
= XFASTINT (beg
);
3197 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3199 return make_number (inserted_chars
);
3202 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3204 doc
: /* Base64-decode STRING and return the result. */)
3205 (Lisp_Object string
)
3208 EMACS_INT length
, decoded_length
;
3209 Lisp_Object decoded_string
;
3212 CHECK_STRING (string
);
3214 length
= SBYTES (string
);
3215 /* We need to allocate enough room for decoding the text. */
3216 SAFE_ALLOCA (decoded
, char *, length
);
3218 /* The decoded result should be unibyte. */
3219 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3221 if (decoded_length
> length
)
3223 else if (decoded_length
>= 0)
3224 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3226 decoded_string
= Qnil
;
3229 if (!STRINGP (decoded_string
))
3230 error ("Invalid base64 data");
3232 return decoded_string
;
3235 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3236 MULTIBYTE is nonzero, the decoded result should be in multibyte
3237 form. If NCHARS_RETRUN is not NULL, store the number of produced
3238 characters in *NCHARS_RETURN. */
3241 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3242 int multibyte
, EMACS_INT
*nchars_return
)
3244 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3247 unsigned long value
;
3248 EMACS_INT nchars
= 0;
3252 /* Process first byte of a quadruplet. */
3254 READ_QUADRUPLET_BYTE (e
-to
);
3258 value
= base64_char_to_value
[c
] << 18;
3260 /* Process second byte of a quadruplet. */
3262 READ_QUADRUPLET_BYTE (-1);
3266 value
|= base64_char_to_value
[c
] << 12;
3268 c
= (unsigned char) (value
>> 16);
3269 if (multibyte
&& c
>= 128)
3270 e
+= BYTE8_STRING (c
, e
);
3275 /* Process third byte of a quadruplet. */
3277 READ_QUADRUPLET_BYTE (-1);
3281 READ_QUADRUPLET_BYTE (-1);
3290 value
|= base64_char_to_value
[c
] << 6;
3292 c
= (unsigned char) (0xff & value
>> 8);
3293 if (multibyte
&& c
>= 128)
3294 e
+= BYTE8_STRING (c
, e
);
3299 /* Process fourth byte of a quadruplet. */
3301 READ_QUADRUPLET_BYTE (-1);
3308 value
|= base64_char_to_value
[c
];
3310 c
= (unsigned char) (0xff & value
);
3311 if (multibyte
&& c
>= 128)
3312 e
+= BYTE8_STRING (c
, e
);
3321 /***********************************************************************
3323 ***** Hash Tables *****
3325 ***********************************************************************/
3327 /* Implemented by gerd@gnu.org. This hash table implementation was
3328 inspired by CMUCL hash tables. */
3332 1. For small tables, association lists are probably faster than
3333 hash tables because they have lower overhead.
3335 For uses of hash tables where the O(1) behavior of table
3336 operations is not a requirement, it might therefore be a good idea
3337 not to hash. Instead, we could just do a linear search in the
3338 key_and_value vector of the hash table. This could be done
3339 if a `:linear-search t' argument is given to make-hash-table. */
3342 /* The list of all weak hash tables. Don't staticpro this one. */
3344 static struct Lisp_Hash_Table
*weak_hash_tables
;
3346 /* Various symbols. */
3348 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3349 Lisp_Object Qeq
, Qeql
, Qequal
;
3350 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3351 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3353 /* Function prototypes. */
3355 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3356 static size_t get_key_arg (Lisp_Object
, size_t, Lisp_Object
*, char *);
3357 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3358 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3362 /***********************************************************************
3364 ***********************************************************************/
3366 /* If OBJ is a Lisp hash table, return a pointer to its struct
3367 Lisp_Hash_Table. Otherwise, signal an error. */
3369 static struct Lisp_Hash_Table
*
3370 check_hash_table (Lisp_Object obj
)
3372 CHECK_HASH_TABLE (obj
);
3373 return XHASH_TABLE (obj
);
3377 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3381 next_almost_prime (EMACS_INT n
)
3393 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3394 which USED[I] is non-zero. If found at index I in ARGS, set
3395 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3396 0. This function is used to extract a keyword/argument pair from
3397 a DEFUN parameter list. */
3400 get_key_arg (Lisp_Object key
, size_t nargs
, Lisp_Object
*args
, char *used
)
3404 for (i
= 1; i
< nargs
; i
++)
3405 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3416 /* Return a Lisp vector which has the same contents as VEC but has
3417 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3418 vector that are not copied from VEC are set to INIT. */
3421 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3423 struct Lisp_Vector
*v
;
3424 EMACS_INT i
, old_size
;
3426 xassert (VECTORP (vec
));
3427 old_size
= ASIZE (vec
);
3428 xassert (new_size
>= old_size
);
3430 v
= allocate_vector (new_size
);
3431 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3432 for (i
= old_size
; i
< new_size
; ++i
)
3433 v
->contents
[i
] = init
;
3434 XSETVECTOR (vec
, v
);
3439 /***********************************************************************
3441 ***********************************************************************/
3443 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3444 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3445 KEY2 are the same. */
3448 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3449 Lisp_Object key1
, EMACS_UINT hash1
,
3450 Lisp_Object key2
, EMACS_UINT hash2
)
3452 return (FLOATP (key1
)
3454 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3458 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3459 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3460 KEY2 are the same. */
3463 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3464 Lisp_Object key1
, EMACS_UINT hash1
,
3465 Lisp_Object key2
, EMACS_UINT hash2
)
3467 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3471 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3472 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3473 if KEY1 and KEY2 are the same. */
3476 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3477 Lisp_Object key1
, EMACS_UINT hash1
,
3478 Lisp_Object key2
, EMACS_UINT hash2
)
3482 Lisp_Object args
[3];
3484 args
[0] = h
->user_cmp_function
;
3487 return !NILP (Ffuncall (3, args
));
3494 /* Value is a hash code for KEY for use in hash table H which uses
3495 `eq' to compare keys. The hash code returned is guaranteed to fit
3496 in a Lisp integer. */
3499 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3501 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3502 xassert ((hash
& ~INTMASK
) == 0);
3507 /* Value is a hash code for KEY for use in hash table H which uses
3508 `eql' to compare keys. The hash code returned is guaranteed to fit
3509 in a Lisp integer. */
3512 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3516 hash
= sxhash (key
, 0);
3518 hash
= XUINT (key
) ^ XTYPE (key
);
3519 xassert ((hash
& ~INTMASK
) == 0);
3524 /* Value is a hash code for KEY for use in hash table H which uses
3525 `equal' to compare keys. The hash code returned is guaranteed to fit
3526 in a Lisp integer. */
3529 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3531 EMACS_UINT hash
= sxhash (key
, 0);
3532 xassert ((hash
& ~INTMASK
) == 0);
3537 /* Value is a hash code for KEY for use in hash table H which uses as
3538 user-defined function to compare keys. The hash code returned is
3539 guaranteed to fit in a Lisp integer. */
3542 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3544 Lisp_Object args
[2], hash
;
3546 args
[0] = h
->user_hash_function
;
3548 hash
= Ffuncall (2, args
);
3549 if (!INTEGERP (hash
))
3550 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3551 return XUINT (hash
);
3555 /* Create and initialize a new hash table.
3557 TEST specifies the test the hash table will use to compare keys.
3558 It must be either one of the predefined tests `eq', `eql' or
3559 `equal' or a symbol denoting a user-defined test named TEST with
3560 test and hash functions USER_TEST and USER_HASH.
3562 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3564 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3565 new size when it becomes full is computed by adding REHASH_SIZE to
3566 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3567 table's new size is computed by multiplying its old size with
3570 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3571 be resized when the ratio of (number of entries in the table) /
3572 (table size) is >= REHASH_THRESHOLD.
3574 WEAK specifies the weakness of the table. If non-nil, it must be
3575 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3578 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3579 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3580 Lisp_Object user_test
, Lisp_Object user_hash
)
3582 struct Lisp_Hash_Table
*h
;
3584 EMACS_INT index_size
, i
, sz
;
3587 /* Preconditions. */
3588 xassert (SYMBOLP (test
));
3589 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3590 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3591 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3592 xassert (FLOATP (rehash_threshold
)
3593 && 0 < XFLOAT_DATA (rehash_threshold
)
3594 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3596 if (XFASTINT (size
) == 0)
3597 size
= make_number (1);
3599 sz
= XFASTINT (size
);
3600 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3601 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3602 ? next_almost_prime (index_float
)
3603 : MOST_POSITIVE_FIXNUM
+ 1);
3604 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3605 error ("Hash table too large");
3607 /* Allocate a table and initialize it. */
3608 h
= allocate_hash_table ();
3610 /* Initialize hash table slots. */
3612 if (EQ (test
, Qeql
))
3614 h
->cmpfn
= cmpfn_eql
;
3615 h
->hashfn
= hashfn_eql
;
3617 else if (EQ (test
, Qeq
))
3620 h
->hashfn
= hashfn_eq
;
3622 else if (EQ (test
, Qequal
))
3624 h
->cmpfn
= cmpfn_equal
;
3625 h
->hashfn
= hashfn_equal
;
3629 h
->user_cmp_function
= user_test
;
3630 h
->user_hash_function
= user_hash
;
3631 h
->cmpfn
= cmpfn_user_defined
;
3632 h
->hashfn
= hashfn_user_defined
;
3636 h
->rehash_threshold
= rehash_threshold
;
3637 h
->rehash_size
= rehash_size
;
3639 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3640 h
->hash
= Fmake_vector (size
, Qnil
);
3641 h
->next
= Fmake_vector (size
, Qnil
);
3642 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3644 /* Set up the free list. */
3645 for (i
= 0; i
< sz
- 1; ++i
)
3646 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3647 h
->next_free
= make_number (0);
3649 XSET_HASH_TABLE (table
, h
);
3650 xassert (HASH_TABLE_P (table
));
3651 xassert (XHASH_TABLE (table
) == h
);
3653 /* Maybe add this hash table to the list of all weak hash tables. */
3655 h
->next_weak
= NULL
;
3658 h
->next_weak
= weak_hash_tables
;
3659 weak_hash_tables
= h
;
3666 /* Return a copy of hash table H1. Keys and values are not copied,
3667 only the table itself is. */
3670 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3673 struct Lisp_Hash_Table
*h2
;
3674 struct Lisp_Vector
*next
;
3676 h2
= allocate_hash_table ();
3677 next
= h2
->header
.next
.vector
;
3678 memcpy (h2
, h1
, sizeof *h2
);
3679 h2
->header
.next
.vector
= next
;
3680 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3681 h2
->hash
= Fcopy_sequence (h1
->hash
);
3682 h2
->next
= Fcopy_sequence (h1
->next
);
3683 h2
->index
= Fcopy_sequence (h1
->index
);
3684 XSET_HASH_TABLE (table
, h2
);
3686 /* Maybe add this hash table to the list of all weak hash tables. */
3687 if (!NILP (h2
->weak
))
3689 h2
->next_weak
= weak_hash_tables
;
3690 weak_hash_tables
= h2
;
3697 /* Resize hash table H if it's too full. If H cannot be resized
3698 because it's already too large, throw an error. */
3701 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3703 if (NILP (h
->next_free
))
3705 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3706 EMACS_INT i
, new_size
, index_size
;
3710 if (INTEGERP (h
->rehash_size
))
3711 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3714 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3715 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3717 new_size
= float_new_size
;
3718 if (new_size
<= old_size
)
3719 new_size
= old_size
+ 1;
3722 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3724 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3725 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3726 ? next_almost_prime (index_float
)
3727 : MOST_POSITIVE_FIXNUM
+ 1);
3728 nsize
= max (index_size
, 2 * new_size
);
3729 if (nsize
> MOST_POSITIVE_FIXNUM
)
3730 error ("Hash table too large to resize");
3732 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3733 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3734 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3735 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3737 /* Update the free list. Do it so that new entries are added at
3738 the end of the free list. This makes some operations like
3740 for (i
= old_size
; i
< new_size
- 1; ++i
)
3741 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3743 if (!NILP (h
->next_free
))
3745 Lisp_Object last
, next
;
3747 last
= h
->next_free
;
3748 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3752 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3755 XSETFASTINT (h
->next_free
, old_size
);
3758 for (i
= 0; i
< old_size
; ++i
)
3759 if (!NILP (HASH_HASH (h
, i
)))
3761 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3762 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3763 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3764 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3770 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3771 the hash code of KEY. Value is the index of the entry in H
3772 matching KEY, or -1 if not found. */
3775 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3777 EMACS_UINT hash_code
;
3778 EMACS_INT start_of_bucket
;
3781 hash_code
= h
->hashfn (h
, key
);
3785 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3786 idx
= HASH_INDEX (h
, start_of_bucket
);
3788 /* We need not gcpro idx since it's either an integer or nil. */
3791 EMACS_INT i
= XFASTINT (idx
);
3792 if (EQ (key
, HASH_KEY (h
, i
))
3794 && h
->cmpfn (h
, key
, hash_code
,
3795 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3797 idx
= HASH_NEXT (h
, i
);
3800 return NILP (idx
) ? -1 : XFASTINT (idx
);
3804 /* Put an entry into hash table H that associates KEY with VALUE.
3805 HASH is a previously computed hash code of KEY.
3806 Value is the index of the entry in H matching KEY. */
3809 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3812 EMACS_INT start_of_bucket
, i
;
3814 xassert ((hash
& ~INTMASK
) == 0);
3816 /* Increment count after resizing because resizing may fail. */
3817 maybe_resize_hash_table (h
);
3820 /* Store key/value in the key_and_value vector. */
3821 i
= XFASTINT (h
->next_free
);
3822 h
->next_free
= HASH_NEXT (h
, i
);
3823 HASH_KEY (h
, i
) = key
;
3824 HASH_VALUE (h
, i
) = value
;
3826 /* Remember its hash code. */
3827 HASH_HASH (h
, i
) = make_number (hash
);
3829 /* Add new entry to its collision chain. */
3830 start_of_bucket
= hash
% ASIZE (h
->index
);
3831 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3832 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3837 /* Remove the entry matching KEY from hash table H, if there is one. */
3840 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3842 EMACS_UINT hash_code
;
3843 EMACS_INT start_of_bucket
;
3844 Lisp_Object idx
, prev
;
3846 hash_code
= h
->hashfn (h
, key
);
3847 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3848 idx
= HASH_INDEX (h
, start_of_bucket
);
3851 /* We need not gcpro idx, prev since they're either integers or nil. */
3854 EMACS_INT i
= XFASTINT (idx
);
3856 if (EQ (key
, HASH_KEY (h
, i
))
3858 && h
->cmpfn (h
, key
, hash_code
,
3859 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3861 /* Take entry out of collision chain. */
3863 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3865 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3867 /* Clear slots in key_and_value and add the slots to
3869 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3870 HASH_NEXT (h
, i
) = h
->next_free
;
3871 h
->next_free
= make_number (i
);
3873 xassert (h
->count
>= 0);
3879 idx
= HASH_NEXT (h
, i
);
3885 /* Clear hash table H. */
3888 hash_clear (struct Lisp_Hash_Table
*h
)
3892 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3894 for (i
= 0; i
< size
; ++i
)
3896 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3897 HASH_KEY (h
, i
) = Qnil
;
3898 HASH_VALUE (h
, i
) = Qnil
;
3899 HASH_HASH (h
, i
) = Qnil
;
3902 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3903 ASET (h
->index
, i
, Qnil
);
3905 h
->next_free
= make_number (0);
3912 /************************************************************************
3914 ************************************************************************/
3917 init_weak_hash_tables (void)
3919 weak_hash_tables
= NULL
;
3922 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3923 entries from the table that don't survive the current GC.
3924 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3925 non-zero if anything was marked. */
3928 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3930 EMACS_INT bucket
, n
;
3933 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3936 for (bucket
= 0; bucket
< n
; ++bucket
)
3938 Lisp_Object idx
, next
, prev
;
3940 /* Follow collision chain, removing entries that
3941 don't survive this garbage collection. */
3943 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3945 EMACS_INT i
= XFASTINT (idx
);
3946 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3947 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3950 if (EQ (h
->weak
, Qkey
))
3951 remove_p
= !key_known_to_survive_p
;
3952 else if (EQ (h
->weak
, Qvalue
))
3953 remove_p
= !value_known_to_survive_p
;
3954 else if (EQ (h
->weak
, Qkey_or_value
))
3955 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3956 else if (EQ (h
->weak
, Qkey_and_value
))
3957 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3961 next
= HASH_NEXT (h
, i
);
3963 if (remove_entries_p
)
3967 /* Take out of collision chain. */
3969 HASH_INDEX (h
, bucket
) = next
;
3971 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3973 /* Add to free list. */
3974 HASH_NEXT (h
, i
) = h
->next_free
;
3977 /* Clear key, value, and hash. */
3978 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3979 HASH_HASH (h
, i
) = Qnil
;
3992 /* Make sure key and value survive. */
3993 if (!key_known_to_survive_p
)
3995 mark_object (HASH_KEY (h
, i
));
3999 if (!value_known_to_survive_p
)
4001 mark_object (HASH_VALUE (h
, i
));
4012 /* Remove elements from weak hash tables that don't survive the
4013 current garbage collection. Remove weak tables that don't survive
4014 from Vweak_hash_tables. Called from gc_sweep. */
4017 sweep_weak_hash_tables (void)
4019 struct Lisp_Hash_Table
*h
, *used
, *next
;
4022 /* Mark all keys and values that are in use. Keep on marking until
4023 there is no more change. This is necessary for cases like
4024 value-weak table A containing an entry X -> Y, where Y is used in a
4025 key-weak table B, Z -> Y. If B comes after A in the list of weak
4026 tables, X -> Y might be removed from A, although when looking at B
4027 one finds that it shouldn't. */
4031 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4033 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4034 marked
|= sweep_weak_table (h
, 0);
4039 /* Remove tables and entries that aren't used. */
4040 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4042 next
= h
->next_weak
;
4044 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4046 /* TABLE is marked as used. Sweep its contents. */
4048 sweep_weak_table (h
, 1);
4050 /* Add table to the list of used weak hash tables. */
4051 h
->next_weak
= used
;
4056 weak_hash_tables
= used
;
4061 /***********************************************************************
4062 Hash Code Computation
4063 ***********************************************************************/
4065 /* Maximum depth up to which to dive into Lisp structures. */
4067 #define SXHASH_MAX_DEPTH 3
4069 /* Maximum length up to which to take list and vector elements into
4072 #define SXHASH_MAX_LEN 7
4074 /* Combine two integers X and Y for hashing. The result might not fit
4075 into a Lisp integer. */
4077 #define SXHASH_COMBINE(X, Y) \
4078 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4081 /* Hash X, returning a value that fits into a Lisp integer. */
4082 #define SXHASH_REDUCE(X) \
4083 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4085 /* Return a hash for string PTR which has length LEN. The hash
4086 code returned is guaranteed to fit in a Lisp integer. */
4089 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4091 unsigned char *p
= ptr
;
4092 unsigned char *end
= p
+ len
;
4094 EMACS_UINT hash
= 0;
4101 hash
= SXHASH_COMBINE (hash
, c
);
4104 return SXHASH_REDUCE (hash
);
4107 /* Return a hash for the floating point value VAL. */
4110 sxhash_float (double val
)
4112 EMACS_UINT hash
= 0;
4114 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4115 + (sizeof val
% sizeof hash
!= 0))
4119 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4123 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4124 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4125 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4126 return SXHASH_REDUCE (hash
);
4129 /* Return a hash for list LIST. DEPTH is the current depth in the
4130 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4133 sxhash_list (Lisp_Object list
, int depth
)
4135 EMACS_UINT hash
= 0;
4138 if (depth
< SXHASH_MAX_DEPTH
)
4140 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4141 list
= XCDR (list
), ++i
)
4143 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4144 hash
= SXHASH_COMBINE (hash
, hash2
);
4149 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4150 hash
= SXHASH_COMBINE (hash
, hash2
);
4153 return SXHASH_REDUCE (hash
);
4157 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4158 the Lisp structure. */
4161 sxhash_vector (Lisp_Object vec
, int depth
)
4163 EMACS_UINT hash
= ASIZE (vec
);
4166 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4167 for (i
= 0; i
< n
; ++i
)
4169 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4170 hash
= SXHASH_COMBINE (hash
, hash2
);
4173 return SXHASH_REDUCE (hash
);
4176 /* Return a hash for bool-vector VECTOR. */
4179 sxhash_bool_vector (Lisp_Object vec
)
4181 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4184 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4185 for (i
= 0; i
< n
; ++i
)
4186 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4188 return SXHASH_REDUCE (hash
);
4192 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4193 structure. Value is an unsigned integer clipped to INTMASK. */
4196 sxhash (Lisp_Object obj
, int depth
)
4200 if (depth
> SXHASH_MAX_DEPTH
)
4203 switch (XTYPE (obj
))
4214 obj
= SYMBOL_NAME (obj
);
4218 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4221 /* This can be everything from a vector to an overlay. */
4222 case Lisp_Vectorlike
:
4224 /* According to the CL HyperSpec, two arrays are equal only if
4225 they are `eq', except for strings and bit-vectors. In
4226 Emacs, this works differently. We have to compare element
4228 hash
= sxhash_vector (obj
, depth
);
4229 else if (BOOL_VECTOR_P (obj
))
4230 hash
= sxhash_bool_vector (obj
);
4232 /* Others are `equal' if they are `eq', so let's take their
4238 hash
= sxhash_list (obj
, depth
);
4242 hash
= sxhash_float (XFLOAT_DATA (obj
));
4254 /***********************************************************************
4256 ***********************************************************************/
4259 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4260 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4263 EMACS_UINT hash
= sxhash (obj
, 0);
4264 return make_number (hash
);
4268 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4269 doc
: /* Create and return a new hash table.
4271 Arguments are specified as keyword/argument pairs. The following
4272 arguments are defined:
4274 :test TEST -- TEST must be a symbol that specifies how to compare
4275 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4276 `equal'. User-supplied test and hash functions can be specified via
4277 `define-hash-table-test'.
4279 :size SIZE -- A hint as to how many elements will be put in the table.
4282 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4283 fills up. If REHASH-SIZE is an integer, increase the size by that
4284 amount. If it is a float, it must be > 1.0, and the new size is the
4285 old size multiplied by that factor. Default is 1.5.
4287 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4288 Resize the hash table when the ratio (number of entries / table size)
4289 is greater than or equal to THRESHOLD. Default is 0.8.
4291 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4292 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4293 returned is a weak table. Key/value pairs are removed from a weak
4294 hash table when there are no non-weak references pointing to their
4295 key, value, one of key or value, or both key and value, depending on
4296 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4299 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4300 (size_t nargs
, Lisp_Object
*args
)
4302 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4303 Lisp_Object user_test
, user_hash
;
4307 /* The vector `used' is used to keep track of arguments that
4308 have been consumed. */
4309 used
= (char *) alloca (nargs
* sizeof *used
);
4310 memset (used
, 0, nargs
* sizeof *used
);
4312 /* See if there's a `:test TEST' among the arguments. */
4313 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4314 test
= i
? args
[i
] : Qeql
;
4315 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4317 /* See if it is a user-defined test. */
4320 prop
= Fget (test
, Qhash_table_test
);
4321 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4322 signal_error ("Invalid hash table test", test
);
4323 user_test
= XCAR (prop
);
4324 user_hash
= XCAR (XCDR (prop
));
4327 user_test
= user_hash
= Qnil
;
4329 /* See if there's a `:size SIZE' argument. */
4330 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4331 size
= i
? args
[i
] : Qnil
;
4333 size
= make_number (DEFAULT_HASH_SIZE
);
4334 else if (!INTEGERP (size
) || XINT (size
) < 0)
4335 signal_error ("Invalid hash table size", size
);
4337 /* Look for `:rehash-size SIZE'. */
4338 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4339 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4340 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4341 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4342 signal_error ("Invalid hash table rehash size", rehash_size
);
4344 /* Look for `:rehash-threshold THRESHOLD'. */
4345 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4346 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4347 if (! (FLOATP (rehash_threshold
)
4348 && 0 < XFLOAT_DATA (rehash_threshold
)
4349 && XFLOAT_DATA (rehash_threshold
) <= 1))
4350 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4352 /* Look for `:weakness WEAK'. */
4353 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4354 weak
= i
? args
[i
] : Qnil
;
4356 weak
= Qkey_and_value
;
4359 && !EQ (weak
, Qvalue
)
4360 && !EQ (weak
, Qkey_or_value
)
4361 && !EQ (weak
, Qkey_and_value
))
4362 signal_error ("Invalid hash table weakness", weak
);
4364 /* Now, all args should have been used up, or there's a problem. */
4365 for (i
= 0; i
< nargs
; ++i
)
4367 signal_error ("Invalid argument list", args
[i
]);
4369 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4370 user_test
, user_hash
);
4374 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4375 doc
: /* Return a copy of hash table TABLE. */)
4378 return copy_hash_table (check_hash_table (table
));
4382 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4383 doc
: /* Return the number of elements in TABLE. */)
4386 return make_number (check_hash_table (table
)->count
);
4390 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4391 Shash_table_rehash_size
, 1, 1, 0,
4392 doc
: /* Return the current rehash size of TABLE. */)
4395 return check_hash_table (table
)->rehash_size
;
4399 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4400 Shash_table_rehash_threshold
, 1, 1, 0,
4401 doc
: /* Return the current rehash threshold of TABLE. */)
4404 return check_hash_table (table
)->rehash_threshold
;
4408 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4409 doc
: /* Return the size of TABLE.
4410 The size can be used as an argument to `make-hash-table' to create
4411 a hash table than can hold as many elements as TABLE holds
4412 without need for resizing. */)
4415 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4416 return make_number (HASH_TABLE_SIZE (h
));
4420 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4421 doc
: /* Return the test TABLE uses. */)
4424 return check_hash_table (table
)->test
;
4428 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4430 doc
: /* Return the weakness of TABLE. */)
4433 return check_hash_table (table
)->weak
;
4437 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4438 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4441 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4445 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4446 doc
: /* Clear hash table TABLE and return it. */)
4449 hash_clear (check_hash_table (table
));
4450 /* Be compatible with XEmacs. */
4455 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4456 doc
: /* Look up KEY in TABLE and return its associated value.
4457 If KEY is not found, return DFLT which defaults to nil. */)
4458 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4460 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4461 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4462 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4466 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4467 doc
: /* Associate KEY with VALUE in hash table TABLE.
4468 If KEY is already present in table, replace its current value with
4469 VALUE. In any case, return VALUE. */)
4470 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4472 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4476 i
= hash_lookup (h
, key
, &hash
);
4478 HASH_VALUE (h
, i
) = value
;
4480 hash_put (h
, key
, value
, hash
);
4486 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4487 doc
: /* Remove KEY from TABLE. */)
4488 (Lisp_Object key
, Lisp_Object table
)
4490 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4491 hash_remove_from_table (h
, key
);
4496 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4497 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4498 FUNCTION is called with two arguments, KEY and VALUE. */)
4499 (Lisp_Object function
, Lisp_Object table
)
4501 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4502 Lisp_Object args
[3];
4505 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4506 if (!NILP (HASH_HASH (h
, i
)))
4509 args
[1] = HASH_KEY (h
, i
);
4510 args
[2] = HASH_VALUE (h
, i
);
4518 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4519 Sdefine_hash_table_test
, 3, 3, 0,
4520 doc
: /* Define a new hash table test with name NAME, a symbol.
4522 In hash tables created with NAME specified as test, use TEST to
4523 compare keys, and HASH for computing hash codes of keys.
4525 TEST must be a function taking two arguments and returning non-nil if
4526 both arguments are the same. HASH must be a function taking one
4527 argument and return an integer that is the hash code of the argument.
4528 Hash code computation should use the whole value range of integers,
4529 including negative integers. */)
4530 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4532 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4537 /************************************************************************
4539 ************************************************************************/
4544 /* Convert a possibly-signed character to an unsigned character. This is
4545 a bit safer than casting to unsigned char, since it catches some type
4546 errors that the cast doesn't. */
4547 static inline unsigned char to_uchar (char ch
) { return ch
; }
4549 /* TYPE: 0 for md5, 1 for sha1. */
4552 crypto_hash_function (int type
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4556 EMACS_INT size_byte
= 0;
4557 EMACS_INT start_char
= 0, end_char
= 0;
4558 EMACS_INT start_byte
= 0, end_byte
= 0;
4559 register EMACS_INT b
, e
;
4560 register struct buffer
*bp
;
4562 Lisp_Object res
=Qnil
;
4564 if (STRINGP (object
))
4566 if (NILP (coding_system
))
4568 /* Decide the coding-system to encode the data with. */
4570 if (STRING_MULTIBYTE (object
))
4571 /* use default, we can't guess correct value */
4572 coding_system
= preferred_coding_system ();
4574 coding_system
= Qraw_text
;
4577 if (NILP (Fcoding_system_p (coding_system
)))
4579 /* Invalid coding system. */
4581 if (!NILP (noerror
))
4582 coding_system
= Qraw_text
;
4584 xsignal1 (Qcoding_system_error
, coding_system
);
4587 if (STRING_MULTIBYTE (object
))
4588 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4590 size
= SCHARS (object
);
4591 size_byte
= SBYTES (object
);
4595 CHECK_NUMBER (start
);
4597 start_char
= XINT (start
);
4602 start_byte
= string_char_to_byte (object
, start_char
);
4608 end_byte
= size_byte
;
4614 end_char
= XINT (end
);
4619 end_byte
= string_char_to_byte (object
, end_char
);
4622 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4623 args_out_of_range_3 (object
, make_number (start_char
),
4624 make_number (end_char
));
4628 struct buffer
*prev
= current_buffer
;
4630 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4632 CHECK_BUFFER (object
);
4634 bp
= XBUFFER (object
);
4635 if (bp
!= current_buffer
)
4636 set_buffer_internal (bp
);
4642 CHECK_NUMBER_COERCE_MARKER (start
);
4650 CHECK_NUMBER_COERCE_MARKER (end
);
4655 temp
= b
, b
= e
, e
= temp
;
4657 if (!(BEGV
<= b
&& e
<= ZV
))
4658 args_out_of_range (start
, end
);
4660 if (NILP (coding_system
))
4662 /* Decide the coding-system to encode the data with.
4663 See fileio.c:Fwrite-region */
4665 if (!NILP (Vcoding_system_for_write
))
4666 coding_system
= Vcoding_system_for_write
;
4669 int force_raw_text
= 0;
4671 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4672 if (NILP (coding_system
)
4673 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4675 coding_system
= Qnil
;
4676 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4680 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4682 /* Check file-coding-system-alist. */
4683 Lisp_Object args
[4], val
;
4685 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4686 args
[3] = Fbuffer_file_name(object
);
4687 val
= Ffind_operation_coding_system (4, args
);
4688 if (CONSP (val
) && !NILP (XCDR (val
)))
4689 coding_system
= XCDR (val
);
4692 if (NILP (coding_system
)
4693 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4695 /* If we still have not decided a coding system, use the
4696 default value of buffer-file-coding-system. */
4697 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4701 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4702 /* Confirm that VAL can surely encode the current region. */
4703 coding_system
= call4 (Vselect_safe_coding_system_function
,
4704 make_number (b
), make_number (e
),
4705 coding_system
, Qnil
);
4708 coding_system
= Qraw_text
;
4711 if (NILP (Fcoding_system_p (coding_system
)))
4713 /* Invalid coding system. */
4715 if (!NILP (noerror
))
4716 coding_system
= Qraw_text
;
4718 xsignal1 (Qcoding_system_error
, coding_system
);
4722 object
= make_buffer_string (b
, e
, 0);
4723 if (prev
!= current_buffer
)
4724 set_buffer_internal (prev
);
4725 /* Discard the unwind protect for recovering the current
4729 if (STRING_MULTIBYTE (object
))
4730 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4738 md5_buffer (SSDATA (object
) + start_byte
,
4739 SBYTES (object
) - (size_byte
- end_byte
),
4745 for (i
= 0; i
< 16; i
++)
4746 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4747 res
= make_string (value
, 32);
4750 res
= make_string (digest
, 16);
4757 sha1_buffer (SSDATA (object
) + start_byte
,
4758 SBYTES (object
) - (size_byte
- end_byte
),
4763 for (i
= 0; i
< 20; i
++)
4764 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4765 res
= make_string (value
, 40);
4768 res
= make_string (digest
, 20);
4776 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4777 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4779 A message digest is a cryptographic checksum of a document, and the
4780 algorithm to calculate it is defined in RFC 1321.
4782 The two optional arguments START and END are character positions
4783 specifying for which part of OBJECT the message digest should be
4784 computed. If nil or omitted, the digest is computed for the whole
4787 The MD5 message digest is computed from the result of encoding the
4788 text in a coding system, not directly from the internal Emacs form of
4789 the text. The optional fourth argument CODING-SYSTEM specifies which
4790 coding system to encode the text with. It should be the same coding
4791 system that you used or will use when actually writing the text into a
4794 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4795 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4796 system would be chosen by default for writing this text into a file.
4798 If OBJECT is a string, the most preferred coding system (see the
4799 command `prefer-coding-system') is used.
4801 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4802 guesswork fails. Normally, an error is signaled in such case. */)
4803 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4805 return crypto_hash_function (0, object
, start
, end
, coding_system
, noerror
, Qnil
);
4808 DEFUN ("sha1", Fsha1
, Ssha1
, 1, 4, 0,
4809 doc
: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
4811 OBJECT is either a string or a buffer. Optional arguments START and
4812 END are character positions specifying which portion of OBJECT for
4813 computing the hash. If BINARY is non-nil, return a string in binary
4815 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4817 return crypto_hash_function (1, object
, start
, end
, Qnil
, Qnil
, binary
);
4824 /* Hash table stuff. */
4825 Qhash_table_p
= intern_c_string ("hash-table-p");
4826 staticpro (&Qhash_table_p
);
4827 Qeq
= intern_c_string ("eq");
4829 Qeql
= intern_c_string ("eql");
4831 Qequal
= intern_c_string ("equal");
4832 staticpro (&Qequal
);
4833 QCtest
= intern_c_string (":test");
4834 staticpro (&QCtest
);
4835 QCsize
= intern_c_string (":size");
4836 staticpro (&QCsize
);
4837 QCrehash_size
= intern_c_string (":rehash-size");
4838 staticpro (&QCrehash_size
);
4839 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4840 staticpro (&QCrehash_threshold
);
4841 QCweakness
= intern_c_string (":weakness");
4842 staticpro (&QCweakness
);
4843 Qkey
= intern_c_string ("key");
4845 Qvalue
= intern_c_string ("value");
4846 staticpro (&Qvalue
);
4847 Qhash_table_test
= intern_c_string ("hash-table-test");
4848 staticpro (&Qhash_table_test
);
4849 Qkey_or_value
= intern_c_string ("key-or-value");
4850 staticpro (&Qkey_or_value
);
4851 Qkey_and_value
= intern_c_string ("key-and-value");
4852 staticpro (&Qkey_and_value
);
4855 defsubr (&Smake_hash_table
);
4856 defsubr (&Scopy_hash_table
);
4857 defsubr (&Shash_table_count
);
4858 defsubr (&Shash_table_rehash_size
);
4859 defsubr (&Shash_table_rehash_threshold
);
4860 defsubr (&Shash_table_size
);
4861 defsubr (&Shash_table_test
);
4862 defsubr (&Shash_table_weakness
);
4863 defsubr (&Shash_table_p
);
4864 defsubr (&Sclrhash
);
4865 defsubr (&Sgethash
);
4866 defsubr (&Sputhash
);
4867 defsubr (&Sremhash
);
4868 defsubr (&Smaphash
);
4869 defsubr (&Sdefine_hash_table_test
);
4871 Qstring_lessp
= intern_c_string ("string-lessp");
4872 staticpro (&Qstring_lessp
);
4873 Qprovide
= intern_c_string ("provide");
4874 staticpro (&Qprovide
);
4875 Qrequire
= intern_c_string ("require");
4876 staticpro (&Qrequire
);
4877 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4878 staticpro (&Qyes_or_no_p_history
);
4879 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4880 staticpro (&Qcursor_in_echo_area
);
4881 Qwidget_type
= intern_c_string ("widget-type");
4882 staticpro (&Qwidget_type
);
4884 staticpro (&string_char_byte_cache_string
);
4885 string_char_byte_cache_string
= Qnil
;
4887 require_nesting_list
= Qnil
;
4888 staticpro (&require_nesting_list
);
4890 Fset (Qyes_or_no_p_history
, Qnil
);
4892 DEFVAR_LISP ("features", Vfeatures
,
4893 doc
: /* A list of symbols which are the features of the executing Emacs.
4894 Used by `featurep' and `require', and altered by `provide'. */);
4895 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4896 Qsubfeatures
= intern_c_string ("subfeatures");
4897 staticpro (&Qsubfeatures
);
4899 #ifdef HAVE_LANGINFO_CODESET
4900 Qcodeset
= intern_c_string ("codeset");
4901 staticpro (&Qcodeset
);
4902 Qdays
= intern_c_string ("days");
4904 Qmonths
= intern_c_string ("months");
4905 staticpro (&Qmonths
);
4906 Qpaper
= intern_c_string ("paper");
4907 staticpro (&Qpaper
);
4908 #endif /* HAVE_LANGINFO_CODESET */
4910 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4911 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4912 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4913 invoked by mouse clicks and mouse menu items.
4915 On some platforms, file selection dialogs are also enabled if this is
4919 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4920 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4921 This applies to commands from menus and tool bar buttons even when
4922 they are initiated from the keyboard. If `use-dialog-box' is nil,
4923 that disables the use of a file dialog, regardless of the value of
4925 use_file_dialog
= 1;
4927 defsubr (&Sidentity
);
4930 defsubr (&Ssafe_length
);
4931 defsubr (&Sstring_bytes
);
4932 defsubr (&Sstring_equal
);
4933 defsubr (&Scompare_strings
);
4934 defsubr (&Sstring_lessp
);
4937 defsubr (&Svconcat
);
4938 defsubr (&Scopy_sequence
);
4939 defsubr (&Sstring_make_multibyte
);
4940 defsubr (&Sstring_make_unibyte
);
4941 defsubr (&Sstring_as_multibyte
);
4942 defsubr (&Sstring_as_unibyte
);
4943 defsubr (&Sstring_to_multibyte
);
4944 defsubr (&Sstring_to_unibyte
);
4945 defsubr (&Scopy_alist
);
4946 defsubr (&Ssubstring
);
4947 defsubr (&Ssubstring_no_properties
);
4960 defsubr (&Snreverse
);
4961 defsubr (&Sreverse
);
4963 defsubr (&Splist_get
);
4965 defsubr (&Splist_put
);
4967 defsubr (&Slax_plist_get
);
4968 defsubr (&Slax_plist_put
);
4971 defsubr (&Sequal_including_properties
);
4972 defsubr (&Sfillarray
);
4973 defsubr (&Sclear_string
);
4977 defsubr (&Smapconcat
);
4978 defsubr (&Syes_or_no_p
);
4979 defsubr (&Sload_average
);
4980 defsubr (&Sfeaturep
);
4981 defsubr (&Srequire
);
4982 defsubr (&Sprovide
);
4983 defsubr (&Splist_member
);
4984 defsubr (&Swidget_put
);
4985 defsubr (&Swidget_get
);
4986 defsubr (&Swidget_apply
);
4987 defsubr (&Sbase64_encode_region
);
4988 defsubr (&Sbase64_decode_region
);
4989 defsubr (&Sbase64_encode_string
);
4990 defsubr (&Sbase64_decode_string
);
4993 defsubr (&Slocale_info
);