1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 /* Note on some machines this defines `vector' as a typedef,
29 so make sure we don't use that name in this file. */
35 #include "character.h"
40 #include "intervals.h"
43 #include "blockinput.h"
45 #if defined (HAVE_X_WINDOWS)
47 #elif defined (MAC_OS)
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
79 extern long get_random ();
80 extern void seed_random
P_ ((long));
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer argument N, return random number in interval [0,N).
99 With argument t, set the random number seed from the current time and pid. */)
104 Lisp_Object lispy_val
;
105 unsigned long denominator
;
108 seed_random (getpid () + time (NULL
));
109 if (NATNUMP (n
) && XFASTINT (n
) != 0)
111 /* Try to take our random number from the higher bits of VAL,
112 not the lower, since (says Gentzel) the low bits of `random'
113 are less random than the higher ones. We do this by using the
114 quotient rather than the remainder. At the high end of the RNG
115 it's possible to get a quotient larger than n; discarding
116 these values eliminates the bias that would otherwise appear
117 when using a large n. */
118 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
120 val
= get_random () / denominator
;
121 while (val
>= XFASTINT (n
));
125 XSETINT (lispy_val
, val
);
129 /* Random data-structure functions */
131 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
132 doc
: /* Return the length of vector, list or string SEQUENCE.
133 A byte-code function object is also allowed.
134 If the string contains multibyte characters, this is not necessarily
135 the number of bytes in the string; it is the number of characters.
136 To get the number of bytes, use `string-bytes'. */)
138 register Lisp_Object sequence
;
140 register Lisp_Object val
;
143 if (STRINGP (sequence
))
144 XSETFASTINT (val
, SCHARS (sequence
));
145 else if (VECTORP (sequence
))
146 XSETFASTINT (val
, ASIZE (sequence
));
147 else if (CHAR_TABLE_P (sequence
))
148 XSETFASTINT (val
, MAX_CHAR
);
149 else if (BOOL_VECTOR_P (sequence
))
150 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
151 else if (COMPILEDP (sequence
))
152 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
153 else if (CONSP (sequence
))
156 while (CONSP (sequence
))
158 sequence
= XCDR (sequence
);
161 if (!CONSP (sequence
))
164 sequence
= XCDR (sequence
);
169 CHECK_LIST_END (sequence
, sequence
);
171 val
= make_number (i
);
173 else if (NILP (sequence
))
174 XSETFASTINT (val
, 0);
176 wrong_type_argument (Qsequencep
, sequence
);
181 /* This does not check for quits. That is safe since it must terminate. */
183 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
184 doc
: /* Return the length of a list, but avoid error or infinite loop.
185 This function never gets an error. If LIST is not really a list,
186 it returns 0. If LIST is circular, it returns a finite value
187 which is at least the number of distinct elements. */)
191 Lisp_Object tail
, halftail
, length
;
194 /* halftail is used to detect circular lists. */
196 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
198 if (EQ (tail
, halftail
) && len
!= 0)
202 halftail
= XCDR (halftail
);
205 XSETINT (length
, len
);
209 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
210 doc
: /* Return the number of bytes in STRING.
211 If STRING is multibyte, this may be greater than the length of STRING. */)
215 CHECK_STRING (string
);
216 return make_number (SBYTES (string
));
219 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
220 doc
: /* Return t if two strings have identical contents.
221 Case is significant, but text properties are ignored.
222 Symbols are also allowed; their print names are used instead. */)
224 register Lisp_Object s1
, s2
;
227 s1
= SYMBOL_NAME (s1
);
229 s2
= SYMBOL_NAME (s2
);
233 if (SCHARS (s1
) != SCHARS (s2
)
234 || SBYTES (s1
) != SBYTES (s2
)
235 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
240 DEFUN ("compare-strings", Fcompare_strings
,
241 Scompare_strings
, 6, 7, 0,
242 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
243 In string STR1, skip the first START1 characters and stop at END1.
244 In string STR2, skip the first START2 characters and stop at END2.
245 END1 and END2 default to the full lengths of the respective strings.
247 Case is significant in this comparison if IGNORE-CASE is nil.
248 Unibyte strings are converted to multibyte for comparison.
250 The value is t if the strings (or specified portions) match.
251 If string STR1 is less, the value is a negative number N;
252 - 1 - N is the number of characters that match at the beginning.
253 If string STR1 is greater, the value is a positive number N;
254 N - 1 is the number of characters that match at the beginning. */)
255 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
256 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
258 register int end1_char
, end2_char
;
259 register int i1
, i1_byte
, i2
, i2_byte
;
264 start1
= make_number (0);
266 start2
= make_number (0);
267 CHECK_NATNUM (start1
);
268 CHECK_NATNUM (start2
);
277 i1_byte
= string_char_to_byte (str1
, i1
);
278 i2_byte
= string_char_to_byte (str2
, i2
);
280 end1_char
= SCHARS (str1
);
281 if (! NILP (end1
) && end1_char
> XINT (end1
))
282 end1_char
= XINT (end1
);
284 end2_char
= SCHARS (str2
);
285 if (! NILP (end2
) && end2_char
> XINT (end2
))
286 end2_char
= XINT (end2
);
288 while (i1
< end1_char
&& i2
< end2_char
)
290 /* When we find a mismatch, we must compare the
291 characters, not just the bytes. */
294 if (STRING_MULTIBYTE (str1
))
295 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
298 c1
= SREF (str1
, i1
++);
299 c1
= unibyte_char_to_multibyte (c1
);
302 if (STRING_MULTIBYTE (str2
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
306 c2
= SREF (str2
, i2
++);
307 c2
= unibyte_char_to_multibyte (c2
);
313 if (! NILP (ignore_case
))
317 tem
= Fupcase (make_number (c1
));
319 tem
= Fupcase (make_number (c2
));
326 /* Note that I1 has already been incremented
327 past the character that we are comparing;
328 hence we don't add or subtract 1 here. */
330 return make_number (- i1
+ XINT (start1
));
332 return make_number (i1
- XINT (start1
));
336 return make_number (i1
- XINT (start1
) + 1);
338 return make_number (- i1
+ XINT (start1
) - 1);
343 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
344 doc
: /* Return t if first arg string is less than second in lexicographic order.
346 Symbols are also allowed; their print names are used instead. */)
348 register Lisp_Object s1
, s2
;
351 register int i1
, i1_byte
, i2
, i2_byte
;
354 s1
= SYMBOL_NAME (s1
);
356 s2
= SYMBOL_NAME (s2
);
360 i1
= i1_byte
= i2
= i2_byte
= 0;
363 if (end
> SCHARS (s2
))
368 /* When we find a mismatch, we must compare the
369 characters, not just the bytes. */
372 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
373 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
376 return c1
< c2
? Qt
: Qnil
;
378 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
382 /* "gcc -O3" enables automatic function inlining, which optimizes out
383 the arguments for the invocations of this function, whereas it
384 expects these values on the stack. */
385 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
386 #else /* !__GNUC__ */
387 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
399 return concat (2, args
, Lisp_String
, 0);
401 return concat (2, &s1
, Lisp_String
, 0);
402 #endif /* NO_ARG_ARRAY */
408 Lisp_Object s1
, s2
, s3
;
415 return concat (3, args
, Lisp_String
, 0);
417 return concat (3, &s1
, Lisp_String
, 0);
418 #endif /* NO_ARG_ARRAY */
421 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
422 doc
: /* Concatenate all the arguments and make the result a list.
423 The result is a list whose elements are the elements of all the arguments.
424 Each argument may be a list, vector or string.
425 The last argument is not copied, just used as the tail of the new list.
426 usage: (append &rest SEQUENCES) */)
431 return concat (nargs
, args
, Lisp_Cons
, 1);
434 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
435 doc
: /* Concatenate all the arguments and make the result a string.
436 The result is a string whose elements are the elements of all the arguments.
437 Each argument may be a string or a list or vector of characters (integers).
438 usage: (concat &rest SEQUENCES) */)
443 return concat (nargs
, args
, Lisp_String
, 0);
446 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
447 doc
: /* Concatenate all the arguments and make the result a vector.
448 The result is a vector whose elements are the elements of all the arguments.
449 Each argument may be a list, vector or string.
450 usage: (vconcat &rest SEQUENCES) */)
455 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
460 doc
: /* Return a copy of a list, vector, string or char-table.
461 The elements of a list or vector are not copied; they are shared
462 with the original. */)
466 if (NILP (arg
)) return arg
;
468 if (CHAR_TABLE_P (arg
))
470 return copy_char_table (arg
);
473 if (BOOL_VECTOR_P (arg
))
477 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
478 / BOOL_VECTOR_BITS_PER_CHAR
);
480 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
481 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
486 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
487 wrong_type_argument (Qsequencep
, arg
);
489 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
492 /* This structure holds information of an argument of `concat' that is
493 a string and has text properties to be copied. */
496 int argnum
; /* refer to ARGS (arguments of `concat') */
497 int from
; /* refer to ARGS[argnum] (argument string) */
498 int to
; /* refer to VAL (the target string) */
502 concat (nargs
, args
, target_type
, last_special
)
505 enum Lisp_Type target_type
;
509 register Lisp_Object tail
;
510 register Lisp_Object
this;
512 int toindex_byte
= 0;
513 register int result_len
;
514 register int result_len_byte
;
516 Lisp_Object last_tail
;
519 /* When we make a multibyte string, we can't copy text properties
520 while concatinating each string because the length of resulting
521 string can't be decided until we finish the whole concatination.
522 So, we record strings that have text properties to be copied
523 here, and copy the text properties after the concatination. */
524 struct textprop_rec
*textprops
= NULL
;
525 /* Number of elments in textprops. */
526 int num_textprops
= 0;
531 /* In append, the last arg isn't treated like the others */
532 if (last_special
&& nargs
> 0)
535 last_tail
= args
[nargs
];
540 /* Check each argument. */
541 for (argnum
= 0; argnum
< nargs
; argnum
++)
544 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
545 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
546 wrong_type_argument (Qsequencep
, this);
549 /* Compute total length in chars of arguments in RESULT_LEN.
550 If desired output is a string, also compute length in bytes
551 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
552 whether the result should be a multibyte string. */
556 for (argnum
= 0; argnum
< nargs
; argnum
++)
560 len
= XFASTINT (Flength (this));
561 if (target_type
== Lisp_String
)
563 /* We must count the number of bytes needed in the string
564 as well as the number of characters. */
570 for (i
= 0; i
< len
; i
++)
573 CHECK_CHARACTER (ch
);
574 this_len_byte
= CHAR_BYTES (XINT (ch
));
575 result_len_byte
+= this_len_byte
;
576 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
579 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
580 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
581 else if (CONSP (this))
582 for (; CONSP (this); this = XCDR (this))
585 CHECK_CHARACTER (ch
);
586 this_len_byte
= CHAR_BYTES (XINT (ch
));
587 result_len_byte
+= this_len_byte
;
588 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
591 else if (STRINGP (this))
593 if (STRING_MULTIBYTE (this))
596 result_len_byte
+= SBYTES (this);
599 result_len_byte
+= count_size_as_multibyte (SDATA (this),
607 if (! some_multibyte
)
608 result_len_byte
= result_len
;
610 /* Create the output object. */
611 if (target_type
== Lisp_Cons
)
612 val
= Fmake_list (make_number (result_len
), Qnil
);
613 else if (target_type
== Lisp_Vectorlike
)
614 val
= Fmake_vector (make_number (result_len
), Qnil
);
615 else if (some_multibyte
)
616 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
618 val
= make_uninit_string (result_len
);
620 /* In `append', if all but last arg are nil, return last arg. */
621 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
624 /* Copy the contents of the args into the result. */
626 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
628 toindex
= 0, toindex_byte
= 0;
632 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
634 for (argnum
= 0; argnum
< nargs
; argnum
++)
638 register unsigned int thisindex
= 0;
639 register unsigned int thisindex_byte
= 0;
643 thislen
= Flength (this), thisleni
= XINT (thislen
);
645 /* Between strings of the same kind, copy fast. */
646 if (STRINGP (this) && STRINGP (val
)
647 && STRING_MULTIBYTE (this) == some_multibyte
)
649 int thislen_byte
= SBYTES (this);
651 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
653 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
655 textprops
[num_textprops
].argnum
= argnum
;
656 textprops
[num_textprops
].from
= 0;
657 textprops
[num_textprops
++].to
= toindex
;
659 toindex_byte
+= thislen_byte
;
661 STRING_SET_CHARS (val
, SCHARS (val
));
663 /* Copy a single-byte string to a multibyte string. */
664 else if (STRINGP (this) && STRINGP (val
))
666 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
668 textprops
[num_textprops
].argnum
= argnum
;
669 textprops
[num_textprops
].from
= 0;
670 textprops
[num_textprops
++].to
= toindex
;
672 toindex_byte
+= copy_text (SDATA (this),
673 SDATA (val
) + toindex_byte
,
674 SCHARS (this), 0, 1);
678 /* Copy element by element. */
681 register Lisp_Object elt
;
683 /* Fetch next element of `this' arg into `elt', or break if
684 `this' is exhausted. */
685 if (NILP (this)) break;
687 elt
= XCAR (this), this = XCDR (this);
688 else if (thisindex
>= thisleni
)
690 else if (STRINGP (this))
693 if (STRING_MULTIBYTE (this))
695 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
698 XSETFASTINT (elt
, c
);
702 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
704 && XINT (elt
) >= 0200
705 && XINT (elt
) < 0400)
707 c
= unibyte_char_to_multibyte (XINT (elt
));
712 else if (BOOL_VECTOR_P (this))
715 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
716 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
724 elt
= AREF (this, thisindex
);
728 /* Store this element into the result. */
735 else if (VECTORP (val
))
737 ASET (val
, toindex
, elt
);
744 toindex_byte
+= CHAR_STRING (XINT (elt
),
745 SDATA (val
) + toindex_byte
);
747 SSET (val
, toindex_byte
++, XINT (elt
));
753 XSETCDR (prev
, last_tail
);
755 if (num_textprops
> 0)
758 int last_to_end
= -1;
760 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
762 this = args
[textprops
[argnum
].argnum
];
763 props
= text_property_list (this,
765 make_number (SCHARS (this)),
767 /* If successive arguments have properites, be sure that the
768 value of `composition' property be the copy. */
769 if (last_to_end
== textprops
[argnum
].to
)
770 make_composition_value_copy (props
);
771 add_text_properties_from_list (val
, props
,
772 make_number (textprops
[argnum
].to
));
773 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
781 static Lisp_Object string_char_byte_cache_string
;
782 static EMACS_INT string_char_byte_cache_charpos
;
783 static EMACS_INT string_char_byte_cache_bytepos
;
786 clear_string_char_byte_cache ()
788 string_char_byte_cache_string
= Qnil
;
791 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
794 string_char_to_byte (string
, char_index
)
796 EMACS_INT char_index
;
799 EMACS_INT best_below
, best_below_byte
;
800 EMACS_INT best_above
, best_above_byte
;
802 best_below
= best_below_byte
= 0;
803 best_above
= SCHARS (string
);
804 best_above_byte
= SBYTES (string
);
805 if (best_above
== best_above_byte
)
808 if (EQ (string
, string_char_byte_cache_string
))
810 if (string_char_byte_cache_charpos
< char_index
)
812 best_below
= string_char_byte_cache_charpos
;
813 best_below_byte
= string_char_byte_cache_bytepos
;
817 best_above
= string_char_byte_cache_charpos
;
818 best_above_byte
= string_char_byte_cache_bytepos
;
822 if (char_index
- best_below
< best_above
- char_index
)
824 unsigned char *p
= SDATA (string
) + best_below_byte
;
826 while (best_below
< char_index
)
828 p
+= BYTES_BY_CHAR_HEAD (*p
);
831 i_byte
= p
- SDATA (string
);
835 unsigned char *p
= SDATA (string
) + best_above_byte
;
837 while (best_above
> char_index
)
840 while (!CHAR_HEAD_P (*p
)) p
--;
843 i_byte
= p
- SDATA (string
);
846 string_char_byte_cache_bytepos
= i_byte
;
847 string_char_byte_cache_charpos
= char_index
;
848 string_char_byte_cache_string
= string
;
853 /* Return the character index corresponding to BYTE_INDEX in STRING. */
856 string_byte_to_char (string
, byte_index
)
858 EMACS_INT byte_index
;
861 EMACS_INT best_below
, best_below_byte
;
862 EMACS_INT best_above
, best_above_byte
;
864 best_below
= best_below_byte
= 0;
865 best_above
= SCHARS (string
);
866 best_above_byte
= SBYTES (string
);
867 if (best_above
== best_above_byte
)
870 if (EQ (string
, string_char_byte_cache_string
))
872 if (string_char_byte_cache_bytepos
< byte_index
)
874 best_below
= string_char_byte_cache_charpos
;
875 best_below_byte
= string_char_byte_cache_bytepos
;
879 best_above
= string_char_byte_cache_charpos
;
880 best_above_byte
= string_char_byte_cache_bytepos
;
884 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
886 unsigned char *p
= SDATA (string
) + best_below_byte
;
887 unsigned char *pend
= SDATA (string
) + byte_index
;
891 p
+= BYTES_BY_CHAR_HEAD (*p
);
895 i_byte
= p
- SDATA (string
);
899 unsigned char *p
= SDATA (string
) + best_above_byte
;
900 unsigned char *pbeg
= SDATA (string
) + byte_index
;
905 while (!CHAR_HEAD_P (*p
)) p
--;
909 i_byte
= p
- SDATA (string
);
912 string_char_byte_cache_bytepos
= i_byte
;
913 string_char_byte_cache_charpos
= i
;
914 string_char_byte_cache_string
= string
;
919 /* Convert STRING to a multibyte string. */
922 string_make_multibyte (string
)
930 if (STRING_MULTIBYTE (string
))
933 nbytes
= count_size_as_multibyte (SDATA (string
),
935 /* If all the chars are ASCII, they won't need any more bytes
936 once converted. In that case, we can return STRING itself. */
937 if (nbytes
== SBYTES (string
))
940 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
941 copy_text (SDATA (string
), buf
, SBYTES (string
),
944 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
951 /* Convert STRING (if unibyte) to a multibyte string without changing
952 the number of characters. Characters 0200 trough 0237 are
953 converted to eight-bit characters. */
956 string_to_multibyte (string
)
964 if (STRING_MULTIBYTE (string
))
967 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
968 /* If all the chars are ASCII, they won't need any more bytes once
970 if (nbytes
== SBYTES (string
))
971 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
973 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
974 bcopy (SDATA (string
), buf
, SBYTES (string
));
975 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
977 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
984 /* Convert STRING to a single-byte string. */
987 string_make_unibyte (string
)
995 if (! STRING_MULTIBYTE (string
))
998 nchars
= SCHARS (string
);
1000 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1001 copy_text (SDATA (string
), buf
, SBYTES (string
),
1004 ret
= make_unibyte_string (buf
, nchars
);
1010 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1012 doc
: /* Return the multibyte equivalent of STRING.
1013 If STRING is unibyte and contains non-ASCII characters, the function
1014 `unibyte-char-to-multibyte' is used to convert each unibyte character
1015 to a multibyte character. In this case, the returned string is a
1016 newly created string with no text properties. If STRING is multibyte
1017 or entirely ASCII, it is returned unchanged. In particular, when
1018 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1019 \(When the characters are all ASCII, Emacs primitives will treat the
1020 string the same way whether it is unibyte or multibyte.) */)
1024 CHECK_STRING (string
);
1026 return string_make_multibyte (string
);
1029 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1031 doc
: /* Return the unibyte equivalent of STRING.
1032 Multibyte character codes are converted to unibyte according to
1033 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1034 If the lookup in the translation table fails, this function takes just
1035 the low 8 bits of each character. */)
1039 CHECK_STRING (string
);
1041 return string_make_unibyte (string
);
1044 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1046 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1047 If STRING is unibyte, the result is STRING itself.
1048 Otherwise it is a newly created string, with no text properties.
1049 If STRING is multibyte and contains a character of charset
1050 `eight-bit', it is converted to the corresponding single byte. */)
1054 CHECK_STRING (string
);
1056 if (STRING_MULTIBYTE (string
))
1058 int bytes
= SBYTES (string
);
1059 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1061 bcopy (SDATA (string
), str
, bytes
);
1062 bytes
= str_as_unibyte (str
, bytes
);
1063 string
= make_unibyte_string (str
, bytes
);
1069 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1071 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1072 If STRING is multibyte, the result is STRING itself.
1073 Otherwise it is a newly created string, with no text properties.
1075 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1076 part of a correct utf-8 sequence), it is converted to the corresponding
1077 multibyte character of charset `eight-bit'.
1078 See also `string-to-multibyte'.
1080 Beware, this often doesn't really do what you think it does.
1081 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1082 If you're not sure, whether to use `string-as-multibyte' or
1083 `string-to-multibyte', use `string-to-multibyte'. */)
1087 CHECK_STRING (string
);
1089 if (! STRING_MULTIBYTE (string
))
1091 Lisp_Object new_string
;
1094 parse_str_as_multibyte (SDATA (string
),
1097 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1098 bcopy (SDATA (string
), SDATA (new_string
),
1100 if (nbytes
!= SBYTES (string
))
1101 str_as_multibyte (SDATA (new_string
), nbytes
,
1102 SBYTES (string
), NULL
);
1103 string
= new_string
;
1104 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1109 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1111 doc
: /* Return a multibyte string with the same individual chars as STRING.
1112 If STRING is multibyte, the result is STRING itself.
1113 Otherwise it is a newly created string, with no text properties.
1115 If STRING is unibyte and contains an 8-bit byte, it is converted to
1116 the corresponding multibyte character of charset `eight-bit'.
1118 This differs from `string-as-multibyte' by converting each byte of a correct
1119 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1120 correct sequence. */)
1124 CHECK_STRING (string
);
1126 return string_to_multibyte (string
);
1129 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1131 doc
: /* Return a unibyte string with the same individual chars as STRING.
1132 If STRING is unibyte, the result is STRING itself.
1133 Otherwise it is a newly created string, with no text properties,
1134 where each `eight-bit' character is converted to the corresponding byte.
1135 If STRING contains a non-ASCII, non-`eight-bit' character,
1136 an error is signaled. */)
1140 CHECK_STRING (string
);
1142 if (STRING_MULTIBYTE (string
))
1144 EMACS_INT chars
= SCHARS (string
);
1145 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1146 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1148 if (converted
< chars
)
1149 error ("Can't convert the %dth character to unibyte", converted
);
1150 string
= make_unibyte_string (str
, chars
);
1157 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1158 doc
: /* Return a copy of ALIST.
1159 This is an alist which represents the same mapping from objects to objects,
1160 but does not share the alist structure with ALIST.
1161 The objects mapped (cars and cdrs of elements of the alist)
1162 are shared, however.
1163 Elements of ALIST that are not conses are also shared. */)
1167 register Lisp_Object tem
;
1172 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1173 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1175 register Lisp_Object car
;
1179 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1184 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1185 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1186 TO may be nil or omitted; then the substring runs to the end of STRING.
1187 FROM and TO start at 0. If either is negative, it counts from the end.
1189 This function allows vectors as well as strings. */)
1192 register Lisp_Object from
, to
;
1197 int from_char
, to_char
;
1198 int from_byte
= 0, to_byte
= 0;
1200 CHECK_VECTOR_OR_STRING (string
);
1201 CHECK_NUMBER (from
);
1203 if (STRINGP (string
))
1205 size
= SCHARS (string
);
1206 size_byte
= SBYTES (string
);
1209 size
= ASIZE (string
);
1214 to_byte
= size_byte
;
1220 to_char
= XINT (to
);
1224 if (STRINGP (string
))
1225 to_byte
= string_char_to_byte (string
, to_char
);
1228 from_char
= XINT (from
);
1231 if (STRINGP (string
))
1232 from_byte
= string_char_to_byte (string
, from_char
);
1234 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1235 args_out_of_range_3 (string
, make_number (from_char
),
1236 make_number (to_char
));
1238 if (STRINGP (string
))
1240 res
= make_specified_string (SDATA (string
) + from_byte
,
1241 to_char
- from_char
, to_byte
- from_byte
,
1242 STRING_MULTIBYTE (string
));
1243 copy_text_properties (make_number (from_char
), make_number (to_char
),
1244 string
, make_number (0), res
, Qnil
);
1247 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1253 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1254 doc
: /* Return a substring of STRING, without text properties.
1255 It starts at index FROM and ending before TO.
1256 TO may be nil or omitted; then the substring runs to the end of STRING.
1257 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1258 If FROM or TO is negative, it counts from the end.
1260 With one argument, just copy STRING without its properties. */)
1263 register Lisp_Object from
, to
;
1265 int size
, size_byte
;
1266 int from_char
, to_char
;
1267 int from_byte
, to_byte
;
1269 CHECK_STRING (string
);
1271 size
= SCHARS (string
);
1272 size_byte
= SBYTES (string
);
1275 from_char
= from_byte
= 0;
1278 CHECK_NUMBER (from
);
1279 from_char
= XINT (from
);
1283 from_byte
= string_char_to_byte (string
, from_char
);
1289 to_byte
= size_byte
;
1295 to_char
= XINT (to
);
1299 to_byte
= string_char_to_byte (string
, to_char
);
1302 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1303 args_out_of_range_3 (string
, make_number (from_char
),
1304 make_number (to_char
));
1306 return make_specified_string (SDATA (string
) + from_byte
,
1307 to_char
- from_char
, to_byte
- from_byte
,
1308 STRING_MULTIBYTE (string
));
1311 /* Extract a substring of STRING, giving start and end positions
1312 both in characters and in bytes. */
1315 substring_both (string
, from
, from_byte
, to
, to_byte
)
1317 int from
, from_byte
, to
, to_byte
;
1323 CHECK_VECTOR_OR_STRING (string
);
1325 if (STRINGP (string
))
1327 size
= SCHARS (string
);
1328 size_byte
= SBYTES (string
);
1331 size
= ASIZE (string
);
1333 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1334 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1336 if (STRINGP (string
))
1338 res
= make_specified_string (SDATA (string
) + from_byte
,
1339 to
- from
, to_byte
- from_byte
,
1340 STRING_MULTIBYTE (string
));
1341 copy_text_properties (make_number (from
), make_number (to
),
1342 string
, make_number (0), res
, Qnil
);
1345 res
= Fvector (to
- from
, &AREF (string
, from
));
1350 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1351 doc
: /* Take cdr N times on LIST, returns the result. */)
1354 register Lisp_Object list
;
1356 register int i
, num
;
1359 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1362 CHECK_LIST_CONS (list
, list
);
1368 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1369 doc
: /* Return the Nth element of LIST.
1370 N counts from zero. If LIST is not that long, nil is returned. */)
1372 Lisp_Object n
, list
;
1374 return Fcar (Fnthcdr (n
, list
));
1377 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1378 doc
: /* Return element of SEQUENCE at index N. */)
1380 register Lisp_Object sequence
, n
;
1383 if (CONSP (sequence
) || NILP (sequence
))
1384 return Fcar (Fnthcdr (n
, sequence
));
1386 /* Faref signals a "not array" error, so check here. */
1387 CHECK_ARRAY (sequence
, Qsequencep
);
1388 return Faref (sequence
, n
);
1391 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1392 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1393 The value is actually the tail of LIST whose car is ELT. */)
1395 register Lisp_Object elt
;
1398 register Lisp_Object tail
;
1399 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1401 register Lisp_Object tem
;
1402 CHECK_LIST_CONS (tail
, list
);
1404 if (! NILP (Fequal (elt
, tem
)))
1411 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1412 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1413 The value is actually the tail of LIST whose car is ELT. */)
1415 register Lisp_Object elt
, list
;
1419 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1423 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1427 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1438 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1439 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1440 The value is actually the tail of LIST whose car is ELT. */)
1442 register Lisp_Object elt
;
1445 register Lisp_Object tail
;
1448 return Fmemq (elt
, list
);
1450 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1452 register Lisp_Object tem
;
1453 CHECK_LIST_CONS (tail
, list
);
1455 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1462 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1463 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1464 The value is actually the first element of LIST whose car is KEY.
1465 Elements of LIST that are not conses are ignored. */)
1467 Lisp_Object key
, list
;
1472 || (CONSP (XCAR (list
))
1473 && EQ (XCAR (XCAR (list
)), key
)))
1478 || (CONSP (XCAR (list
))
1479 && EQ (XCAR (XCAR (list
)), key
)))
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCAR (XCAR (list
)), key
)))
1495 /* Like Fassq but never report an error and do not allow quits.
1496 Use only on lists known never to be circular. */
1499 assq_no_quit (key
, list
)
1500 Lisp_Object key
, list
;
1503 && (!CONSP (XCAR (list
))
1504 || !EQ (XCAR (XCAR (list
)), key
)))
1507 return CAR_SAFE (list
);
1510 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1511 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1512 The value is actually the first element of LIST whose car equals KEY. */)
1514 Lisp_Object key
, list
;
1521 || (CONSP (XCAR (list
))
1522 && (car
= XCAR (XCAR (list
)),
1523 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1528 || (CONSP (XCAR (list
))
1529 && (car
= XCAR (XCAR (list
)),
1530 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1535 || (CONSP (XCAR (list
))
1536 && (car
= XCAR (XCAR (list
)),
1537 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1547 /* Like Fassoc but never report an error and do not allow quits.
1548 Use only on lists known never to be circular. */
1551 assoc_no_quit (key
, list
)
1552 Lisp_Object key
, list
;
1555 && (!CONSP (XCAR (list
))
1556 || (!EQ (XCAR (XCAR (list
)), key
)
1557 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1560 return CONSP (list
) ? XCAR (list
) : Qnil
;
1563 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1564 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1565 The value is actually the first element of LIST whose cdr is KEY. */)
1567 register Lisp_Object key
;
1573 || (CONSP (XCAR (list
))
1574 && EQ (XCDR (XCAR (list
)), key
)))
1579 || (CONSP (XCAR (list
))
1580 && EQ (XCDR (XCAR (list
)), key
)))
1585 || (CONSP (XCAR (list
))
1586 && EQ (XCDR (XCAR (list
)), key
)))
1596 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1597 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1598 The value is actually the first element of LIST whose cdr equals KEY. */)
1600 Lisp_Object key
, list
;
1607 || (CONSP (XCAR (list
))
1608 && (cdr
= XCDR (XCAR (list
)),
1609 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1614 || (CONSP (XCAR (list
))
1615 && (cdr
= XCDR (XCAR (list
)),
1616 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1621 || (CONSP (XCAR (list
))
1622 && (cdr
= XCDR (XCAR (list
)),
1623 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1633 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1634 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1635 The modified LIST is returned. Comparison is done with `eq'.
1636 If the first member of LIST is ELT, there is no way to remove it by side effect;
1637 therefore, write `(setq foo (delq element foo))'
1638 to be sure of changing the value of `foo'. */)
1640 register Lisp_Object elt
;
1643 register Lisp_Object tail
, prev
;
1644 register Lisp_Object tem
;
1648 while (!NILP (tail
))
1650 CHECK_LIST_CONS (tail
, list
);
1657 Fsetcdr (prev
, XCDR (tail
));
1667 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1668 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1669 SEQ must be a list, a vector, or a string.
1670 The modified SEQ is returned. Comparison is done with `equal'.
1671 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1672 is not a side effect; it is simply using a different sequence.
1673 Therefore, write `(setq foo (delete element foo))'
1674 to be sure of changing the value of `foo'. */)
1676 Lisp_Object elt
, seq
;
1682 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1683 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1686 if (n
!= ASIZE (seq
))
1688 struct Lisp_Vector
*p
= allocate_vector (n
);
1690 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1691 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1692 p
->contents
[n
++] = AREF (seq
, i
);
1694 XSETVECTOR (seq
, p
);
1697 else if (STRINGP (seq
))
1699 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1702 for (i
= nchars
= nbytes
= ibyte
= 0;
1704 ++i
, ibyte
+= cbytes
)
1706 if (STRING_MULTIBYTE (seq
))
1708 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1709 SBYTES (seq
) - ibyte
);
1710 cbytes
= CHAR_BYTES (c
);
1718 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1725 if (nchars
!= SCHARS (seq
))
1729 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1730 if (!STRING_MULTIBYTE (seq
))
1731 STRING_SET_UNIBYTE (tem
);
1733 for (i
= nchars
= nbytes
= ibyte
= 0;
1735 ++i
, ibyte
+= cbytes
)
1737 if (STRING_MULTIBYTE (seq
))
1739 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1740 SBYTES (seq
) - ibyte
);
1741 cbytes
= CHAR_BYTES (c
);
1749 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1751 unsigned char *from
= SDATA (seq
) + ibyte
;
1752 unsigned char *to
= SDATA (tem
) + nbytes
;
1758 for (n
= cbytes
; n
--; )
1768 Lisp_Object tail
, prev
;
1770 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1772 CHECK_LIST_CONS (tail
, seq
);
1774 if (!NILP (Fequal (elt
, XCAR (tail
))))
1779 Fsetcdr (prev
, XCDR (tail
));
1790 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1791 doc
: /* Reverse LIST by modifying cdr pointers.
1792 Return the reversed list. */)
1796 register Lisp_Object prev
, tail
, next
;
1798 if (NILP (list
)) return list
;
1801 while (!NILP (tail
))
1804 CHECK_LIST_CONS (tail
, list
);
1806 Fsetcdr (tail
, prev
);
1813 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1814 doc
: /* Reverse LIST, copying. Return the reversed list.
1815 See also the function `nreverse', which is used more often. */)
1821 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1824 new = Fcons (XCAR (list
), new);
1826 CHECK_LIST_END (list
, list
);
1830 Lisp_Object
merge ();
1832 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1833 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1834 Returns the sorted list. LIST is modified by side effects.
1835 PREDICATE is called with two elements of LIST, and should return non-nil
1836 if the first element should sort before the second. */)
1838 Lisp_Object list
, predicate
;
1840 Lisp_Object front
, back
;
1841 register Lisp_Object len
, tem
;
1842 struct gcpro gcpro1
, gcpro2
;
1843 register int length
;
1846 len
= Flength (list
);
1847 length
= XINT (len
);
1851 XSETINT (len
, (length
/ 2) - 1);
1852 tem
= Fnthcdr (len
, list
);
1854 Fsetcdr (tem
, Qnil
);
1856 GCPRO2 (front
, back
);
1857 front
= Fsort (front
, predicate
);
1858 back
= Fsort (back
, predicate
);
1860 return merge (front
, back
, predicate
);
1864 merge (org_l1
, org_l2
, pred
)
1865 Lisp_Object org_l1
, org_l2
;
1869 register Lisp_Object tail
;
1871 register Lisp_Object l1
, l2
;
1872 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1879 /* It is sufficient to protect org_l1 and org_l2.
1880 When l1 and l2 are updated, we copy the new values
1881 back into the org_ vars. */
1882 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1902 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1918 Fsetcdr (tail
, tem
);
1924 #if 0 /* Unsafe version. */
1925 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1926 doc
: /* Extract a value from a property list.
1927 PLIST is a property list, which is a list of the form
1928 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1929 corresponding to the given PROP, or nil if PROP is not
1930 one of the properties on the list. */)
1938 CONSP (tail
) && CONSP (XCDR (tail
));
1939 tail
= XCDR (XCDR (tail
)))
1941 if (EQ (prop
, XCAR (tail
)))
1942 return XCAR (XCDR (tail
));
1944 /* This function can be called asynchronously
1945 (setup_coding_system). Don't QUIT in that case. */
1946 if (!interrupt_input_blocked
)
1950 CHECK_LIST_END (tail
, prop
);
1956 /* This does not check for quits. That is safe since it must terminate. */
1958 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1959 doc
: /* Extract a value from a property list.
1960 PLIST is a property list, which is a list of the form
1961 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1962 corresponding to the given PROP, or nil if PROP is not one of the
1963 properties on the list. This function never signals an error. */)
1968 Lisp_Object tail
, halftail
;
1970 /* halftail is used to detect circular lists. */
1971 tail
= halftail
= plist
;
1972 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1974 if (EQ (prop
, XCAR (tail
)))
1975 return XCAR (XCDR (tail
));
1977 tail
= XCDR (XCDR (tail
));
1978 halftail
= XCDR (halftail
);
1979 if (EQ (tail
, halftail
))
1986 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1987 doc
: /* Return the value of SYMBOL's PROPNAME property.
1988 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1990 Lisp_Object symbol
, propname
;
1992 CHECK_SYMBOL (symbol
);
1993 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1996 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1997 doc
: /* Change value in PLIST of PROP to VAL.
1998 PLIST is a property list, which is a list of the form
1999 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2000 If PROP is already a property on the list, its value is set to VAL,
2001 otherwise the new PROP VAL pair is added. The new plist is returned;
2002 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2003 The PLIST is modified by side effects. */)
2006 register Lisp_Object prop
;
2009 register Lisp_Object tail
, prev
;
2010 Lisp_Object newcell
;
2012 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2013 tail
= XCDR (XCDR (tail
)))
2015 if (EQ (prop
, XCAR (tail
)))
2017 Fsetcar (XCDR (tail
), val
);
2024 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2028 Fsetcdr (XCDR (prev
), newcell
);
2032 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2033 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2034 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2035 (symbol
, propname
, value
)
2036 Lisp_Object symbol
, propname
, value
;
2038 CHECK_SYMBOL (symbol
);
2039 XSYMBOL (symbol
)->plist
2040 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2044 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2045 doc
: /* Extract a value from a property list, comparing with `equal'.
2046 PLIST is a property list, which is a list of the form
2047 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2048 corresponding to the given PROP, or nil if PROP is not
2049 one of the properties on the list. */)
2057 CONSP (tail
) && CONSP (XCDR (tail
));
2058 tail
= XCDR (XCDR (tail
)))
2060 if (! NILP (Fequal (prop
, XCAR (tail
))))
2061 return XCAR (XCDR (tail
));
2066 CHECK_LIST_END (tail
, prop
);
2071 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2072 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2073 PLIST is a property list, which is a list of the form
2074 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2075 If PROP is already a property on the list, its value is set to VAL,
2076 otherwise the new PROP VAL pair is added. The new plist is returned;
2077 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2078 The PLIST is modified by side effects. */)
2081 register Lisp_Object prop
;
2084 register Lisp_Object tail
, prev
;
2085 Lisp_Object newcell
;
2087 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2088 tail
= XCDR (XCDR (tail
)))
2090 if (! NILP (Fequal (prop
, XCAR (tail
))))
2092 Fsetcar (XCDR (tail
), val
);
2099 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2103 Fsetcdr (XCDR (prev
), newcell
);
2107 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2108 doc
: /* Return t if the two args are the same Lisp object.
2109 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2111 Lisp_Object obj1
, obj2
;
2114 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2116 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2119 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2120 doc
: /* Return t if two Lisp objects have similar structure and contents.
2121 They must have the same data type.
2122 Conses are compared by comparing the cars and the cdrs.
2123 Vectors and strings are compared element by element.
2124 Numbers are compared by value, but integers cannot equal floats.
2125 (Use `=' if you want integers and floats to be able to be equal.)
2126 Symbols must match exactly. */)
2128 register Lisp_Object o1
, o2
;
2130 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2133 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2134 doc
: /* Return t if two Lisp objects have similar structure and contents.
2135 This is like `equal' except that it compares the text properties
2136 of strings. (`equal' ignores text properties.) */)
2138 register Lisp_Object o1
, o2
;
2140 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2143 /* DEPTH is current depth of recursion. Signal an error if it
2145 PROPS, if non-nil, means compare string text properties too. */
2148 internal_equal (o1
, o2
, depth
, props
)
2149 register Lisp_Object o1
, o2
;
2153 error ("Stack overflow in equal");
2159 if (XTYPE (o1
) != XTYPE (o2
))
2168 d1
= extract_float (o1
);
2169 d2
= extract_float (o2
);
2170 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2171 though they are not =. */
2172 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2176 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2183 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2187 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2189 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2192 o1
= XOVERLAY (o1
)->plist
;
2193 o2
= XOVERLAY (o2
)->plist
;
2198 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2199 && (XMARKER (o1
)->buffer
== 0
2200 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2204 case Lisp_Vectorlike
:
2207 EMACS_INT size
= ASIZE (o1
);
2208 /* Pseudovectors have the type encoded in the size field, so this test
2209 actually checks that the objects have the same type as well as the
2211 if (ASIZE (o2
) != size
)
2213 /* Boolvectors are compared much like strings. */
2214 if (BOOL_VECTOR_P (o1
))
2217 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2218 / BOOL_VECTOR_BITS_PER_CHAR
);
2220 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2222 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2227 if (WINDOW_CONFIGURATIONP (o1
))
2228 return compare_window_configurations (o1
, o2
, 0);
2230 /* Aside from them, only true vectors, char-tables, compiled
2231 functions, and fonts (font-spec, font-entity, font-ojbect)
2232 are sensible to compare, so eliminate the others now. */
2233 if (size
& PSEUDOVECTOR_FLAG
)
2235 if (!(size
& (PVEC_COMPILED
2236 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2238 size
&= PSEUDOVECTOR_SIZE_MASK
;
2240 for (i
= 0; i
< size
; i
++)
2245 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2253 if (SCHARS (o1
) != SCHARS (o2
))
2255 if (SBYTES (o1
) != SBYTES (o2
))
2257 if (bcmp (SDATA (o1
), SDATA (o2
),
2260 if (props
&& !compare_string_intervals (o1
, o2
))
2266 case Lisp_Type_Limit
:
2273 extern Lisp_Object
Fmake_char_internal ();
2275 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2276 doc
: /* Store each element of ARRAY with ITEM.
2277 ARRAY is a vector, string, char-table, or bool-vector. */)
2279 Lisp_Object array
, item
;
2281 register int size
, index
, charval
;
2282 if (VECTORP (array
))
2284 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2285 size
= ASIZE (array
);
2286 for (index
= 0; index
< size
; index
++)
2289 else if (CHAR_TABLE_P (array
))
2293 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2294 XCHAR_TABLE (array
)->contents
[i
] = item
;
2295 XCHAR_TABLE (array
)->defalt
= item
;
2297 else if (STRINGP (array
))
2299 register unsigned char *p
= SDATA (array
);
2300 CHECK_NUMBER (item
);
2301 charval
= XINT (item
);
2302 size
= SCHARS (array
);
2303 if (STRING_MULTIBYTE (array
))
2305 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2306 int len
= CHAR_STRING (charval
, str
);
2307 int size_byte
= SBYTES (array
);
2308 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2311 if (size
!= size_byte
)
2314 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2315 if (len
!= this_len
)
2316 error ("Attempt to change byte length of a string");
2319 for (i
= 0; i
< size_byte
; i
++)
2320 *p
++ = str
[i
% len
];
2323 for (index
= 0; index
< size
; index
++)
2326 else if (BOOL_VECTOR_P (array
))
2328 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2330 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2331 / BOOL_VECTOR_BITS_PER_CHAR
);
2333 charval
= (! NILP (item
) ? -1 : 0);
2334 for (index
= 0; index
< size_in_chars
- 1; index
++)
2336 if (index
< size_in_chars
)
2338 /* Mask out bits beyond the vector size. */
2339 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2340 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2345 wrong_type_argument (Qarrayp
, array
);
2349 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2351 doc
: /* Clear the contents of STRING.
2352 This makes STRING unibyte and may change its length. */)
2357 CHECK_STRING (string
);
2358 len
= SBYTES (string
);
2359 bzero (SDATA (string
), len
);
2360 STRING_SET_CHARS (string
, len
);
2361 STRING_SET_UNIBYTE (string
);
2371 Lisp_Object args
[2];
2374 return Fnconc (2, args
);
2376 return Fnconc (2, &s1
);
2377 #endif /* NO_ARG_ARRAY */
2380 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2381 doc
: /* Concatenate any number of lists by altering them.
2382 Only the last argument is not altered, and need not be a list.
2383 usage: (nconc &rest LISTS) */)
2388 register int argnum
;
2389 register Lisp_Object tail
, tem
, val
;
2393 for (argnum
= 0; argnum
< nargs
; argnum
++)
2396 if (NILP (tem
)) continue;
2401 if (argnum
+ 1 == nargs
) break;
2403 CHECK_LIST_CONS (tem
, tem
);
2412 tem
= args
[argnum
+ 1];
2413 Fsetcdr (tail
, tem
);
2415 args
[argnum
+ 1] = tail
;
2421 /* This is the guts of all mapping functions.
2422 Apply FN to each element of SEQ, one by one,
2423 storing the results into elements of VALS, a C vector of Lisp_Objects.
2424 LENI is the length of VALS, which should also be the length of SEQ. */
2427 mapcar1 (leni
, vals
, fn
, seq
)
2430 Lisp_Object fn
, seq
;
2432 register Lisp_Object tail
;
2435 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2439 /* Don't let vals contain any garbage when GC happens. */
2440 for (i
= 0; i
< leni
; i
++)
2443 GCPRO3 (dummy
, fn
, seq
);
2445 gcpro1
.nvars
= leni
;
2449 /* We need not explicitly protect `tail' because it is used only on lists, and
2450 1) lists are not relocated and 2) the list is marked via `seq' so will not
2455 for (i
= 0; i
< leni
; i
++)
2457 dummy
= call1 (fn
, AREF (seq
, i
));
2462 else if (BOOL_VECTOR_P (seq
))
2464 for (i
= 0; i
< leni
; i
++)
2467 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2468 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2469 dummy
= call1 (fn
, dummy
);
2474 else if (STRINGP (seq
))
2478 for (i
= 0, i_byte
= 0; i
< leni
;)
2483 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2484 XSETFASTINT (dummy
, c
);
2485 dummy
= call1 (fn
, dummy
);
2487 vals
[i_before
] = dummy
;
2490 else /* Must be a list, since Flength did not get an error */
2493 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2495 dummy
= call1 (fn
, XCAR (tail
));
2505 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2506 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2507 In between each pair of results, stick in SEPARATOR. Thus, " " as
2508 SEPARATOR results in spaces between the values returned by FUNCTION.
2509 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2510 (function
, sequence
, separator
)
2511 Lisp_Object function
, sequence
, separator
;
2516 register Lisp_Object
*args
;
2518 struct gcpro gcpro1
;
2522 len
= Flength (sequence
);
2523 if (CHAR_TABLE_P (sequence
))
2524 wrong_type_argument (Qlistp
, sequence
);
2526 nargs
= leni
+ leni
- 1;
2527 if (nargs
< 0) return empty_unibyte_string
;
2529 SAFE_ALLOCA_LISP (args
, nargs
);
2532 mapcar1 (leni
, args
, function
, sequence
);
2535 for (i
= leni
- 1; i
> 0; i
--)
2536 args
[i
+ i
] = args
[i
];
2538 for (i
= 1; i
< nargs
; i
+= 2)
2539 args
[i
] = separator
;
2541 ret
= Fconcat (nargs
, args
);
2547 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2548 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2549 The result is a list just as long as SEQUENCE.
2550 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2551 (function
, sequence
)
2552 Lisp_Object function
, sequence
;
2554 register Lisp_Object len
;
2556 register Lisp_Object
*args
;
2560 len
= Flength (sequence
);
2561 if (CHAR_TABLE_P (sequence
))
2562 wrong_type_argument (Qlistp
, sequence
);
2563 leni
= XFASTINT (len
);
2565 SAFE_ALLOCA_LISP (args
, leni
);
2567 mapcar1 (leni
, args
, function
, sequence
);
2569 ret
= Flist (leni
, args
);
2575 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2576 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2577 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2578 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2579 (function
, sequence
)
2580 Lisp_Object function
, sequence
;
2584 leni
= XFASTINT (Flength (sequence
));
2585 if (CHAR_TABLE_P (sequence
))
2586 wrong_type_argument (Qlistp
, sequence
);
2587 mapcar1 (leni
, 0, function
, sequence
);
2592 /* Anything that calls this function must protect from GC! */
2594 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2595 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2596 Takes one argument, which is the string to display to ask the question.
2597 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2598 No confirmation of the answer is requested; a single character is enough.
2599 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2600 the bindings in `query-replace-map'; see the documentation of that variable
2601 for more information. In this case, the useful bindings are `act', `skip',
2602 `recenter', and `quit'.\)
2604 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2605 is nil and `use-dialog-box' is non-nil. */)
2609 register Lisp_Object obj
, key
, def
, map
;
2610 register int answer
;
2611 Lisp_Object xprompt
;
2612 Lisp_Object args
[2];
2613 struct gcpro gcpro1
, gcpro2
;
2614 int count
= SPECPDL_INDEX ();
2616 specbind (Qcursor_in_echo_area
, Qt
);
2618 map
= Fsymbol_value (intern ("query-replace-map"));
2620 CHECK_STRING (prompt
);
2622 GCPRO2 (prompt
, xprompt
);
2624 #ifdef HAVE_WINDOW_SYSTEM
2625 if (display_hourglass_p
)
2626 cancel_hourglass ();
2633 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2634 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2638 Lisp_Object pane
, menu
;
2639 redisplay_preserve_echo_area (3);
2640 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2641 Fcons (Fcons (build_string ("No"), Qnil
),
2643 menu
= Fcons (prompt
, pane
);
2644 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2645 answer
= !NILP (obj
);
2648 #endif /* HAVE_MENUS */
2649 cursor_in_echo_area
= 1;
2650 choose_minibuf_frame ();
2653 Lisp_Object pargs
[3];
2655 /* Colorize prompt according to `minibuffer-prompt' face. */
2656 pargs
[0] = build_string ("%s(y or n) ");
2657 pargs
[1] = intern ("face");
2658 pargs
[2] = intern ("minibuffer-prompt");
2659 args
[0] = Fpropertize (3, pargs
);
2664 if (minibuffer_auto_raise
)
2666 Lisp_Object mini_frame
;
2668 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2670 Fraise_frame (mini_frame
);
2673 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2674 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2675 cursor_in_echo_area
= 0;
2676 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2679 key
= Fmake_vector (make_number (1), obj
);
2680 def
= Flookup_key (map
, key
, Qt
);
2682 if (EQ (def
, intern ("skip")))
2687 else if (EQ (def
, intern ("act")))
2692 else if (EQ (def
, intern ("recenter")))
2698 else if (EQ (def
, intern ("quit")))
2700 /* We want to exit this command for exit-prefix,
2701 and this is the only way to do it. */
2702 else if (EQ (def
, intern ("exit-prefix")))
2707 /* If we don't clear this, then the next call to read_char will
2708 return quit_char again, and we'll enter an infinite loop. */
2713 if (EQ (xprompt
, prompt
))
2715 args
[0] = build_string ("Please answer y or n. ");
2717 xprompt
= Fconcat (2, args
);
2722 if (! noninteractive
)
2724 cursor_in_echo_area
= -1;
2725 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2729 unbind_to (count
, Qnil
);
2730 return answer
? Qt
: Qnil
;
2733 /* This is how C code calls `yes-or-no-p' and allows the user
2736 Anything that calls this function must protect from GC! */
2739 do_yes_or_no_p (prompt
)
2742 return call1 (intern ("yes-or-no-p"), prompt
);
2745 /* Anything that calls this function must protect from GC! */
2747 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2748 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2749 Takes one argument, which is the string to display to ask the question.
2750 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2751 The user must confirm the answer with RET,
2752 and can edit it until it has been confirmed.
2754 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2755 is nil, and `use-dialog-box' is non-nil. */)
2759 register Lisp_Object ans
;
2760 Lisp_Object args
[2];
2761 struct gcpro gcpro1
;
2763 CHECK_STRING (prompt
);
2766 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2767 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2771 Lisp_Object pane
, menu
, obj
;
2772 redisplay_preserve_echo_area (4);
2773 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2774 Fcons (Fcons (build_string ("No"), Qnil
),
2777 menu
= Fcons (prompt
, pane
);
2778 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2782 #endif /* HAVE_MENUS */
2785 args
[1] = build_string ("(yes or no) ");
2786 prompt
= Fconcat (2, args
);
2792 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2793 Qyes_or_no_p_history
, Qnil
,
2795 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2800 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2808 message ("Please answer yes or no.");
2809 Fsleep_for (make_number (2), Qnil
);
2813 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2814 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2816 Each of the three load averages is multiplied by 100, then converted
2819 When USE-FLOATS is non-nil, floats will be used instead of integers.
2820 These floats are not multiplied by 100.
2822 If the 5-minute or 15-minute load averages are not available, return a
2823 shortened list, containing only those averages which are available.
2825 An error is thrown if the load average can't be obtained. In some
2826 cases making it work would require Emacs being installed setuid or
2827 setgid so that it can read kernel information, and that usually isn't
2830 Lisp_Object use_floats
;
2833 int loads
= getloadavg (load_ave
, 3);
2834 Lisp_Object ret
= Qnil
;
2837 error ("load-average not implemented for this operating system");
2841 Lisp_Object load
= (NILP (use_floats
) ?
2842 make_number ((int) (100.0 * load_ave
[loads
]))
2843 : make_float (load_ave
[loads
]));
2844 ret
= Fcons (load
, ret
);
2850 Lisp_Object Vfeatures
, Qsubfeatures
;
2851 extern Lisp_Object Vafter_load_alist
;
2853 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2854 doc
: /* Returns t if FEATURE is present in this Emacs.
2856 Use this to conditionalize execution of lisp code based on the
2857 presence or absence of Emacs or environment extensions.
2858 Use `provide' to declare that a feature is available. This function
2859 looks at the value of the variable `features'. The optional argument
2860 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2861 (feature
, subfeature
)
2862 Lisp_Object feature
, subfeature
;
2864 register Lisp_Object tem
;
2865 CHECK_SYMBOL (feature
);
2866 tem
= Fmemq (feature
, Vfeatures
);
2867 if (!NILP (tem
) && !NILP (subfeature
))
2868 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2869 return (NILP (tem
)) ? Qnil
: Qt
;
2872 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2873 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2874 The optional argument SUBFEATURES should be a list of symbols listing
2875 particular subfeatures supported in this version of FEATURE. */)
2876 (feature
, subfeatures
)
2877 Lisp_Object feature
, subfeatures
;
2879 register Lisp_Object tem
;
2880 CHECK_SYMBOL (feature
);
2881 CHECK_LIST (subfeatures
);
2882 if (!NILP (Vautoload_queue
))
2883 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2885 tem
= Fmemq (feature
, Vfeatures
);
2887 Vfeatures
= Fcons (feature
, Vfeatures
);
2888 if (!NILP (subfeatures
))
2889 Fput (feature
, Qsubfeatures
, subfeatures
);
2890 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2892 /* Run any load-hooks for this file. */
2893 tem
= Fassq (feature
, Vafter_load_alist
);
2895 Fprogn (XCDR (tem
));
2900 /* `require' and its subroutines. */
2902 /* List of features currently being require'd, innermost first. */
2904 Lisp_Object require_nesting_list
;
2907 require_unwind (old_value
)
2908 Lisp_Object old_value
;
2910 return require_nesting_list
= old_value
;
2913 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2914 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2915 If FEATURE is not a member of the list `features', then the feature
2916 is not loaded; so load the file FILENAME.
2917 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2918 and `load' will try to load this name appended with the suffix `.elc' or
2919 `.el', in that order. The name without appended suffix will not be used.
2920 If the optional third argument NOERROR is non-nil,
2921 then return nil if the file is not found instead of signaling an error.
2922 Normally the return value is FEATURE.
2923 The normal messages at start and end of loading FILENAME are suppressed. */)
2924 (feature
, filename
, noerror
)
2925 Lisp_Object feature
, filename
, noerror
;
2927 register Lisp_Object tem
;
2928 struct gcpro gcpro1
, gcpro2
;
2929 int from_file
= load_in_progress
;
2931 CHECK_SYMBOL (feature
);
2933 /* Record the presence of `require' in this file
2934 even if the feature specified is already loaded.
2935 But not more than once in any file,
2936 and not when we aren't loading or reading from a file. */
2938 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2939 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2944 tem
= Fcons (Qrequire
, feature
);
2945 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2946 LOADHIST_ATTACH (tem
);
2948 tem
= Fmemq (feature
, Vfeatures
);
2952 int count
= SPECPDL_INDEX ();
2955 /* This is to make sure that loadup.el gives a clear picture
2956 of what files are preloaded and when. */
2957 if (! NILP (Vpurify_flag
))
2958 error ("(require %s) while preparing to dump",
2959 SDATA (SYMBOL_NAME (feature
)));
2961 /* A certain amount of recursive `require' is legitimate,
2962 but if we require the same feature recursively 3 times,
2964 tem
= require_nesting_list
;
2965 while (! NILP (tem
))
2967 if (! NILP (Fequal (feature
, XCAR (tem
))))
2972 error ("Recursive `require' for feature `%s'",
2973 SDATA (SYMBOL_NAME (feature
)));
2975 /* Update the list for any nested `require's that occur. */
2976 record_unwind_protect (require_unwind
, require_nesting_list
);
2977 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2979 /* Value saved here is to be restored into Vautoload_queue */
2980 record_unwind_protect (un_autoload
, Vautoload_queue
);
2981 Vautoload_queue
= Qt
;
2983 /* Load the file. */
2984 GCPRO2 (feature
, filename
);
2985 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2986 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2989 /* If load failed entirely, return nil. */
2991 return unbind_to (count
, Qnil
);
2993 tem
= Fmemq (feature
, Vfeatures
);
2995 error ("Required feature `%s' was not provided",
2996 SDATA (SYMBOL_NAME (feature
)));
2998 /* Once loading finishes, don't undo it. */
2999 Vautoload_queue
= Qt
;
3000 feature
= unbind_to (count
, feature
);
3006 /* Primitives for work of the "widget" library.
3007 In an ideal world, this section would not have been necessary.
3008 However, lisp function calls being as slow as they are, it turns
3009 out that some functions in the widget library (wid-edit.el) are the
3010 bottleneck of Widget operation. Here is their translation to C,
3011 for the sole reason of efficiency. */
3013 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3014 doc
: /* Return non-nil if PLIST has the property PROP.
3015 PLIST is a property list, which is a list of the form
3016 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3017 Unlike `plist-get', this allows you to distinguish between a missing
3018 property and a property with the value nil.
3019 The value is actually the tail of PLIST whose car is PROP. */)
3021 Lisp_Object plist
, prop
;
3023 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3026 plist
= XCDR (plist
);
3027 plist
= CDR (plist
);
3032 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3033 doc
: /* In WIDGET, set PROPERTY to VALUE.
3034 The value can later be retrieved with `widget-get'. */)
3035 (widget
, property
, value
)
3036 Lisp_Object widget
, property
, value
;
3038 CHECK_CONS (widget
);
3039 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3043 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3044 doc
: /* In WIDGET, get the value of PROPERTY.
3045 The value could either be specified when the widget was created, or
3046 later with `widget-put'. */)
3048 Lisp_Object widget
, property
;
3056 CHECK_CONS (widget
);
3057 tmp
= Fplist_member (XCDR (widget
), property
);
3063 tmp
= XCAR (widget
);
3066 widget
= Fget (tmp
, Qwidget_type
);
3070 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3071 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3072 ARGS are passed as extra arguments to the function.
3073 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3078 /* This function can GC. */
3079 Lisp_Object newargs
[3];
3080 struct gcpro gcpro1
, gcpro2
;
3083 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3084 newargs
[1] = args
[0];
3085 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3086 GCPRO2 (newargs
[0], newargs
[2]);
3087 result
= Fapply (3, newargs
);
3092 #ifdef HAVE_LANGINFO_CODESET
3093 #include <langinfo.h>
3096 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3097 doc
: /* Access locale data ITEM for the current C locale, if available.
3098 ITEM should be one of the following:
3100 `codeset', returning the character set as a string (locale item CODESET);
3102 `days', returning a 7-element vector of day names (locale items DAY_n);
3104 `months', returning a 12-element vector of month names (locale items MON_n);
3106 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3107 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3109 If the system can't provide such information through a call to
3110 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3112 See also Info node `(libc)Locales'.
3114 The data read from the system are decoded using `locale-coding-system'. */)
3119 #ifdef HAVE_LANGINFO_CODESET
3121 if (EQ (item
, Qcodeset
))
3123 str
= nl_langinfo (CODESET
);
3124 return build_string (str
);
3127 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3129 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3130 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3132 synchronize_system_time_locale ();
3133 for (i
= 0; i
< 7; i
++)
3135 str
= nl_langinfo (days
[i
]);
3136 val
= make_unibyte_string (str
, strlen (str
));
3137 /* Fixme: Is this coding system necessarily right, even if
3138 it is consistent with CODESET? If not, what to do? */
3139 Faset (v
, make_number (i
),
3140 code_convert_string_norecord (val
, Vlocale_coding_system
,
3147 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3149 struct Lisp_Vector
*p
= allocate_vector (12);
3150 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3151 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3153 synchronize_system_time_locale ();
3154 for (i
= 0; i
< 12; i
++)
3156 str
= nl_langinfo (months
[i
]);
3157 val
= make_unibyte_string (str
, strlen (str
));
3159 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3161 XSETVECTOR (val
, p
);
3165 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3166 but is in the locale files. This could be used by ps-print. */
3168 else if (EQ (item
, Qpaper
))
3170 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3171 make_number (nl_langinfo (PAPER_HEIGHT
)));
3173 #endif /* PAPER_WIDTH */
3174 #endif /* HAVE_LANGINFO_CODESET*/
3178 /* base64 encode/decode functions (RFC 2045).
3179 Based on code from GNU recode. */
3181 #define MIME_LINE_LENGTH 76
3183 #define IS_ASCII(Character) \
3185 #define IS_BASE64(Character) \
3186 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3187 #define IS_BASE64_IGNORABLE(Character) \
3188 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3189 || (Character) == '\f' || (Character) == '\r')
3191 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3192 character or return retval if there are no characters left to
3194 #define READ_QUADRUPLET_BYTE(retval) \
3199 if (nchars_return) \
3200 *nchars_return = nchars; \
3205 while (IS_BASE64_IGNORABLE (c))
3207 /* Table of characters coding the 64 values. */
3208 static char base64_value_to_char
[64] =
3210 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3211 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3212 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3213 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3214 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3215 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3216 '8', '9', '+', '/' /* 60-63 */
3219 /* Table of base64 values for first 128 characters. */
3220 static short base64_char_to_value
[128] =
3222 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3223 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3224 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3225 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3226 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3227 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3228 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3229 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3230 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3231 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3232 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3233 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3234 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3237 /* The following diagram shows the logical steps by which three octets
3238 get transformed into four base64 characters.
3240 .--------. .--------. .--------.
3241 |aaaaaabb| |bbbbcccc| |ccdddddd|
3242 `--------' `--------' `--------'
3244 .--------+--------+--------+--------.
3245 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3246 `--------+--------+--------+--------'
3248 .--------+--------+--------+--------.
3249 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3250 `--------+--------+--------+--------'
3252 The octets are divided into 6 bit chunks, which are then encoded into
3253 base64 characters. */
3256 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3257 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3259 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3261 doc
: /* Base64-encode the region between BEG and END.
3262 Return the length of the encoded text.
3263 Optional third argument NO-LINE-BREAK means do not break long lines
3264 into shorter lines. */)
3265 (beg
, end
, no_line_break
)
3266 Lisp_Object beg
, end
, no_line_break
;
3269 int allength
, length
;
3270 int ibeg
, iend
, encoded_length
;
3274 validate_region (&beg
, &end
);
3276 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3277 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3278 move_gap_both (XFASTINT (beg
), ibeg
);
3280 /* We need to allocate enough room for encoding the text.
3281 We need 33 1/3% more space, plus a newline every 76
3282 characters, and then we round up. */
3283 length
= iend
- ibeg
;
3284 allength
= length
+ length
/3 + 1;
3285 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3287 SAFE_ALLOCA (encoded
, char *, allength
);
3288 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3289 NILP (no_line_break
),
3290 !NILP (current_buffer
->enable_multibyte_characters
));
3291 if (encoded_length
> allength
)
3294 if (encoded_length
< 0)
3296 /* The encoding wasn't possible. */
3298 error ("Multibyte character in data for base64 encoding");
3301 /* Now we have encoded the region, so we insert the new contents
3302 and delete the old. (Insert first in order to preserve markers.) */
3303 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3304 insert (encoded
, encoded_length
);
3306 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3308 /* If point was outside of the region, restore it exactly; else just
3309 move to the beginning of the region. */
3310 if (old_pos
>= XFASTINT (end
))
3311 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3312 else if (old_pos
> XFASTINT (beg
))
3313 old_pos
= XFASTINT (beg
);
3316 /* We return the length of the encoded text. */
3317 return make_number (encoded_length
);
3320 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3322 doc
: /* Base64-encode STRING and return the result.
3323 Optional second argument NO-LINE-BREAK means do not break long lines
3324 into shorter lines. */)
3325 (string
, no_line_break
)
3326 Lisp_Object string
, no_line_break
;
3328 int allength
, length
, encoded_length
;
3330 Lisp_Object encoded_string
;
3333 CHECK_STRING (string
);
3335 /* We need to allocate enough room for encoding the text.
3336 We need 33 1/3% more space, plus a newline every 76
3337 characters, and then we round up. */
3338 length
= SBYTES (string
);
3339 allength
= length
+ length
/3 + 1;
3340 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3342 /* We need to allocate enough room for decoding the text. */
3343 SAFE_ALLOCA (encoded
, char *, allength
);
3345 encoded_length
= base64_encode_1 (SDATA (string
),
3346 encoded
, length
, NILP (no_line_break
),
3347 STRING_MULTIBYTE (string
));
3348 if (encoded_length
> allength
)
3351 if (encoded_length
< 0)
3353 /* The encoding wasn't possible. */
3355 error ("Multibyte character in data for base64 encoding");
3358 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3361 return encoded_string
;
3365 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3372 int counter
= 0, i
= 0;
3382 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3383 if (CHAR_BYTE8_P (c
))
3384 c
= CHAR_TO_BYTE8 (c
);
3392 /* Wrap line every 76 characters. */
3396 if (counter
< MIME_LINE_LENGTH
/ 4)
3405 /* Process first byte of a triplet. */
3407 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3408 value
= (0x03 & c
) << 4;
3410 /* Process second byte of a triplet. */
3414 *e
++ = base64_value_to_char
[value
];
3422 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3423 if (CHAR_BYTE8_P (c
))
3424 c
= CHAR_TO_BYTE8 (c
);
3432 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3433 value
= (0x0f & c
) << 2;
3435 /* Process third byte of a triplet. */
3439 *e
++ = base64_value_to_char
[value
];
3446 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3447 if (CHAR_BYTE8_P (c
))
3448 c
= CHAR_TO_BYTE8 (c
);
3456 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3457 *e
++ = base64_value_to_char
[0x3f & c
];
3464 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3466 doc
: /* Base64-decode the region between BEG and END.
3467 Return the length of the decoded text.
3468 If the region can't be decoded, signal an error and don't modify the buffer. */)
3470 Lisp_Object beg
, end
;
3472 int ibeg
, iend
, length
, allength
;
3477 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3480 validate_region (&beg
, &end
);
3482 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3483 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3485 length
= iend
- ibeg
;
3487 /* We need to allocate enough room for decoding the text. If we are
3488 working on a multibyte buffer, each decoded code may occupy at
3490 allength
= multibyte
? length
* 2 : length
;
3491 SAFE_ALLOCA (decoded
, char *, allength
);
3493 move_gap_both (XFASTINT (beg
), ibeg
);
3494 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3495 multibyte
, &inserted_chars
);
3496 if (decoded_length
> allength
)
3499 if (decoded_length
< 0)
3501 /* The decoding wasn't possible. */
3503 error ("Invalid base64 data");
3506 /* Now we have decoded the region, so we insert the new contents
3507 and delete the old. (Insert first in order to preserve markers.) */
3508 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3509 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3512 /* Delete the original text. */
3513 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3514 iend
+ decoded_length
, 1);
3516 /* If point was outside of the region, restore it exactly; else just
3517 move to the beginning of the region. */
3518 if (old_pos
>= XFASTINT (end
))
3519 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3520 else if (old_pos
> XFASTINT (beg
))
3521 old_pos
= XFASTINT (beg
);
3522 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3524 return make_number (inserted_chars
);
3527 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3529 doc
: /* Base64-decode STRING and return the result. */)
3534 int length
, decoded_length
;
3535 Lisp_Object decoded_string
;
3538 CHECK_STRING (string
);
3540 length
= SBYTES (string
);
3541 /* We need to allocate enough room for decoding the text. */
3542 SAFE_ALLOCA (decoded
, char *, length
);
3544 /* The decoded result should be unibyte. */
3545 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3547 if (decoded_length
> length
)
3549 else if (decoded_length
>= 0)
3550 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3552 decoded_string
= Qnil
;
3555 if (!STRINGP (decoded_string
))
3556 error ("Invalid base64 data");
3558 return decoded_string
;
3561 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3562 MULTIBYTE is nonzero, the decoded result should be in multibyte
3563 form. If NCHARS_RETRUN is not NULL, store the number of produced
3564 characters in *NCHARS_RETURN. */
3567 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3577 unsigned long value
;
3582 /* Process first byte of a quadruplet. */
3584 READ_QUADRUPLET_BYTE (e
-to
);
3588 value
= base64_char_to_value
[c
] << 18;
3590 /* Process second byte of a quadruplet. */
3592 READ_QUADRUPLET_BYTE (-1);
3596 value
|= base64_char_to_value
[c
] << 12;
3598 c
= (unsigned char) (value
>> 16);
3599 if (multibyte
&& c
>= 128)
3600 e
+= BYTE8_STRING (c
, e
);
3605 /* Process third byte of a quadruplet. */
3607 READ_QUADRUPLET_BYTE (-1);
3611 READ_QUADRUPLET_BYTE (-1);
3620 value
|= base64_char_to_value
[c
] << 6;
3622 c
= (unsigned char) (0xff & value
>> 8);
3623 if (multibyte
&& c
>= 128)
3624 e
+= BYTE8_STRING (c
, e
);
3629 /* Process fourth byte of a quadruplet. */
3631 READ_QUADRUPLET_BYTE (-1);
3638 value
|= base64_char_to_value
[c
];
3640 c
= (unsigned char) (0xff & value
);
3641 if (multibyte
&& c
>= 128)
3642 e
+= BYTE8_STRING (c
, e
);
3651 /***********************************************************************
3653 ***** Hash Tables *****
3655 ***********************************************************************/
3657 /* Implemented by gerd@gnu.org. This hash table implementation was
3658 inspired by CMUCL hash tables. */
3662 1. For small tables, association lists are probably faster than
3663 hash tables because they have lower overhead.
3665 For uses of hash tables where the O(1) behavior of table
3666 operations is not a requirement, it might therefore be a good idea
3667 not to hash. Instead, we could just do a linear search in the
3668 key_and_value vector of the hash table. This could be done
3669 if a `:linear-search t' argument is given to make-hash-table. */
3672 /* The list of all weak hash tables. Don't staticpro this one. */
3674 struct Lisp_Hash_Table
*weak_hash_tables
;
3676 /* Various symbols. */
3678 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3679 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3680 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3682 /* Function prototypes. */
3684 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3685 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3686 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3687 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3688 Lisp_Object
, unsigned));
3689 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3690 Lisp_Object
, unsigned));
3691 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3692 unsigned, Lisp_Object
, unsigned));
3693 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3694 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3695 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3696 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3698 static unsigned sxhash_string
P_ ((unsigned char *, int));
3699 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3700 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3701 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3702 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3706 /***********************************************************************
3708 ***********************************************************************/
3710 /* If OBJ is a Lisp hash table, return a pointer to its struct
3711 Lisp_Hash_Table. Otherwise, signal an error. */
3713 static struct Lisp_Hash_Table
*
3714 check_hash_table (obj
)
3717 CHECK_HASH_TABLE (obj
);
3718 return XHASH_TABLE (obj
);
3722 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3726 next_almost_prime (n
)
3739 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3740 which USED[I] is non-zero. If found at index I in ARGS, set
3741 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3742 -1. This function is used to extract a keyword/argument pair from
3743 a DEFUN parameter list. */
3746 get_key_arg (key
, nargs
, args
, used
)
3754 for (i
= 0; i
< nargs
- 1; ++i
)
3755 if (!used
[i
] && EQ (args
[i
], key
))
3770 /* Return a Lisp vector which has the same contents as VEC but has
3771 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3772 vector that are not copied from VEC are set to INIT. */
3775 larger_vector (vec
, new_size
, init
)
3780 struct Lisp_Vector
*v
;
3783 xassert (VECTORP (vec
));
3784 old_size
= ASIZE (vec
);
3785 xassert (new_size
>= old_size
);
3787 v
= allocate_vector (new_size
);
3788 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3789 old_size
* sizeof *v
->contents
);
3790 for (i
= old_size
; i
< new_size
; ++i
)
3791 v
->contents
[i
] = init
;
3792 XSETVECTOR (vec
, v
);
3797 /***********************************************************************
3799 ***********************************************************************/
3801 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3802 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3803 KEY2 are the same. */
3806 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3807 struct Lisp_Hash_Table
*h
;
3808 Lisp_Object key1
, key2
;
3809 unsigned hash1
, hash2
;
3811 return (FLOATP (key1
)
3813 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3817 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3818 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3819 KEY2 are the same. */
3822 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3823 struct Lisp_Hash_Table
*h
;
3824 Lisp_Object key1
, key2
;
3825 unsigned hash1
, hash2
;
3827 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3831 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3832 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3833 if KEY1 and KEY2 are the same. */
3836 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3837 struct Lisp_Hash_Table
*h
;
3838 Lisp_Object key1
, key2
;
3839 unsigned hash1
, hash2
;
3843 Lisp_Object args
[3];
3845 args
[0] = h
->user_cmp_function
;
3848 return !NILP (Ffuncall (3, args
));
3855 /* Value is a hash code for KEY for use in hash table H which uses
3856 `eq' to compare keys. The hash code returned is guaranteed to fit
3857 in a Lisp integer. */
3861 struct Lisp_Hash_Table
*h
;
3864 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3865 xassert ((hash
& ~INTMASK
) == 0);
3870 /* Value is a hash code for KEY for use in hash table H which uses
3871 `eql' to compare keys. The hash code returned is guaranteed to fit
3872 in a Lisp integer. */
3876 struct Lisp_Hash_Table
*h
;
3881 hash
= sxhash (key
, 0);
3883 hash
= XUINT (key
) ^ XTYPE (key
);
3884 xassert ((hash
& ~INTMASK
) == 0);
3889 /* Value is a hash code for KEY for use in hash table H which uses
3890 `equal' to compare keys. The hash code returned is guaranteed to fit
3891 in a Lisp integer. */
3894 hashfn_equal (h
, key
)
3895 struct Lisp_Hash_Table
*h
;
3898 unsigned hash
= sxhash (key
, 0);
3899 xassert ((hash
& ~INTMASK
) == 0);
3904 /* Value is a hash code for KEY for use in hash table H which uses as
3905 user-defined function to compare keys. The hash code returned is
3906 guaranteed to fit in a Lisp integer. */
3909 hashfn_user_defined (h
, key
)
3910 struct Lisp_Hash_Table
*h
;
3913 Lisp_Object args
[2], hash
;
3915 args
[0] = h
->user_hash_function
;
3917 hash
= Ffuncall (2, args
);
3918 if (!INTEGERP (hash
))
3919 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3920 return XUINT (hash
);
3924 /* Create and initialize a new hash table.
3926 TEST specifies the test the hash table will use to compare keys.
3927 It must be either one of the predefined tests `eq', `eql' or
3928 `equal' or a symbol denoting a user-defined test named TEST with
3929 test and hash functions USER_TEST and USER_HASH.
3931 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3933 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3934 new size when it becomes full is computed by adding REHASH_SIZE to
3935 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3936 table's new size is computed by multiplying its old size with
3939 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3940 be resized when the ratio of (number of entries in the table) /
3941 (table size) is >= REHASH_THRESHOLD.
3943 WEAK specifies the weakness of the table. If non-nil, it must be
3944 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3947 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3948 user_test
, user_hash
)
3949 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3950 Lisp_Object user_test
, user_hash
;
3952 struct Lisp_Hash_Table
*h
;
3954 int index_size
, i
, sz
;
3956 /* Preconditions. */
3957 xassert (SYMBOLP (test
));
3958 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3959 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3960 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3961 xassert (FLOATP (rehash_threshold
)
3962 && XFLOATINT (rehash_threshold
) > 0
3963 && XFLOATINT (rehash_threshold
) <= 1.0);
3965 if (XFASTINT (size
) == 0)
3966 size
= make_number (1);
3968 /* Allocate a table and initialize it. */
3969 h
= allocate_hash_table ();
3971 /* Initialize hash table slots. */
3972 sz
= XFASTINT (size
);
3975 if (EQ (test
, Qeql
))
3977 h
->cmpfn
= cmpfn_eql
;
3978 h
->hashfn
= hashfn_eql
;
3980 else if (EQ (test
, Qeq
))
3983 h
->hashfn
= hashfn_eq
;
3985 else if (EQ (test
, Qequal
))
3987 h
->cmpfn
= cmpfn_equal
;
3988 h
->hashfn
= hashfn_equal
;
3992 h
->user_cmp_function
= user_test
;
3993 h
->user_hash_function
= user_hash
;
3994 h
->cmpfn
= cmpfn_user_defined
;
3995 h
->hashfn
= hashfn_user_defined
;
3999 h
->rehash_threshold
= rehash_threshold
;
4000 h
->rehash_size
= rehash_size
;
4002 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4003 h
->hash
= Fmake_vector (size
, Qnil
);
4004 h
->next
= Fmake_vector (size
, Qnil
);
4005 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4006 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4007 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4009 /* Set up the free list. */
4010 for (i
= 0; i
< sz
- 1; ++i
)
4011 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4012 h
->next_free
= make_number (0);
4014 XSET_HASH_TABLE (table
, h
);
4015 xassert (HASH_TABLE_P (table
));
4016 xassert (XHASH_TABLE (table
) == h
);
4018 /* Maybe add this hash table to the list of all weak hash tables. */
4020 h
->next_weak
= NULL
;
4023 h
->next_weak
= weak_hash_tables
;
4024 weak_hash_tables
= h
;
4031 /* Return a copy of hash table H1. Keys and values are not copied,
4032 only the table itself is. */
4035 copy_hash_table (h1
)
4036 struct Lisp_Hash_Table
*h1
;
4039 struct Lisp_Hash_Table
*h2
;
4040 struct Lisp_Vector
*next
;
4042 h2
= allocate_hash_table ();
4043 next
= h2
->vec_next
;
4044 bcopy (h1
, h2
, sizeof *h2
);
4045 h2
->vec_next
= next
;
4046 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4047 h2
->hash
= Fcopy_sequence (h1
->hash
);
4048 h2
->next
= Fcopy_sequence (h1
->next
);
4049 h2
->index
= Fcopy_sequence (h1
->index
);
4050 XSET_HASH_TABLE (table
, h2
);
4052 /* Maybe add this hash table to the list of all weak hash tables. */
4053 if (!NILP (h2
->weak
))
4055 h2
->next_weak
= weak_hash_tables
;
4056 weak_hash_tables
= h2
;
4063 /* Resize hash table H if it's too full. If H cannot be resized
4064 because it's already too large, throw an error. */
4067 maybe_resize_hash_table (h
)
4068 struct Lisp_Hash_Table
*h
;
4070 if (NILP (h
->next_free
))
4072 int old_size
= HASH_TABLE_SIZE (h
);
4073 int i
, new_size
, index_size
;
4076 if (INTEGERP (h
->rehash_size
))
4077 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4079 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4080 new_size
= max (old_size
+ 1, new_size
);
4081 index_size
= next_almost_prime ((int)
4083 / XFLOATINT (h
->rehash_threshold
)));
4084 /* Assignment to EMACS_INT stops GCC whining about limited range
4086 nsize
= max (index_size
, 2 * new_size
);
4087 if (nsize
> MOST_POSITIVE_FIXNUM
)
4088 error ("Hash table too large to resize");
4090 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4091 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4092 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4093 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4095 /* Update the free list. Do it so that new entries are added at
4096 the end of the free list. This makes some operations like
4098 for (i
= old_size
; i
< new_size
- 1; ++i
)
4099 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4101 if (!NILP (h
->next_free
))
4103 Lisp_Object last
, next
;
4105 last
= h
->next_free
;
4106 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4110 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4113 XSETFASTINT (h
->next_free
, old_size
);
4116 for (i
= 0; i
< old_size
; ++i
)
4117 if (!NILP (HASH_HASH (h
, i
)))
4119 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4120 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4121 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4122 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4128 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4129 the hash code of KEY. Value is the index of the entry in H
4130 matching KEY, or -1 if not found. */
4133 hash_lookup (h
, key
, hash
)
4134 struct Lisp_Hash_Table
*h
;
4139 int start_of_bucket
;
4142 hash_code
= h
->hashfn (h
, key
);
4146 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4147 idx
= HASH_INDEX (h
, start_of_bucket
);
4149 /* We need not gcpro idx since it's either an integer or nil. */
4152 int i
= XFASTINT (idx
);
4153 if (EQ (key
, HASH_KEY (h
, i
))
4155 && h
->cmpfn (h
, key
, hash_code
,
4156 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4158 idx
= HASH_NEXT (h
, i
);
4161 return NILP (idx
) ? -1 : XFASTINT (idx
);
4165 /* Put an entry into hash table H that associates KEY with VALUE.
4166 HASH is a previously computed hash code of KEY.
4167 Value is the index of the entry in H matching KEY. */
4170 hash_put (h
, key
, value
, hash
)
4171 struct Lisp_Hash_Table
*h
;
4172 Lisp_Object key
, value
;
4175 int start_of_bucket
, i
;
4177 xassert ((hash
& ~INTMASK
) == 0);
4179 /* Increment count after resizing because resizing may fail. */
4180 maybe_resize_hash_table (h
);
4183 /* Store key/value in the key_and_value vector. */
4184 i
= XFASTINT (h
->next_free
);
4185 h
->next_free
= HASH_NEXT (h
, i
);
4186 HASH_KEY (h
, i
) = key
;
4187 HASH_VALUE (h
, i
) = value
;
4189 /* Remember its hash code. */
4190 HASH_HASH (h
, i
) = make_number (hash
);
4192 /* Add new entry to its collision chain. */
4193 start_of_bucket
= hash
% ASIZE (h
->index
);
4194 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4195 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4200 /* Remove the entry matching KEY from hash table H, if there is one. */
4203 hash_remove_from_table (h
, key
)
4204 struct Lisp_Hash_Table
*h
;
4208 int start_of_bucket
;
4209 Lisp_Object idx
, prev
;
4211 hash_code
= h
->hashfn (h
, key
);
4212 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4213 idx
= HASH_INDEX (h
, start_of_bucket
);
4216 /* We need not gcpro idx, prev since they're either integers or nil. */
4219 int i
= XFASTINT (idx
);
4221 if (EQ (key
, HASH_KEY (h
, i
))
4223 && h
->cmpfn (h
, key
, hash_code
,
4224 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4226 /* Take entry out of collision chain. */
4228 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4230 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4232 /* Clear slots in key_and_value and add the slots to
4234 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4235 HASH_NEXT (h
, i
) = h
->next_free
;
4236 h
->next_free
= make_number (i
);
4238 xassert (h
->count
>= 0);
4244 idx
= HASH_NEXT (h
, i
);
4250 /* Clear hash table H. */
4254 struct Lisp_Hash_Table
*h
;
4258 int i
, size
= HASH_TABLE_SIZE (h
);
4260 for (i
= 0; i
< size
; ++i
)
4262 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4263 HASH_KEY (h
, i
) = Qnil
;
4264 HASH_VALUE (h
, i
) = Qnil
;
4265 HASH_HASH (h
, i
) = Qnil
;
4268 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4269 ASET (h
->index
, i
, Qnil
);
4271 h
->next_free
= make_number (0);
4278 /************************************************************************
4280 ************************************************************************/
4283 init_weak_hash_tables ()
4285 weak_hash_tables
= NULL
;
4288 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4289 entries from the table that don't survive the current GC.
4290 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4291 non-zero if anything was marked. */
4294 sweep_weak_table (h
, remove_entries_p
)
4295 struct Lisp_Hash_Table
*h
;
4296 int remove_entries_p
;
4298 int bucket
, n
, marked
;
4300 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4303 for (bucket
= 0; bucket
< n
; ++bucket
)
4305 Lisp_Object idx
, next
, prev
;
4307 /* Follow collision chain, removing entries that
4308 don't survive this garbage collection. */
4310 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4312 int i
= XFASTINT (idx
);
4313 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4314 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4317 if (EQ (h
->weak
, Qkey
))
4318 remove_p
= !key_known_to_survive_p
;
4319 else if (EQ (h
->weak
, Qvalue
))
4320 remove_p
= !value_known_to_survive_p
;
4321 else if (EQ (h
->weak
, Qkey_or_value
))
4322 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4323 else if (EQ (h
->weak
, Qkey_and_value
))
4324 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4328 next
= HASH_NEXT (h
, i
);
4330 if (remove_entries_p
)
4334 /* Take out of collision chain. */
4336 HASH_INDEX (h
, bucket
) = next
;
4338 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4340 /* Add to free list. */
4341 HASH_NEXT (h
, i
) = h
->next_free
;
4344 /* Clear key, value, and hash. */
4345 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4346 HASH_HASH (h
, i
) = Qnil
;
4359 /* Make sure key and value survive. */
4360 if (!key_known_to_survive_p
)
4362 mark_object (HASH_KEY (h
, i
));
4366 if (!value_known_to_survive_p
)
4368 mark_object (HASH_VALUE (h
, i
));
4379 /* Remove elements from weak hash tables that don't survive the
4380 current garbage collection. Remove weak tables that don't survive
4381 from Vweak_hash_tables. Called from gc_sweep. */
4384 sweep_weak_hash_tables ()
4386 struct Lisp_Hash_Table
*h
, *used
, *next
;
4389 /* Mark all keys and values that are in use. Keep on marking until
4390 there is no more change. This is necessary for cases like
4391 value-weak table A containing an entry X -> Y, where Y is used in a
4392 key-weak table B, Z -> Y. If B comes after A in the list of weak
4393 tables, X -> Y might be removed from A, although when looking at B
4394 one finds that it shouldn't. */
4398 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4400 if (h
->size
& ARRAY_MARK_FLAG
)
4401 marked
|= sweep_weak_table (h
, 0);
4406 /* Remove tables and entries that aren't used. */
4407 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4409 next
= h
->next_weak
;
4411 if (h
->size
& ARRAY_MARK_FLAG
)
4413 /* TABLE is marked as used. Sweep its contents. */
4415 sweep_weak_table (h
, 1);
4417 /* Add table to the list of used weak hash tables. */
4418 h
->next_weak
= used
;
4423 weak_hash_tables
= used
;
4428 /***********************************************************************
4429 Hash Code Computation
4430 ***********************************************************************/
4432 /* Maximum depth up to which to dive into Lisp structures. */
4434 #define SXHASH_MAX_DEPTH 3
4436 /* Maximum length up to which to take list and vector elements into
4439 #define SXHASH_MAX_LEN 7
4441 /* Combine two integers X and Y for hashing. */
4443 #define SXHASH_COMBINE(X, Y) \
4444 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4448 /* Return a hash for string PTR which has length LEN. The hash
4449 code returned is guaranteed to fit in a Lisp integer. */
4452 sxhash_string (ptr
, len
)
4456 unsigned char *p
= ptr
;
4457 unsigned char *end
= p
+ len
;
4466 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4469 return hash
& INTMASK
;
4473 /* Return a hash for list LIST. DEPTH is the current depth in the
4474 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4477 sxhash_list (list
, depth
)
4484 if (depth
< SXHASH_MAX_DEPTH
)
4486 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4487 list
= XCDR (list
), ++i
)
4489 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4490 hash
= SXHASH_COMBINE (hash
, hash2
);
4495 unsigned hash2
= sxhash (list
, depth
+ 1);
4496 hash
= SXHASH_COMBINE (hash
, hash2
);
4503 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4504 the Lisp structure. */
4507 sxhash_vector (vec
, depth
)
4511 unsigned hash
= ASIZE (vec
);
4514 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4515 for (i
= 0; i
< n
; ++i
)
4517 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4518 hash
= SXHASH_COMBINE (hash
, hash2
);
4525 /* Return a hash for bool-vector VECTOR. */
4528 sxhash_bool_vector (vec
)
4531 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4534 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4535 for (i
= 0; i
< n
; ++i
)
4536 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4542 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4543 structure. Value is an unsigned integer clipped to INTMASK. */
4552 if (depth
> SXHASH_MAX_DEPTH
)
4555 switch (XTYPE (obj
))
4566 obj
= SYMBOL_NAME (obj
);
4570 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4573 /* This can be everything from a vector to an overlay. */
4574 case Lisp_Vectorlike
:
4576 /* According to the CL HyperSpec, two arrays are equal only if
4577 they are `eq', except for strings and bit-vectors. In
4578 Emacs, this works differently. We have to compare element
4580 hash
= sxhash_vector (obj
, depth
);
4581 else if (BOOL_VECTOR_P (obj
))
4582 hash
= sxhash_bool_vector (obj
);
4584 /* Others are `equal' if they are `eq', so let's take their
4590 hash
= sxhash_list (obj
, depth
);
4595 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4596 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4597 for (hash
= 0; p
< e
; ++p
)
4598 hash
= SXHASH_COMBINE (hash
, *p
);
4606 return hash
& INTMASK
;
4611 /***********************************************************************
4613 ***********************************************************************/
4616 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4617 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4621 unsigned hash
= sxhash (obj
, 0);
4622 return make_number (hash
);
4626 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4627 doc
: /* Create and return a new hash table.
4629 Arguments are specified as keyword/argument pairs. The following
4630 arguments are defined:
4632 :test TEST -- TEST must be a symbol that specifies how to compare
4633 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4634 `equal'. User-supplied test and hash functions can be specified via
4635 `define-hash-table-test'.
4637 :size SIZE -- A hint as to how many elements will be put in the table.
4640 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4641 fills up. If REHASH-SIZE is an integer, add that many space. If it
4642 is a float, it must be > 1.0, and the new size is computed by
4643 multiplying the old size with that factor. Default is 1.5.
4645 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4646 Resize the hash table when ratio of the number of entries in the
4647 table. Default is 0.8.
4649 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4650 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4651 returned is a weak table. Key/value pairs are removed from a weak
4652 hash table when there are no non-weak references pointing to their
4653 key, value, one of key or value, or both key and value, depending on
4654 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4657 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4662 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4663 Lisp_Object user_test
, user_hash
;
4667 /* The vector `used' is used to keep track of arguments that
4668 have been consumed. */
4669 used
= (char *) alloca (nargs
* sizeof *used
);
4670 bzero (used
, nargs
* sizeof *used
);
4672 /* See if there's a `:test TEST' among the arguments. */
4673 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4674 test
= i
< 0 ? Qeql
: args
[i
];
4675 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4677 /* See if it is a user-defined test. */
4680 prop
= Fget (test
, Qhash_table_test
);
4681 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4682 signal_error ("Invalid hash table test", test
);
4683 user_test
= XCAR (prop
);
4684 user_hash
= XCAR (XCDR (prop
));
4687 user_test
= user_hash
= Qnil
;
4689 /* See if there's a `:size SIZE' argument. */
4690 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4691 size
= i
< 0 ? Qnil
: args
[i
];
4693 size
= make_number (DEFAULT_HASH_SIZE
);
4694 else if (!INTEGERP (size
) || XINT (size
) < 0)
4695 signal_error ("Invalid hash table size", size
);
4697 /* Look for `:rehash-size SIZE'. */
4698 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4699 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4700 if (!NUMBERP (rehash_size
)
4701 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4702 || XFLOATINT (rehash_size
) <= 1.0)
4703 signal_error ("Invalid hash table rehash size", rehash_size
);
4705 /* Look for `:rehash-threshold THRESHOLD'. */
4706 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4707 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4708 if (!FLOATP (rehash_threshold
)
4709 || XFLOATINT (rehash_threshold
) <= 0.0
4710 || XFLOATINT (rehash_threshold
) > 1.0)
4711 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4713 /* Look for `:weakness WEAK'. */
4714 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4715 weak
= i
< 0 ? Qnil
: args
[i
];
4717 weak
= Qkey_and_value
;
4720 && !EQ (weak
, Qvalue
)
4721 && !EQ (weak
, Qkey_or_value
)
4722 && !EQ (weak
, Qkey_and_value
))
4723 signal_error ("Invalid hash table weakness", weak
);
4725 /* Now, all args should have been used up, or there's a problem. */
4726 for (i
= 0; i
< nargs
; ++i
)
4728 signal_error ("Invalid argument list", args
[i
]);
4730 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4731 user_test
, user_hash
);
4735 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4736 doc
: /* Return a copy of hash table TABLE. */)
4740 return copy_hash_table (check_hash_table (table
));
4744 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4745 doc
: /* Return the number of elements in TABLE. */)
4749 return make_number (check_hash_table (table
)->count
);
4753 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4754 Shash_table_rehash_size
, 1, 1, 0,
4755 doc
: /* Return the current rehash size of TABLE. */)
4759 return check_hash_table (table
)->rehash_size
;
4763 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4764 Shash_table_rehash_threshold
, 1, 1, 0,
4765 doc
: /* Return the current rehash threshold of TABLE. */)
4769 return check_hash_table (table
)->rehash_threshold
;
4773 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4774 doc
: /* Return the size of TABLE.
4775 The size can be used as an argument to `make-hash-table' to create
4776 a hash table than can hold as many elements of TABLE holds
4777 without need for resizing. */)
4781 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4782 return make_number (HASH_TABLE_SIZE (h
));
4786 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4787 doc
: /* Return the test TABLE uses. */)
4791 return check_hash_table (table
)->test
;
4795 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4797 doc
: /* Return the weakness of TABLE. */)
4801 return check_hash_table (table
)->weak
;
4805 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4806 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4810 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4814 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4815 doc
: /* Clear hash table TABLE and return it. */)
4819 hash_clear (check_hash_table (table
));
4820 /* Be compatible with XEmacs. */
4825 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4826 doc
: /* Look up KEY in TABLE and return its associated value.
4827 If KEY is not found, return DFLT which defaults to nil. */)
4829 Lisp_Object key
, table
, dflt
;
4831 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4832 int i
= hash_lookup (h
, key
, NULL
);
4833 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4837 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4838 doc
: /* Associate KEY with VALUE in hash table TABLE.
4839 If KEY is already present in table, replace its current value with
4842 Lisp_Object key
, value
, table
;
4844 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4848 i
= hash_lookup (h
, key
, &hash
);
4850 HASH_VALUE (h
, i
) = value
;
4852 hash_put (h
, key
, value
, hash
);
4858 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4859 doc
: /* Remove KEY from TABLE. */)
4861 Lisp_Object key
, table
;
4863 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4864 hash_remove_from_table (h
, key
);
4869 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4870 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4871 FUNCTION is called with two arguments, KEY and VALUE. */)
4873 Lisp_Object function
, table
;
4875 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4876 Lisp_Object args
[3];
4879 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4880 if (!NILP (HASH_HASH (h
, i
)))
4883 args
[1] = HASH_KEY (h
, i
);
4884 args
[2] = HASH_VALUE (h
, i
);
4892 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4893 Sdefine_hash_table_test
, 3, 3, 0,
4894 doc
: /* Define a new hash table test with name NAME, a symbol.
4896 In hash tables created with NAME specified as test, use TEST to
4897 compare keys, and HASH for computing hash codes of keys.
4899 TEST must be a function taking two arguments and returning non-nil if
4900 both arguments are the same. HASH must be a function taking one
4901 argument and return an integer that is the hash code of the argument.
4902 Hash code computation should use the whole value range of integers,
4903 including negative integers. */)
4905 Lisp_Object name
, test
, hash
;
4907 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4912 /************************************************************************
4914 ************************************************************************/
4918 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4919 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4921 A message digest is a cryptographic checksum of a document, and the
4922 algorithm to calculate it is defined in RFC 1321.
4924 The two optional arguments START and END are character positions
4925 specifying for which part of OBJECT the message digest should be
4926 computed. If nil or omitted, the digest is computed for the whole
4929 The MD5 message digest is computed from the result of encoding the
4930 text in a coding system, not directly from the internal Emacs form of
4931 the text. The optional fourth argument CODING-SYSTEM specifies which
4932 coding system to encode the text with. It should be the same coding
4933 system that you used or will use when actually writing the text into a
4936 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4937 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4938 system would be chosen by default for writing this text into a file.
4940 If OBJECT is a string, the most preferred coding system (see the
4941 command `prefer-coding-system') is used.
4943 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4944 guesswork fails. Normally, an error is signaled in such case. */)
4945 (object
, start
, end
, coding_system
, noerror
)
4946 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4948 unsigned char digest
[16];
4949 unsigned char value
[33];
4953 int start_char
= 0, end_char
= 0;
4954 int start_byte
= 0, end_byte
= 0;
4956 register struct buffer
*bp
;
4959 if (STRINGP (object
))
4961 if (NILP (coding_system
))
4963 /* Decide the coding-system to encode the data with. */
4965 if (STRING_MULTIBYTE (object
))
4966 /* use default, we can't guess correct value */
4967 coding_system
= preferred_coding_system ();
4969 coding_system
= Qraw_text
;
4972 if (NILP (Fcoding_system_p (coding_system
)))
4974 /* Invalid coding system. */
4976 if (!NILP (noerror
))
4977 coding_system
= Qraw_text
;
4979 xsignal1 (Qcoding_system_error
, coding_system
);
4982 if (STRING_MULTIBYTE (object
))
4983 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4985 size
= SCHARS (object
);
4986 size_byte
= SBYTES (object
);
4990 CHECK_NUMBER (start
);
4992 start_char
= XINT (start
);
4997 start_byte
= string_char_to_byte (object
, start_char
);
5003 end_byte
= size_byte
;
5009 end_char
= XINT (end
);
5014 end_byte
= string_char_to_byte (object
, end_char
);
5017 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5018 args_out_of_range_3 (object
, make_number (start_char
),
5019 make_number (end_char
));
5023 struct buffer
*prev
= current_buffer
;
5025 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5027 CHECK_BUFFER (object
);
5029 bp
= XBUFFER (object
);
5030 if (bp
!= current_buffer
)
5031 set_buffer_internal (bp
);
5037 CHECK_NUMBER_COERCE_MARKER (start
);
5045 CHECK_NUMBER_COERCE_MARKER (end
);
5050 temp
= b
, b
= e
, e
= temp
;
5052 if (!(BEGV
<= b
&& e
<= ZV
))
5053 args_out_of_range (start
, end
);
5055 if (NILP (coding_system
))
5057 /* Decide the coding-system to encode the data with.
5058 See fileio.c:Fwrite-region */
5060 if (!NILP (Vcoding_system_for_write
))
5061 coding_system
= Vcoding_system_for_write
;
5064 int force_raw_text
= 0;
5066 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5067 if (NILP (coding_system
)
5068 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5070 coding_system
= Qnil
;
5071 if (NILP (current_buffer
->enable_multibyte_characters
))
5075 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5077 /* Check file-coding-system-alist. */
5078 Lisp_Object args
[4], val
;
5080 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5081 args
[3] = Fbuffer_file_name(object
);
5082 val
= Ffind_operation_coding_system (4, args
);
5083 if (CONSP (val
) && !NILP (XCDR (val
)))
5084 coding_system
= XCDR (val
);
5087 if (NILP (coding_system
)
5088 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5090 /* If we still have not decided a coding system, use the
5091 default value of buffer-file-coding-system. */
5092 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5096 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5097 /* Confirm that VAL can surely encode the current region. */
5098 coding_system
= call4 (Vselect_safe_coding_system_function
,
5099 make_number (b
), make_number (e
),
5100 coding_system
, Qnil
);
5103 coding_system
= Qraw_text
;
5106 if (NILP (Fcoding_system_p (coding_system
)))
5108 /* Invalid coding system. */
5110 if (!NILP (noerror
))
5111 coding_system
= Qraw_text
;
5113 xsignal1 (Qcoding_system_error
, coding_system
);
5117 object
= make_buffer_string (b
, e
, 0);
5118 if (prev
!= current_buffer
)
5119 set_buffer_internal (prev
);
5120 /* Discard the unwind protect for recovering the current
5124 if (STRING_MULTIBYTE (object
))
5125 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5128 md5_buffer (SDATA (object
) + start_byte
,
5129 SBYTES (object
) - (size_byte
- end_byte
),
5132 for (i
= 0; i
< 16; i
++)
5133 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5136 return make_string (value
, 32);
5143 /* Hash table stuff. */
5144 Qhash_table_p
= intern ("hash-table-p");
5145 staticpro (&Qhash_table_p
);
5146 Qeq
= intern ("eq");
5148 Qeql
= intern ("eql");
5150 Qequal
= intern ("equal");
5151 staticpro (&Qequal
);
5152 QCtest
= intern (":test");
5153 staticpro (&QCtest
);
5154 QCsize
= intern (":size");
5155 staticpro (&QCsize
);
5156 QCrehash_size
= intern (":rehash-size");
5157 staticpro (&QCrehash_size
);
5158 QCrehash_threshold
= intern (":rehash-threshold");
5159 staticpro (&QCrehash_threshold
);
5160 QCweakness
= intern (":weakness");
5161 staticpro (&QCweakness
);
5162 Qkey
= intern ("key");
5164 Qvalue
= intern ("value");
5165 staticpro (&Qvalue
);
5166 Qhash_table_test
= intern ("hash-table-test");
5167 staticpro (&Qhash_table_test
);
5168 Qkey_or_value
= intern ("key-or-value");
5169 staticpro (&Qkey_or_value
);
5170 Qkey_and_value
= intern ("key-and-value");
5171 staticpro (&Qkey_and_value
);
5174 defsubr (&Smake_hash_table
);
5175 defsubr (&Scopy_hash_table
);
5176 defsubr (&Shash_table_count
);
5177 defsubr (&Shash_table_rehash_size
);
5178 defsubr (&Shash_table_rehash_threshold
);
5179 defsubr (&Shash_table_size
);
5180 defsubr (&Shash_table_test
);
5181 defsubr (&Shash_table_weakness
);
5182 defsubr (&Shash_table_p
);
5183 defsubr (&Sclrhash
);
5184 defsubr (&Sgethash
);
5185 defsubr (&Sputhash
);
5186 defsubr (&Sremhash
);
5187 defsubr (&Smaphash
);
5188 defsubr (&Sdefine_hash_table_test
);
5190 Qstring_lessp
= intern ("string-lessp");
5191 staticpro (&Qstring_lessp
);
5192 Qprovide
= intern ("provide");
5193 staticpro (&Qprovide
);
5194 Qrequire
= intern ("require");
5195 staticpro (&Qrequire
);
5196 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5197 staticpro (&Qyes_or_no_p_history
);
5198 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5199 staticpro (&Qcursor_in_echo_area
);
5200 Qwidget_type
= intern ("widget-type");
5201 staticpro (&Qwidget_type
);
5203 staticpro (&string_char_byte_cache_string
);
5204 string_char_byte_cache_string
= Qnil
;
5206 require_nesting_list
= Qnil
;
5207 staticpro (&require_nesting_list
);
5209 Fset (Qyes_or_no_p_history
, Qnil
);
5211 DEFVAR_LISP ("features", &Vfeatures
,
5212 doc
: /* A list of symbols which are the features of the executing Emacs.
5213 Used by `featurep' and `require', and altered by `provide'. */);
5214 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5215 Qsubfeatures
= intern ("subfeatures");
5216 staticpro (&Qsubfeatures
);
5218 #ifdef HAVE_LANGINFO_CODESET
5219 Qcodeset
= intern ("codeset");
5220 staticpro (&Qcodeset
);
5221 Qdays
= intern ("days");
5223 Qmonths
= intern ("months");
5224 staticpro (&Qmonths
);
5225 Qpaper
= intern ("paper");
5226 staticpro (&Qpaper
);
5227 #endif /* HAVE_LANGINFO_CODESET */
5229 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5230 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5231 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5232 invoked by mouse clicks and mouse menu items.
5234 On some platforms, file selection dialogs are also enabled if this is
5238 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5239 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5240 This applies to commands from menus and tool bar buttons even when
5241 they are initiated from the keyboard. The value of `use-dialog-box'
5242 takes precedence over this variable, so a file dialog is only used if
5243 both `use-dialog-box' and this variable are non-nil. */);
5244 use_file_dialog
= 1;
5246 defsubr (&Sidentity
);
5249 defsubr (&Ssafe_length
);
5250 defsubr (&Sstring_bytes
);
5251 defsubr (&Sstring_equal
);
5252 defsubr (&Scompare_strings
);
5253 defsubr (&Sstring_lessp
);
5256 defsubr (&Svconcat
);
5257 defsubr (&Scopy_sequence
);
5258 defsubr (&Sstring_make_multibyte
);
5259 defsubr (&Sstring_make_unibyte
);
5260 defsubr (&Sstring_as_multibyte
);
5261 defsubr (&Sstring_as_unibyte
);
5262 defsubr (&Sstring_to_multibyte
);
5263 defsubr (&Sstring_to_unibyte
);
5264 defsubr (&Scopy_alist
);
5265 defsubr (&Ssubstring
);
5266 defsubr (&Ssubstring_no_properties
);
5279 defsubr (&Snreverse
);
5280 defsubr (&Sreverse
);
5282 defsubr (&Splist_get
);
5284 defsubr (&Splist_put
);
5286 defsubr (&Slax_plist_get
);
5287 defsubr (&Slax_plist_put
);
5290 defsubr (&Sequal_including_properties
);
5291 defsubr (&Sfillarray
);
5292 defsubr (&Sclear_string
);
5296 defsubr (&Smapconcat
);
5297 defsubr (&Sy_or_n_p
);
5298 defsubr (&Syes_or_no_p
);
5299 defsubr (&Sload_average
);
5300 defsubr (&Sfeaturep
);
5301 defsubr (&Srequire
);
5302 defsubr (&Sprovide
);
5303 defsubr (&Splist_member
);
5304 defsubr (&Swidget_put
);
5305 defsubr (&Swidget_get
);
5306 defsubr (&Swidget_apply
);
5307 defsubr (&Sbase64_encode_region
);
5308 defsubr (&Sbase64_decode_region
);
5309 defsubr (&Sbase64_encode_string
);
5310 defsubr (&Sbase64_decode_string
);
5312 defsubr (&Slocale_info
);
5321 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5322 (do not change this comment) */