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, 2009 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/>. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
36 #include "character.h"
41 #include "intervals.h"
44 #include "blockinput.h"
46 #if defined (HAVE_X_WINDOWS)
49 #endif /* HAVE_MENUS */
52 #define NULL ((POINTER_TYPE *)0)
55 /* Nonzero enables use of dialog boxes for questions
56 asked by mouse commands. */
59 /* Nonzero enables use of a file dialog for file name
60 questions asked by mouse commands. */
63 extern int minibuffer_auto_raise
;
64 extern Lisp_Object minibuf_window
;
65 extern Lisp_Object Vlocale_coding_system
;
66 extern int load_in_progress
;
68 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
69 Lisp_Object Qyes_or_no_p_history
;
70 Lisp_Object Qcursor_in_echo_area
;
71 Lisp_Object Qwidget_type
;
72 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
74 extern Lisp_Object Qinput_method_function
;
76 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
78 extern long get_random ();
79 extern void seed_random
P_ ((long));
85 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
86 doc
: /* Return the argument unchanged. */)
93 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
94 doc
: /* Return a pseudo-random number.
95 All integers representable in Lisp are equally likely.
96 On most systems, this is 29 bits' worth.
97 With positive integer LIMIT, return random number in interval [0,LIMIT).
98 With argument t, set the random number seed from the current time and pid.
99 Other values of LIMIT are ignored. */)
104 Lisp_Object lispy_val
;
105 unsigned long denominator
;
108 seed_random (getpid () + time (NULL
));
109 if (NATNUMP (limit
) && XFASTINT (limit
) != 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 (limit
);
120 val
= get_random () / denominator
;
121 while (val
>= XFASTINT (limit
));
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 MAKE_CHAR_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 MAKE_CHAR_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),
606 error ("String overflow");
609 if (! some_multibyte
)
610 result_len_byte
= result_len
;
612 /* Create the output object. */
613 if (target_type
== Lisp_Cons
)
614 val
= Fmake_list (make_number (result_len
), Qnil
);
615 else if (target_type
== Lisp_Vectorlike
)
616 val
= Fmake_vector (make_number (result_len
), Qnil
);
617 else if (some_multibyte
)
618 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
620 val
= make_uninit_string (result_len
);
622 /* In `append', if all but last arg are nil, return last arg. */
623 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
626 /* Copy the contents of the args into the result. */
628 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
630 toindex
= 0, toindex_byte
= 0;
634 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
636 for (argnum
= 0; argnum
< nargs
; argnum
++)
640 register unsigned int thisindex
= 0;
641 register unsigned int thisindex_byte
= 0;
645 thislen
= Flength (this), thisleni
= XINT (thislen
);
647 /* Between strings of the same kind, copy fast. */
648 if (STRINGP (this) && STRINGP (val
)
649 && STRING_MULTIBYTE (this) == some_multibyte
)
651 int thislen_byte
= SBYTES (this);
653 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
655 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
657 textprops
[num_textprops
].argnum
= argnum
;
658 textprops
[num_textprops
].from
= 0;
659 textprops
[num_textprops
++].to
= toindex
;
661 toindex_byte
+= thislen_byte
;
664 /* Copy a single-byte string to a multibyte string. */
665 else if (STRINGP (this) && STRINGP (val
))
667 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
669 textprops
[num_textprops
].argnum
= argnum
;
670 textprops
[num_textprops
].from
= 0;
671 textprops
[num_textprops
++].to
= toindex
;
673 toindex_byte
+= copy_text (SDATA (this),
674 SDATA (val
) + toindex_byte
,
675 SCHARS (this), 0, 1);
679 /* Copy element by element. */
682 register Lisp_Object elt
;
684 /* Fetch next element of `this' arg into `elt', or break if
685 `this' is exhausted. */
686 if (NILP (this)) break;
688 elt
= XCAR (this), this = XCDR (this);
689 else if (thisindex
>= thisleni
)
691 else if (STRINGP (this))
694 if (STRING_MULTIBYTE (this))
696 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
699 XSETFASTINT (elt
, c
);
703 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
705 && !ASCII_CHAR_P (XINT (elt
))
706 && XINT (elt
) < 0400)
708 c
= BYTE8_TO_CHAR (XINT (elt
));
713 else if (BOOL_VECTOR_P (this))
716 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
717 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
725 elt
= AREF (this, thisindex
);
729 /* Store this element into the result. */
736 else if (VECTORP (val
))
738 ASET (val
, toindex
, elt
);
745 toindex_byte
+= CHAR_STRING (XINT (elt
),
746 SDATA (val
) + toindex_byte
);
748 SSET (val
, toindex_byte
++, XINT (elt
));
754 XSETCDR (prev
, last_tail
);
756 if (num_textprops
> 0)
759 int last_to_end
= -1;
761 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
763 this = args
[textprops
[argnum
].argnum
];
764 props
= text_property_list (this,
766 make_number (SCHARS (this)),
768 /* If successive arguments have properites, be sure that the
769 value of `composition' property be the copy. */
770 if (last_to_end
== textprops
[argnum
].to
)
771 make_composition_value_copy (props
);
772 add_text_properties_from_list (val
, props
,
773 make_number (textprops
[argnum
].to
));
774 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
782 static Lisp_Object string_char_byte_cache_string
;
783 static EMACS_INT string_char_byte_cache_charpos
;
784 static EMACS_INT string_char_byte_cache_bytepos
;
787 clear_string_char_byte_cache ()
789 string_char_byte_cache_string
= Qnil
;
792 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
795 string_char_to_byte (string
, char_index
)
797 EMACS_INT char_index
;
800 EMACS_INT best_below
, best_below_byte
;
801 EMACS_INT best_above
, best_above_byte
;
803 best_below
= best_below_byte
= 0;
804 best_above
= SCHARS (string
);
805 best_above_byte
= SBYTES (string
);
806 if (best_above
== best_above_byte
)
809 if (EQ (string
, string_char_byte_cache_string
))
811 if (string_char_byte_cache_charpos
< char_index
)
813 best_below
= string_char_byte_cache_charpos
;
814 best_below_byte
= string_char_byte_cache_bytepos
;
818 best_above
= string_char_byte_cache_charpos
;
819 best_above_byte
= string_char_byte_cache_bytepos
;
823 if (char_index
- best_below
< best_above
- char_index
)
825 unsigned char *p
= SDATA (string
) + best_below_byte
;
827 while (best_below
< char_index
)
829 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
838 while (best_above
> char_index
)
841 while (!CHAR_HEAD_P (*p
)) p
--;
844 i_byte
= p
- SDATA (string
);
847 string_char_byte_cache_bytepos
= i_byte
;
848 string_char_byte_cache_charpos
= char_index
;
849 string_char_byte_cache_string
= string
;
854 /* Return the character index corresponding to BYTE_INDEX in STRING. */
857 string_byte_to_char (string
, byte_index
)
859 EMACS_INT byte_index
;
862 EMACS_INT best_below
, best_below_byte
;
863 EMACS_INT best_above
, best_above_byte
;
865 best_below
= best_below_byte
= 0;
866 best_above
= SCHARS (string
);
867 best_above_byte
= SBYTES (string
);
868 if (best_above
== best_above_byte
)
871 if (EQ (string
, string_char_byte_cache_string
))
873 if (string_char_byte_cache_bytepos
< byte_index
)
875 best_below
= string_char_byte_cache_charpos
;
876 best_below_byte
= string_char_byte_cache_bytepos
;
880 best_above
= string_char_byte_cache_charpos
;
881 best_above_byte
= string_char_byte_cache_bytepos
;
885 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
887 unsigned char *p
= SDATA (string
) + best_below_byte
;
888 unsigned char *pend
= SDATA (string
) + byte_index
;
892 p
+= BYTES_BY_CHAR_HEAD (*p
);
896 i_byte
= p
- SDATA (string
);
900 unsigned char *p
= SDATA (string
) + best_above_byte
;
901 unsigned char *pbeg
= SDATA (string
) + byte_index
;
906 while (!CHAR_HEAD_P (*p
)) p
--;
910 i_byte
= p
- SDATA (string
);
913 string_char_byte_cache_bytepos
= i_byte
;
914 string_char_byte_cache_charpos
= i
;
915 string_char_byte_cache_string
= string
;
920 /* Convert STRING to a multibyte string. */
923 string_make_multibyte (string
)
931 if (STRING_MULTIBYTE (string
))
934 nbytes
= count_size_as_multibyte (SDATA (string
),
936 /* If all the chars are ASCII, they won't need any more bytes
937 once converted. In that case, we can return STRING itself. */
938 if (nbytes
== SBYTES (string
))
941 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
942 copy_text (SDATA (string
), buf
, SBYTES (string
),
945 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
952 /* Convert STRING (if unibyte) to a multibyte string without changing
953 the number of characters. Characters 0200 trough 0237 are
954 converted to eight-bit characters. */
957 string_to_multibyte (string
)
965 if (STRING_MULTIBYTE (string
))
968 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
969 /* If all the chars are ASCII, they won't need any more bytes once
971 if (nbytes
== SBYTES (string
))
972 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
974 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
975 bcopy (SDATA (string
), buf
, SBYTES (string
));
976 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
978 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
985 /* Convert STRING to a single-byte string. */
988 string_make_unibyte (string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string (buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 \(When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1025 CHECK_STRING (string
);
1027 return string_make_multibyte (string
);
1030 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1032 doc
: /* Return the unibyte equivalent of STRING.
1033 Multibyte character codes are converted to unibyte according to
1034 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1035 If the lookup in the translation table fails, this function takes just
1036 the low 8 bits of each character. */)
1040 CHECK_STRING (string
);
1042 return string_make_unibyte (string
);
1045 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1047 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1048 If STRING is unibyte, the result is STRING itself.
1049 Otherwise it is a newly created string, with no text properties.
1050 If STRING is multibyte and contains a character of charset
1051 `eight-bit', it is converted to the corresponding single byte. */)
1055 CHECK_STRING (string
);
1057 if (STRING_MULTIBYTE (string
))
1059 int bytes
= SBYTES (string
);
1060 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1062 bcopy (SDATA (string
), str
, bytes
);
1063 bytes
= str_as_unibyte (str
, bytes
);
1064 string
= make_unibyte_string (str
, bytes
);
1070 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1072 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1073 If STRING is multibyte, the result is STRING itself.
1074 Otherwise it is a newly created string, with no text properties.
1076 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1077 part of a correct utf-8 sequence), it is converted to the corresponding
1078 multibyte character of charset `eight-bit'.
1079 See also `string-to-multibyte'.
1081 Beware, this often doesn't really do what you think it does.
1082 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1083 If you're not sure, whether to use `string-as-multibyte' or
1084 `string-to-multibyte', use `string-to-multibyte'. */)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 bcopy (SDATA (string
), SDATA (new_string
),
1101 if (nbytes
!= SBYTES (string
))
1102 str_as_multibyte (SDATA (new_string
), nbytes
,
1103 SBYTES (string
), NULL
);
1104 string
= new_string
;
1105 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1110 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1112 doc
: /* Return a multibyte string with the same individual chars as STRING.
1113 If STRING is multibyte, the result is STRING itself.
1114 Otherwise it is a newly created string, with no text properties.
1116 If STRING is unibyte and contains an 8-bit byte, it is converted to
1117 the corresponding multibyte character of charset `eight-bit'.
1119 This differs from `string-as-multibyte' by converting each byte of a correct
1120 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1121 correct sequence. */)
1125 CHECK_STRING (string
);
1127 return string_to_multibyte (string
);
1130 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1132 doc
: /* Return a unibyte string with the same individual chars as STRING.
1133 If STRING is unibyte, the result is STRING itself.
1134 Otherwise it is a newly created string, with no text properties,
1135 where each `eight-bit' character is converted to the corresponding byte.
1136 If STRING contains a non-ASCII, non-`eight-bit' character,
1137 an error is signaled. */)
1141 CHECK_STRING (string
);
1143 if (STRING_MULTIBYTE (string
))
1145 EMACS_INT chars
= SCHARS (string
);
1146 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1147 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1149 if (converted
< chars
)
1150 error ("Can't convert the %dth character to unibyte", converted
);
1151 string
= make_unibyte_string (str
, chars
);
1158 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1159 doc
: /* Return a copy of ALIST.
1160 This is an alist which represents the same mapping from objects to objects,
1161 but does not share the alist structure with ALIST.
1162 The objects mapped (cars and cdrs of elements of the alist)
1163 are shared, however.
1164 Elements of ALIST that are not conses are also shared. */)
1168 register Lisp_Object tem
;
1173 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1174 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1176 register Lisp_Object car
;
1180 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1185 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1186 doc
: /* Return a new string whose contents are a substring of STRING.
1187 The returned string consists of the characters between index FROM
1188 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1189 zero-indexed: 0 means the first character of STRING. Negative values
1190 are counted from the end of STRING. If TO is nil, the substring runs
1191 to the end of STRING.
1193 The STRING argument may also be a vector. In that case, the return
1194 value is a new vector that contains the elements between index FROM
1195 \(inclusive) and index TO (exclusive) of that vector argument. */)
1198 register Lisp_Object from
, to
;
1203 int from_char
, to_char
;
1204 int from_byte
= 0, to_byte
= 0;
1206 CHECK_VECTOR_OR_STRING (string
);
1207 CHECK_NUMBER (from
);
1209 if (STRINGP (string
))
1211 size
= SCHARS (string
);
1212 size_byte
= SBYTES (string
);
1215 size
= ASIZE (string
);
1220 to_byte
= size_byte
;
1226 to_char
= XINT (to
);
1230 if (STRINGP (string
))
1231 to_byte
= string_char_to_byte (string
, to_char
);
1234 from_char
= XINT (from
);
1237 if (STRINGP (string
))
1238 from_byte
= string_char_to_byte (string
, from_char
);
1240 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1241 args_out_of_range_3 (string
, make_number (from_char
),
1242 make_number (to_char
));
1244 if (STRINGP (string
))
1246 res
= make_specified_string (SDATA (string
) + from_byte
,
1247 to_char
- from_char
, to_byte
- from_byte
,
1248 STRING_MULTIBYTE (string
));
1249 copy_text_properties (make_number (from_char
), make_number (to_char
),
1250 string
, make_number (0), res
, Qnil
);
1253 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1259 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1260 doc
: /* Return a substring of STRING, without text properties.
1261 It starts at index FROM and ending before TO.
1262 TO may be nil or omitted; then the substring runs to the end of STRING.
1263 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1264 If FROM or TO is negative, it counts from the end.
1266 With one argument, just copy STRING without its properties. */)
1269 register Lisp_Object from
, to
;
1271 int size
, size_byte
;
1272 int from_char
, to_char
;
1273 int from_byte
, to_byte
;
1275 CHECK_STRING (string
);
1277 size
= SCHARS (string
);
1278 size_byte
= SBYTES (string
);
1281 from_char
= from_byte
= 0;
1284 CHECK_NUMBER (from
);
1285 from_char
= XINT (from
);
1289 from_byte
= string_char_to_byte (string
, from_char
);
1295 to_byte
= size_byte
;
1301 to_char
= XINT (to
);
1305 to_byte
= string_char_to_byte (string
, to_char
);
1308 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1309 args_out_of_range_3 (string
, make_number (from_char
),
1310 make_number (to_char
));
1312 return make_specified_string (SDATA (string
) + from_byte
,
1313 to_char
- from_char
, to_byte
- from_byte
,
1314 STRING_MULTIBYTE (string
));
1317 /* Extract a substring of STRING, giving start and end positions
1318 both in characters and in bytes. */
1321 substring_both (string
, from
, from_byte
, to
, to_byte
)
1323 int from
, from_byte
, to
, to_byte
;
1329 CHECK_VECTOR_OR_STRING (string
);
1331 if (STRINGP (string
))
1333 size
= SCHARS (string
);
1334 size_byte
= SBYTES (string
);
1337 size
= ASIZE (string
);
1339 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1340 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1342 if (STRINGP (string
))
1344 res
= make_specified_string (SDATA (string
) + from_byte
,
1345 to
- from
, to_byte
- from_byte
,
1346 STRING_MULTIBYTE (string
));
1347 copy_text_properties (make_number (from
), make_number (to
),
1348 string
, make_number (0), res
, Qnil
);
1351 res
= Fvector (to
- from
, &AREF (string
, from
));
1356 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1357 doc
: /* Take cdr N times on LIST, returns the result. */)
1360 register Lisp_Object list
;
1362 register int i
, num
;
1365 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1368 CHECK_LIST_CONS (list
, list
);
1374 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1375 doc
: /* Return the Nth element of LIST.
1376 N counts from zero. If LIST is not that long, nil is returned. */)
1378 Lisp_Object n
, list
;
1380 return Fcar (Fnthcdr (n
, list
));
1383 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1384 doc
: /* Return element of SEQUENCE at index N. */)
1386 register Lisp_Object sequence
, n
;
1389 if (CONSP (sequence
) || NILP (sequence
))
1390 return Fcar (Fnthcdr (n
, sequence
));
1392 /* Faref signals a "not array" error, so check here. */
1393 CHECK_ARRAY (sequence
, Qsequencep
);
1394 return Faref (sequence
, n
);
1397 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1398 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1399 The value is actually the tail of LIST whose car is ELT. */)
1401 register Lisp_Object elt
;
1404 register Lisp_Object tail
;
1405 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1407 register Lisp_Object tem
;
1408 CHECK_LIST_CONS (tail
, list
);
1410 if (! NILP (Fequal (elt
, tem
)))
1417 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1418 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1419 The value is actually the tail of LIST whose car is ELT. */)
1421 register Lisp_Object elt
, list
;
1425 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1429 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1433 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1444 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1445 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1446 The value is actually the tail of LIST whose car is ELT. */)
1448 register Lisp_Object elt
;
1451 register Lisp_Object tail
;
1454 return Fmemq (elt
, list
);
1456 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1458 register Lisp_Object tem
;
1459 CHECK_LIST_CONS (tail
, list
);
1461 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1468 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1469 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1470 The value is actually the first element of LIST whose car is KEY.
1471 Elements of LIST that are not conses are ignored. */)
1473 Lisp_Object key
, list
;
1478 || (CONSP (XCAR (list
))
1479 && EQ (XCAR (XCAR (list
)), key
)))
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCAR (XCAR (list
)), key
)))
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCAR (XCAR (list
)), key
)))
1501 /* Like Fassq but never report an error and do not allow quits.
1502 Use only on lists known never to be circular. */
1505 assq_no_quit (key
, list
)
1506 Lisp_Object key
, list
;
1509 && (!CONSP (XCAR (list
))
1510 || !EQ (XCAR (XCAR (list
)), key
)))
1513 return CAR_SAFE (list
);
1516 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1517 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1518 The value is actually the first element of LIST whose car equals KEY. */)
1520 Lisp_Object key
, list
;
1527 || (CONSP (XCAR (list
))
1528 && (car
= XCAR (XCAR (list
)),
1529 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (car
= XCAR (XCAR (list
)),
1536 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (car
= XCAR (XCAR (list
)),
1543 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1553 /* Like Fassoc but never report an error and do not allow quits.
1554 Use only on lists known never to be circular. */
1557 assoc_no_quit (key
, list
)
1558 Lisp_Object key
, list
;
1561 && (!CONSP (XCAR (list
))
1562 || (!EQ (XCAR (XCAR (list
)), key
)
1563 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1566 return CONSP (list
) ? XCAR (list
) : Qnil
;
1569 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1570 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1571 The value is actually the first element of LIST whose cdr is KEY. */)
1573 register Lisp_Object key
;
1579 || (CONSP (XCAR (list
))
1580 && EQ (XCDR (XCAR (list
)), key
)))
1585 || (CONSP (XCAR (list
))
1586 && EQ (XCDR (XCAR (list
)), key
)))
1591 || (CONSP (XCAR (list
))
1592 && EQ (XCDR (XCAR (list
)), key
)))
1602 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1603 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1604 The value is actually the first element of LIST whose cdr equals KEY. */)
1606 Lisp_Object key
, list
;
1613 || (CONSP (XCAR (list
))
1614 && (cdr
= XCDR (XCAR (list
)),
1615 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1620 || (CONSP (XCAR (list
))
1621 && (cdr
= XCDR (XCAR (list
)),
1622 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1627 || (CONSP (XCAR (list
))
1628 && (cdr
= XCDR (XCAR (list
)),
1629 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1639 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1640 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1641 The modified LIST is returned. Comparison is done with `eq'.
1642 If the first member of LIST is ELT, there is no way to remove it by side effect;
1643 therefore, write `(setq foo (delq element foo))'
1644 to be sure of changing the value of `foo'. */)
1646 register Lisp_Object elt
;
1649 register Lisp_Object tail
, prev
;
1650 register Lisp_Object tem
;
1654 while (!NILP (tail
))
1656 CHECK_LIST_CONS (tail
, list
);
1663 Fsetcdr (prev
, XCDR (tail
));
1673 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1674 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1675 SEQ must be a list, a vector, or a string.
1676 The modified SEQ is returned. Comparison is done with `equal'.
1677 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1678 is not a side effect; it is simply using a different sequence.
1679 Therefore, write `(setq foo (delete element foo))'
1680 to be sure of changing the value of `foo'. */)
1682 Lisp_Object elt
, seq
;
1688 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1689 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1692 if (n
!= ASIZE (seq
))
1694 struct Lisp_Vector
*p
= allocate_vector (n
);
1696 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1697 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1698 p
->contents
[n
++] = AREF (seq
, i
);
1700 XSETVECTOR (seq
, p
);
1703 else if (STRINGP (seq
))
1705 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1708 for (i
= nchars
= nbytes
= ibyte
= 0;
1710 ++i
, ibyte
+= cbytes
)
1712 if (STRING_MULTIBYTE (seq
))
1714 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1715 SBYTES (seq
) - ibyte
);
1716 cbytes
= CHAR_BYTES (c
);
1724 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1731 if (nchars
!= SCHARS (seq
))
1735 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1736 if (!STRING_MULTIBYTE (seq
))
1737 STRING_SET_UNIBYTE (tem
);
1739 for (i
= nchars
= nbytes
= ibyte
= 0;
1741 ++i
, ibyte
+= cbytes
)
1743 if (STRING_MULTIBYTE (seq
))
1745 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1746 SBYTES (seq
) - ibyte
);
1747 cbytes
= CHAR_BYTES (c
);
1755 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1757 unsigned char *from
= SDATA (seq
) + ibyte
;
1758 unsigned char *to
= SDATA (tem
) + nbytes
;
1764 for (n
= cbytes
; n
--; )
1774 Lisp_Object tail
, prev
;
1776 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1778 CHECK_LIST_CONS (tail
, seq
);
1780 if (!NILP (Fequal (elt
, XCAR (tail
))))
1785 Fsetcdr (prev
, XCDR (tail
));
1796 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1797 doc
: /* Reverse LIST by modifying cdr pointers.
1798 Return the reversed list. */)
1802 register Lisp_Object prev
, tail
, next
;
1804 if (NILP (list
)) return list
;
1807 while (!NILP (tail
))
1810 CHECK_LIST_CONS (tail
, list
);
1812 Fsetcdr (tail
, prev
);
1819 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1820 doc
: /* Reverse LIST, copying. Return the reversed list.
1821 See also the function `nreverse', which is used more often. */)
1827 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1830 new = Fcons (XCAR (list
), new);
1832 CHECK_LIST_END (list
, list
);
1836 Lisp_Object
merge ();
1838 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1839 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1840 Returns the sorted list. LIST is modified by side effects.
1841 PREDICATE is called with two elements of LIST, and should return non-nil
1842 if the first element should sort before the second. */)
1844 Lisp_Object list
, predicate
;
1846 Lisp_Object front
, back
;
1847 register Lisp_Object len
, tem
;
1848 struct gcpro gcpro1
, gcpro2
;
1849 register int length
;
1852 len
= Flength (list
);
1853 length
= XINT (len
);
1857 XSETINT (len
, (length
/ 2) - 1);
1858 tem
= Fnthcdr (len
, list
);
1860 Fsetcdr (tem
, Qnil
);
1862 GCPRO2 (front
, back
);
1863 front
= Fsort (front
, predicate
);
1864 back
= Fsort (back
, predicate
);
1866 return merge (front
, back
, predicate
);
1870 merge (org_l1
, org_l2
, pred
)
1871 Lisp_Object org_l1
, org_l2
;
1875 register Lisp_Object tail
;
1877 register Lisp_Object l1
, l2
;
1878 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1885 /* It is sufficient to protect org_l1 and org_l2.
1886 When l1 and l2 are updated, we copy the new values
1887 back into the org_ vars. */
1888 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1908 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1924 Fsetcdr (tail
, tem
);
1930 #if 0 /* Unsafe version. */
1931 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1932 doc
: /* Extract a value from a property list.
1933 PLIST is a property list, which is a list of the form
1934 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1935 corresponding to the given PROP, or nil if PROP is not
1936 one of the properties on the list. */)
1944 CONSP (tail
) && CONSP (XCDR (tail
));
1945 tail
= XCDR (XCDR (tail
)))
1947 if (EQ (prop
, XCAR (tail
)))
1948 return XCAR (XCDR (tail
));
1950 /* This function can be called asynchronously
1951 (setup_coding_system). Don't QUIT in that case. */
1952 if (!interrupt_input_blocked
)
1956 CHECK_LIST_END (tail
, prop
);
1962 /* This does not check for quits. That is safe since it must terminate. */
1964 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1965 doc
: /* Extract a value from a property list.
1966 PLIST is a property list, which is a list of the form
1967 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1968 corresponding to the given PROP, or nil if PROP is not one of the
1969 properties on the list. This function never signals an error. */)
1974 Lisp_Object tail
, halftail
;
1976 /* halftail is used to detect circular lists. */
1977 tail
= halftail
= plist
;
1978 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1980 if (EQ (prop
, XCAR (tail
)))
1981 return XCAR (XCDR (tail
));
1983 tail
= XCDR (XCDR (tail
));
1984 halftail
= XCDR (halftail
);
1985 if (EQ (tail
, halftail
))
1992 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1993 doc
: /* Return the value of SYMBOL's PROPNAME property.
1994 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1996 Lisp_Object symbol
, propname
;
1998 CHECK_SYMBOL (symbol
);
1999 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2002 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2003 doc
: /* Change value in PLIST of PROP to VAL.
2004 PLIST is a property list, which is a list of the form
2005 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2006 If PROP is already a property on the list, its value is set to VAL,
2007 otherwise the new PROP VAL pair is added. The new plist is returned;
2008 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2009 The PLIST is modified by side effects. */)
2012 register Lisp_Object prop
;
2015 register Lisp_Object tail
, prev
;
2016 Lisp_Object newcell
;
2018 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2019 tail
= XCDR (XCDR (tail
)))
2021 if (EQ (prop
, XCAR (tail
)))
2023 Fsetcar (XCDR (tail
), val
);
2030 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2034 Fsetcdr (XCDR (prev
), newcell
);
2038 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2039 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2040 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2041 (symbol
, propname
, value
)
2042 Lisp_Object symbol
, propname
, value
;
2044 CHECK_SYMBOL (symbol
);
2045 XSYMBOL (symbol
)->plist
2046 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2050 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2051 doc
: /* Extract a value from a property list, comparing with `equal'.
2052 PLIST is a property list, which is a list of the form
2053 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2054 corresponding to the given PROP, or nil if PROP is not
2055 one of the properties on the list. */)
2063 CONSP (tail
) && CONSP (XCDR (tail
));
2064 tail
= XCDR (XCDR (tail
)))
2066 if (! NILP (Fequal (prop
, XCAR (tail
))))
2067 return XCAR (XCDR (tail
));
2072 CHECK_LIST_END (tail
, prop
);
2077 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2078 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2079 PLIST is a property list, which is a list of the form
2080 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2081 If PROP is already a property on the list, its value is set to VAL,
2082 otherwise the new PROP VAL pair is added. The new plist is returned;
2083 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2084 The PLIST is modified by side effects. */)
2087 register Lisp_Object prop
;
2090 register Lisp_Object tail
, prev
;
2091 Lisp_Object newcell
;
2093 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2094 tail
= XCDR (XCDR (tail
)))
2096 if (! NILP (Fequal (prop
, XCAR (tail
))))
2098 Fsetcar (XCDR (tail
), val
);
2105 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2109 Fsetcdr (XCDR (prev
), newcell
);
2113 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2114 doc
: /* Return t if the two args are the same Lisp object.
2115 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2117 Lisp_Object obj1
, obj2
;
2120 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2122 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2125 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2126 doc
: /* Return t if two Lisp objects have similar structure and contents.
2127 They must have the same data type.
2128 Conses are compared by comparing the cars and the cdrs.
2129 Vectors and strings are compared element by element.
2130 Numbers are compared by value, but integers cannot equal floats.
2131 (Use `=' if you want integers and floats to be able to be equal.)
2132 Symbols must match exactly. */)
2134 register Lisp_Object o1
, o2
;
2136 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2139 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2140 doc
: /* Return t if two Lisp objects have similar structure and contents.
2141 This is like `equal' except that it compares the text properties
2142 of strings. (`equal' ignores text properties.) */)
2144 register Lisp_Object o1
, o2
;
2146 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2149 /* DEPTH is current depth of recursion. Signal an error if it
2151 PROPS, if non-nil, means compare string text properties too. */
2154 internal_equal (o1
, o2
, depth
, props
)
2155 register Lisp_Object o1
, o2
;
2159 error ("Stack overflow in equal");
2165 if (XTYPE (o1
) != XTYPE (o2
))
2174 d1
= extract_float (o1
);
2175 d2
= extract_float (o2
);
2176 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2177 though they are not =. */
2178 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2182 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2189 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2193 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2195 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2198 o1
= XOVERLAY (o1
)->plist
;
2199 o2
= XOVERLAY (o2
)->plist
;
2204 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2205 && (XMARKER (o1
)->buffer
== 0
2206 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2210 case Lisp_Vectorlike
:
2213 EMACS_INT size
= ASIZE (o1
);
2214 /* Pseudovectors have the type encoded in the size field, so this test
2215 actually checks that the objects have the same type as well as the
2217 if (ASIZE (o2
) != size
)
2219 /* Boolvectors are compared much like strings. */
2220 if (BOOL_VECTOR_P (o1
))
2223 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2224 / BOOL_VECTOR_BITS_PER_CHAR
);
2226 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2228 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2233 if (WINDOW_CONFIGURATIONP (o1
))
2234 return compare_window_configurations (o1
, o2
, 0);
2236 /* Aside from them, only true vectors, char-tables, compiled
2237 functions, and fonts (font-spec, font-entity, font-ojbect)
2238 are sensible to compare, so eliminate the others now. */
2239 if (size
& PSEUDOVECTOR_FLAG
)
2241 if (!(size
& (PVEC_COMPILED
2242 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2244 size
&= PSEUDOVECTOR_SIZE_MASK
;
2246 for (i
= 0; i
< size
; i
++)
2251 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2259 if (SCHARS (o1
) != SCHARS (o2
))
2261 if (SBYTES (o1
) != SBYTES (o2
))
2263 if (bcmp (SDATA (o1
), SDATA (o2
),
2266 if (props
&& !compare_string_intervals (o1
, o2
))
2272 case Lisp_Type_Limit
:
2279 extern Lisp_Object
Fmake_char_internal ();
2281 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2282 doc
: /* Store each element of ARRAY with ITEM.
2283 ARRAY is a vector, string, char-table, or bool-vector. */)
2285 Lisp_Object array
, item
;
2287 register int size
, index
, charval
;
2288 if (VECTORP (array
))
2290 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2291 size
= ASIZE (array
);
2292 for (index
= 0; index
< size
; index
++)
2295 else if (CHAR_TABLE_P (array
))
2299 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2300 XCHAR_TABLE (array
)->contents
[i
] = item
;
2301 XCHAR_TABLE (array
)->defalt
= item
;
2303 else if (STRINGP (array
))
2305 register unsigned char *p
= SDATA (array
);
2306 CHECK_NUMBER (item
);
2307 charval
= XINT (item
);
2308 size
= SCHARS (array
);
2309 if (STRING_MULTIBYTE (array
))
2311 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2312 int len
= CHAR_STRING (charval
, str
);
2313 int size_byte
= SBYTES (array
);
2314 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2317 if (size
!= size_byte
)
2320 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2321 if (len
!= this_len
)
2322 error ("Attempt to change byte length of a string");
2325 for (i
= 0; i
< size_byte
; i
++)
2326 *p
++ = str
[i
% len
];
2329 for (index
= 0; index
< size
; index
++)
2332 else if (BOOL_VECTOR_P (array
))
2334 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2336 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2337 / BOOL_VECTOR_BITS_PER_CHAR
);
2339 charval
= (! NILP (item
) ? -1 : 0);
2340 for (index
= 0; index
< size_in_chars
- 1; index
++)
2342 if (index
< size_in_chars
)
2344 /* Mask out bits beyond the vector size. */
2345 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2346 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2351 wrong_type_argument (Qarrayp
, array
);
2355 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2357 doc
: /* Clear the contents of STRING.
2358 This makes STRING unibyte and may change its length. */)
2363 CHECK_STRING (string
);
2364 len
= SBYTES (string
);
2365 bzero (SDATA (string
), len
);
2366 STRING_SET_CHARS (string
, len
);
2367 STRING_SET_UNIBYTE (string
);
2377 Lisp_Object args
[2];
2380 return Fnconc (2, args
);
2382 return Fnconc (2, &s1
);
2383 #endif /* NO_ARG_ARRAY */
2386 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2387 doc
: /* Concatenate any number of lists by altering them.
2388 Only the last argument is not altered, and need not be a list.
2389 usage: (nconc &rest LISTS) */)
2394 register int argnum
;
2395 register Lisp_Object tail
, tem
, val
;
2399 for (argnum
= 0; argnum
< nargs
; argnum
++)
2402 if (NILP (tem
)) continue;
2407 if (argnum
+ 1 == nargs
) break;
2409 CHECK_LIST_CONS (tem
, tem
);
2418 tem
= args
[argnum
+ 1];
2419 Fsetcdr (tail
, tem
);
2421 args
[argnum
+ 1] = tail
;
2427 /* This is the guts of all mapping functions.
2428 Apply FN to each element of SEQ, one by one,
2429 storing the results into elements of VALS, a C vector of Lisp_Objects.
2430 LENI is the length of VALS, which should also be the length of SEQ. */
2433 mapcar1 (leni
, vals
, fn
, seq
)
2436 Lisp_Object fn
, seq
;
2438 register Lisp_Object tail
;
2441 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2445 /* Don't let vals contain any garbage when GC happens. */
2446 for (i
= 0; i
< leni
; i
++)
2449 GCPRO3 (dummy
, fn
, seq
);
2451 gcpro1
.nvars
= leni
;
2455 /* We need not explicitly protect `tail' because it is used only on lists, and
2456 1) lists are not relocated and 2) the list is marked via `seq' so will not
2461 for (i
= 0; i
< leni
; i
++)
2463 dummy
= call1 (fn
, AREF (seq
, i
));
2468 else if (BOOL_VECTOR_P (seq
))
2470 for (i
= 0; i
< leni
; i
++)
2473 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2474 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2475 dummy
= call1 (fn
, dummy
);
2480 else if (STRINGP (seq
))
2484 for (i
= 0, i_byte
= 0; i
< leni
;)
2489 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2490 XSETFASTINT (dummy
, c
);
2491 dummy
= call1 (fn
, dummy
);
2493 vals
[i_before
] = dummy
;
2496 else /* Must be a list, since Flength did not get an error */
2499 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2501 dummy
= call1 (fn
, XCAR (tail
));
2511 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2512 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2513 In between each pair of results, stick in SEPARATOR. Thus, " " as
2514 SEPARATOR results in spaces between the values returned by FUNCTION.
2515 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2516 (function
, sequence
, separator
)
2517 Lisp_Object function
, sequence
, separator
;
2522 register Lisp_Object
*args
;
2524 struct gcpro gcpro1
;
2528 len
= Flength (sequence
);
2529 if (CHAR_TABLE_P (sequence
))
2530 wrong_type_argument (Qlistp
, sequence
);
2532 nargs
= leni
+ leni
- 1;
2533 if (nargs
< 0) return empty_unibyte_string
;
2535 SAFE_ALLOCA_LISP (args
, nargs
);
2538 mapcar1 (leni
, args
, function
, sequence
);
2541 for (i
= leni
- 1; i
> 0; i
--)
2542 args
[i
+ i
] = args
[i
];
2544 for (i
= 1; i
< nargs
; i
+= 2)
2545 args
[i
] = separator
;
2547 ret
= Fconcat (nargs
, args
);
2553 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2554 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2555 The result is a list just as long as SEQUENCE.
2556 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2557 (function
, sequence
)
2558 Lisp_Object function
, sequence
;
2560 register Lisp_Object len
;
2562 register Lisp_Object
*args
;
2566 len
= Flength (sequence
);
2567 if (CHAR_TABLE_P (sequence
))
2568 wrong_type_argument (Qlistp
, sequence
);
2569 leni
= XFASTINT (len
);
2571 SAFE_ALLOCA_LISP (args
, leni
);
2573 mapcar1 (leni
, args
, function
, sequence
);
2575 ret
= Flist (leni
, args
);
2581 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2582 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2583 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2584 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2585 (function
, sequence
)
2586 Lisp_Object function
, sequence
;
2590 leni
= XFASTINT (Flength (sequence
));
2591 if (CHAR_TABLE_P (sequence
))
2592 wrong_type_argument (Qlistp
, sequence
);
2593 mapcar1 (leni
, 0, function
, sequence
);
2598 /* Anything that calls this function must protect from GC! */
2600 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2601 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2602 Takes one argument, which is the string to display to ask the question.
2603 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2604 No confirmation of the answer is requested; a single character is enough.
2605 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2606 the bindings in `query-replace-map'; see the documentation of that variable
2607 for more information. In this case, the useful bindings are `act', `skip',
2608 `recenter', and `quit'.\)
2610 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2611 is nil and `use-dialog-box' is non-nil. */)
2615 register Lisp_Object obj
, key
, def
, map
;
2616 register int answer
;
2617 Lisp_Object xprompt
;
2618 Lisp_Object args
[2];
2619 struct gcpro gcpro1
, gcpro2
;
2620 int count
= SPECPDL_INDEX ();
2622 specbind (Qcursor_in_echo_area
, Qt
);
2624 map
= Fsymbol_value (intern ("query-replace-map"));
2626 CHECK_STRING (prompt
);
2628 GCPRO2 (prompt
, xprompt
);
2630 #ifdef HAVE_WINDOW_SYSTEM
2631 if (display_hourglass_p
)
2632 cancel_hourglass ();
2639 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2640 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2644 Lisp_Object pane
, menu
;
2645 redisplay_preserve_echo_area (3);
2646 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2647 Fcons (Fcons (build_string ("No"), Qnil
),
2649 menu
= Fcons (prompt
, pane
);
2650 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2651 answer
= !NILP (obj
);
2654 #endif /* HAVE_MENUS */
2655 cursor_in_echo_area
= 1;
2656 choose_minibuf_frame ();
2659 Lisp_Object pargs
[3];
2661 /* Colorize prompt according to `minibuffer-prompt' face. */
2662 pargs
[0] = build_string ("%s(y or n) ");
2663 pargs
[1] = intern ("face");
2664 pargs
[2] = intern ("minibuffer-prompt");
2665 args
[0] = Fpropertize (3, pargs
);
2670 if (minibuffer_auto_raise
)
2672 Lisp_Object mini_frame
;
2674 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2676 Fraise_frame (mini_frame
);
2679 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2680 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2681 cursor_in_echo_area
= 0;
2682 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2685 key
= Fmake_vector (make_number (1), obj
);
2686 def
= Flookup_key (map
, key
, Qt
);
2688 if (EQ (def
, intern ("skip")))
2693 else if (EQ (def
, intern ("act")))
2698 else if (EQ (def
, intern ("recenter")))
2704 else if (EQ (def
, intern ("quit")))
2706 /* We want to exit this command for exit-prefix,
2707 and this is the only way to do it. */
2708 else if (EQ (def
, intern ("exit-prefix")))
2713 /* If we don't clear this, then the next call to read_char will
2714 return quit_char again, and we'll enter an infinite loop. */
2719 if (EQ (xprompt
, prompt
))
2721 args
[0] = build_string ("Please answer y or n. ");
2723 xprompt
= Fconcat (2, args
);
2728 if (! noninteractive
)
2730 cursor_in_echo_area
= -1;
2731 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2735 unbind_to (count
, Qnil
);
2736 return answer
? Qt
: Qnil
;
2739 /* This is how C code calls `yes-or-no-p' and allows the user
2742 Anything that calls this function must protect from GC! */
2745 do_yes_or_no_p (prompt
)
2748 return call1 (intern ("yes-or-no-p"), prompt
);
2751 /* Anything that calls this function must protect from GC! */
2753 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2754 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2755 Takes one argument, which is the string to display to ask the question.
2756 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2757 The user must confirm the answer with RET,
2758 and can edit it until it has been confirmed.
2760 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2761 is nil, and `use-dialog-box' is non-nil. */)
2765 register Lisp_Object ans
;
2766 Lisp_Object args
[2];
2767 struct gcpro gcpro1
;
2769 CHECK_STRING (prompt
);
2772 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2773 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2777 Lisp_Object pane
, menu
, obj
;
2778 redisplay_preserve_echo_area (4);
2779 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2780 Fcons (Fcons (build_string ("No"), Qnil
),
2783 menu
= Fcons (prompt
, pane
);
2784 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2788 #endif /* HAVE_MENUS */
2791 args
[1] = build_string ("(yes or no) ");
2792 prompt
= Fconcat (2, args
);
2798 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2799 Qyes_or_no_p_history
, Qnil
,
2801 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2806 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2814 message ("Please answer yes or no.");
2815 Fsleep_for (make_number (2), Qnil
);
2819 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2820 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2822 Each of the three load averages is multiplied by 100, then converted
2825 When USE-FLOATS is non-nil, floats will be used instead of integers.
2826 These floats are not multiplied by 100.
2828 If the 5-minute or 15-minute load averages are not available, return a
2829 shortened list, containing only those averages which are available.
2831 An error is thrown if the load average can't be obtained. In some
2832 cases making it work would require Emacs being installed setuid or
2833 setgid so that it can read kernel information, and that usually isn't
2836 Lisp_Object use_floats
;
2839 int loads
= getloadavg (load_ave
, 3);
2840 Lisp_Object ret
= Qnil
;
2843 error ("load-average not implemented for this operating system");
2847 Lisp_Object load
= (NILP (use_floats
) ?
2848 make_number ((int) (100.0 * load_ave
[loads
]))
2849 : make_float (load_ave
[loads
]));
2850 ret
= Fcons (load
, ret
);
2856 Lisp_Object Vfeatures
, Qsubfeatures
;
2857 extern Lisp_Object Vafter_load_alist
;
2859 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2860 doc
: /* Returns t if FEATURE is present in this Emacs.
2862 Use this to conditionalize execution of lisp code based on the
2863 presence or absence of Emacs or environment extensions.
2864 Use `provide' to declare that a feature is available. This function
2865 looks at the value of the variable `features'. The optional argument
2866 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2867 (feature
, subfeature
)
2868 Lisp_Object feature
, subfeature
;
2870 register Lisp_Object tem
;
2871 CHECK_SYMBOL (feature
);
2872 tem
= Fmemq (feature
, Vfeatures
);
2873 if (!NILP (tem
) && !NILP (subfeature
))
2874 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2875 return (NILP (tem
)) ? Qnil
: Qt
;
2878 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2879 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2880 The optional argument SUBFEATURES should be a list of symbols listing
2881 particular subfeatures supported in this version of FEATURE. */)
2882 (feature
, subfeatures
)
2883 Lisp_Object feature
, subfeatures
;
2885 register Lisp_Object tem
;
2886 CHECK_SYMBOL (feature
);
2887 CHECK_LIST (subfeatures
);
2888 if (!NILP (Vautoload_queue
))
2889 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2891 tem
= Fmemq (feature
, Vfeatures
);
2893 Vfeatures
= Fcons (feature
, Vfeatures
);
2894 if (!NILP (subfeatures
))
2895 Fput (feature
, Qsubfeatures
, subfeatures
);
2896 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2898 /* Run any load-hooks for this file. */
2899 tem
= Fassq (feature
, Vafter_load_alist
);
2901 Fprogn (XCDR (tem
));
2906 /* `require' and its subroutines. */
2908 /* List of features currently being require'd, innermost first. */
2910 Lisp_Object require_nesting_list
;
2913 require_unwind (old_value
)
2914 Lisp_Object old_value
;
2916 return require_nesting_list
= old_value
;
2919 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2920 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2921 If FEATURE is not a member of the list `features', then the feature
2922 is not loaded; so load the file FILENAME.
2923 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2924 and `load' will try to load this name appended with the suffix `.elc' or
2925 `.el', in that order. The name without appended suffix will not be used.
2926 If the optional third argument NOERROR is non-nil,
2927 then return nil if the file is not found instead of signaling an error.
2928 Normally the return value is FEATURE.
2929 The normal messages at start and end of loading FILENAME are suppressed. */)
2930 (feature
, filename
, noerror
)
2931 Lisp_Object feature
, filename
, noerror
;
2933 register Lisp_Object tem
;
2934 struct gcpro gcpro1
, gcpro2
;
2935 int from_file
= load_in_progress
;
2937 CHECK_SYMBOL (feature
);
2939 /* Record the presence of `require' in this file
2940 even if the feature specified is already loaded.
2941 But not more than once in any file,
2942 and not when we aren't loading or reading from a file. */
2944 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2945 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2950 tem
= Fcons (Qrequire
, feature
);
2951 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2952 LOADHIST_ATTACH (tem
);
2954 tem
= Fmemq (feature
, Vfeatures
);
2958 int count
= SPECPDL_INDEX ();
2961 /* This is to make sure that loadup.el gives a clear picture
2962 of what files are preloaded and when. */
2963 if (! NILP (Vpurify_flag
))
2964 error ("(require %s) while preparing to dump",
2965 SDATA (SYMBOL_NAME (feature
)));
2967 /* A certain amount of recursive `require' is legitimate,
2968 but if we require the same feature recursively 3 times,
2970 tem
= require_nesting_list
;
2971 while (! NILP (tem
))
2973 if (! NILP (Fequal (feature
, XCAR (tem
))))
2978 error ("Recursive `require' for feature `%s'",
2979 SDATA (SYMBOL_NAME (feature
)));
2981 /* Update the list for any nested `require's that occur. */
2982 record_unwind_protect (require_unwind
, require_nesting_list
);
2983 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2985 /* Value saved here is to be restored into Vautoload_queue */
2986 record_unwind_protect (un_autoload
, Vautoload_queue
);
2987 Vautoload_queue
= Qt
;
2989 /* Load the file. */
2990 GCPRO2 (feature
, filename
);
2991 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2992 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2995 /* If load failed entirely, return nil. */
2997 return unbind_to (count
, Qnil
);
2999 tem
= Fmemq (feature
, Vfeatures
);
3001 error ("Required feature `%s' was not provided",
3002 SDATA (SYMBOL_NAME (feature
)));
3004 /* Once loading finishes, don't undo it. */
3005 Vautoload_queue
= Qt
;
3006 feature
= unbind_to (count
, feature
);
3012 /* Primitives for work of the "widget" library.
3013 In an ideal world, this section would not have been necessary.
3014 However, lisp function calls being as slow as they are, it turns
3015 out that some functions in the widget library (wid-edit.el) are the
3016 bottleneck of Widget operation. Here is their translation to C,
3017 for the sole reason of efficiency. */
3019 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3020 doc
: /* Return non-nil if PLIST has the property PROP.
3021 PLIST is a property list, which is a list of the form
3022 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3023 Unlike `plist-get', this allows you to distinguish between a missing
3024 property and a property with the value nil.
3025 The value is actually the tail of PLIST whose car is PROP. */)
3027 Lisp_Object plist
, prop
;
3029 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3032 plist
= XCDR (plist
);
3033 plist
= CDR (plist
);
3038 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3039 doc
: /* In WIDGET, set PROPERTY to VALUE.
3040 The value can later be retrieved with `widget-get'. */)
3041 (widget
, property
, value
)
3042 Lisp_Object widget
, property
, value
;
3044 CHECK_CONS (widget
);
3045 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3049 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3050 doc
: /* In WIDGET, get the value of PROPERTY.
3051 The value could either be specified when the widget was created, or
3052 later with `widget-put'. */)
3054 Lisp_Object widget
, property
;
3062 CHECK_CONS (widget
);
3063 tmp
= Fplist_member (XCDR (widget
), property
);
3069 tmp
= XCAR (widget
);
3072 widget
= Fget (tmp
, Qwidget_type
);
3076 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3077 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3078 ARGS are passed as extra arguments to the function.
3079 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3084 /* This function can GC. */
3085 Lisp_Object newargs
[3];
3086 struct gcpro gcpro1
, gcpro2
;
3089 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3090 newargs
[1] = args
[0];
3091 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3092 GCPRO2 (newargs
[0], newargs
[2]);
3093 result
= Fapply (3, newargs
);
3098 #ifdef HAVE_LANGINFO_CODESET
3099 #include <langinfo.h>
3102 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3103 doc
: /* Access locale data ITEM for the current C locale, if available.
3104 ITEM should be one of the following:
3106 `codeset', returning the character set as a string (locale item CODESET);
3108 `days', returning a 7-element vector of day names (locale items DAY_n);
3110 `months', returning a 12-element vector of month names (locale items MON_n);
3112 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3113 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3115 If the system can't provide such information through a call to
3116 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3118 See also Info node `(libc)Locales'.
3120 The data read from the system are decoded using `locale-coding-system'. */)
3125 #ifdef HAVE_LANGINFO_CODESET
3127 if (EQ (item
, Qcodeset
))
3129 str
= nl_langinfo (CODESET
);
3130 return build_string (str
);
3133 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3135 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3136 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3138 struct gcpro gcpro1
;
3140 synchronize_system_time_locale ();
3141 for (i
= 0; i
< 7; i
++)
3143 str
= nl_langinfo (days
[i
]);
3144 val
= make_unibyte_string (str
, strlen (str
));
3145 /* Fixme: Is this coding system necessarily right, even if
3146 it is consistent with CODESET? If not, what to do? */
3147 Faset (v
, make_number (i
),
3148 code_convert_string_norecord (val
, Vlocale_coding_system
,
3156 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3158 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3159 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3160 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3162 struct gcpro gcpro1
;
3164 synchronize_system_time_locale ();
3165 for (i
= 0; i
< 12; i
++)
3167 str
= nl_langinfo (months
[i
]);
3168 val
= make_unibyte_string (str
, strlen (str
));
3169 Faset (v
, make_number (i
),
3170 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3176 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3177 but is in the locale files. This could be used by ps-print. */
3179 else if (EQ (item
, Qpaper
))
3181 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3182 make_number (nl_langinfo (PAPER_HEIGHT
)));
3184 #endif /* PAPER_WIDTH */
3185 #endif /* HAVE_LANGINFO_CODESET*/
3189 /* base64 encode/decode functions (RFC 2045).
3190 Based on code from GNU recode. */
3192 #define MIME_LINE_LENGTH 76
3194 #define IS_ASCII(Character) \
3196 #define IS_BASE64(Character) \
3197 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3198 #define IS_BASE64_IGNORABLE(Character) \
3199 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3200 || (Character) == '\f' || (Character) == '\r')
3202 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3203 character or return retval if there are no characters left to
3205 #define READ_QUADRUPLET_BYTE(retval) \
3210 if (nchars_return) \
3211 *nchars_return = nchars; \
3216 while (IS_BASE64_IGNORABLE (c))
3218 /* Table of characters coding the 64 values. */
3219 static char base64_value_to_char
[64] =
3221 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3222 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3223 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3224 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3225 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3226 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3227 '8', '9', '+', '/' /* 60-63 */
3230 /* Table of base64 values for first 128 characters. */
3231 static short base64_char_to_value
[128] =
3233 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3234 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3235 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3236 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3237 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3238 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3239 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3240 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3241 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3242 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3243 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3244 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3245 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3248 /* The following diagram shows the logical steps by which three octets
3249 get transformed into four base64 characters.
3251 .--------. .--------. .--------.
3252 |aaaaaabb| |bbbbcccc| |ccdddddd|
3253 `--------' `--------' `--------'
3255 .--------+--------+--------+--------.
3256 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3257 `--------+--------+--------+--------'
3259 .--------+--------+--------+--------.
3260 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3261 `--------+--------+--------+--------'
3263 The octets are divided into 6 bit chunks, which are then encoded into
3264 base64 characters. */
3267 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3268 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3270 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3272 doc
: /* Base64-encode the region between BEG and END.
3273 Return the length of the encoded text.
3274 Optional third argument NO-LINE-BREAK means do not break long lines
3275 into shorter lines. */)
3276 (beg
, end
, no_line_break
)
3277 Lisp_Object beg
, end
, no_line_break
;
3280 int allength
, length
;
3281 int ibeg
, iend
, encoded_length
;
3285 validate_region (&beg
, &end
);
3287 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3288 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3289 move_gap_both (XFASTINT (beg
), ibeg
);
3291 /* We need to allocate enough room for encoding the text.
3292 We need 33 1/3% more space, plus a newline every 76
3293 characters, and then we round up. */
3294 length
= iend
- ibeg
;
3295 allength
= length
+ length
/3 + 1;
3296 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3298 SAFE_ALLOCA (encoded
, char *, allength
);
3299 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3300 NILP (no_line_break
),
3301 !NILP (current_buffer
->enable_multibyte_characters
));
3302 if (encoded_length
> allength
)
3305 if (encoded_length
< 0)
3307 /* The encoding wasn't possible. */
3309 error ("Multibyte character in data for base64 encoding");
3312 /* Now we have encoded the region, so we insert the new contents
3313 and delete the old. (Insert first in order to preserve markers.) */
3314 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3315 insert (encoded
, encoded_length
);
3317 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3319 /* If point was outside of the region, restore it exactly; else just
3320 move to the beginning of the region. */
3321 if (old_pos
>= XFASTINT (end
))
3322 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3323 else if (old_pos
> XFASTINT (beg
))
3324 old_pos
= XFASTINT (beg
);
3327 /* We return the length of the encoded text. */
3328 return make_number (encoded_length
);
3331 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3333 doc
: /* Base64-encode STRING and return the result.
3334 Optional second argument NO-LINE-BREAK means do not break long lines
3335 into shorter lines. */)
3336 (string
, no_line_break
)
3337 Lisp_Object string
, no_line_break
;
3339 int allength
, length
, encoded_length
;
3341 Lisp_Object encoded_string
;
3344 CHECK_STRING (string
);
3346 /* We need to allocate enough room for encoding the text.
3347 We need 33 1/3% more space, plus a newline every 76
3348 characters, and then we round up. */
3349 length
= SBYTES (string
);
3350 allength
= length
+ length
/3 + 1;
3351 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3353 /* We need to allocate enough room for decoding the text. */
3354 SAFE_ALLOCA (encoded
, char *, allength
);
3356 encoded_length
= base64_encode_1 (SDATA (string
),
3357 encoded
, length
, NILP (no_line_break
),
3358 STRING_MULTIBYTE (string
));
3359 if (encoded_length
> allength
)
3362 if (encoded_length
< 0)
3364 /* The encoding wasn't possible. */
3366 error ("Multibyte character in data for base64 encoding");
3369 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3372 return encoded_string
;
3376 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3383 int counter
= 0, i
= 0;
3393 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3394 if (CHAR_BYTE8_P (c
))
3395 c
= CHAR_TO_BYTE8 (c
);
3403 /* Wrap line every 76 characters. */
3407 if (counter
< MIME_LINE_LENGTH
/ 4)
3416 /* Process first byte of a triplet. */
3418 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3419 value
= (0x03 & c
) << 4;
3421 /* Process second byte of a triplet. */
3425 *e
++ = base64_value_to_char
[value
];
3433 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3434 if (CHAR_BYTE8_P (c
))
3435 c
= CHAR_TO_BYTE8 (c
);
3443 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3444 value
= (0x0f & c
) << 2;
3446 /* Process third byte of a triplet. */
3450 *e
++ = base64_value_to_char
[value
];
3457 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3458 if (CHAR_BYTE8_P (c
))
3459 c
= CHAR_TO_BYTE8 (c
);
3467 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3468 *e
++ = base64_value_to_char
[0x3f & c
];
3475 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3477 doc
: /* Base64-decode the region between BEG and END.
3478 Return the length of the decoded text.
3479 If the region can't be decoded, signal an error and don't modify the buffer. */)
3481 Lisp_Object beg
, end
;
3483 int ibeg
, iend
, length
, allength
;
3488 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3491 validate_region (&beg
, &end
);
3493 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3494 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3496 length
= iend
- ibeg
;
3498 /* We need to allocate enough room for decoding the text. If we are
3499 working on a multibyte buffer, each decoded code may occupy at
3501 allength
= multibyte
? length
* 2 : length
;
3502 SAFE_ALLOCA (decoded
, char *, allength
);
3504 move_gap_both (XFASTINT (beg
), ibeg
);
3505 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3506 multibyte
, &inserted_chars
);
3507 if (decoded_length
> allength
)
3510 if (decoded_length
< 0)
3512 /* The decoding wasn't possible. */
3514 error ("Invalid base64 data");
3517 /* Now we have decoded the region, so we insert the new contents
3518 and delete the old. (Insert first in order to preserve markers.) */
3519 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3520 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3523 /* Delete the original text. */
3524 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3525 iend
+ decoded_length
, 1);
3527 /* If point was outside of the region, restore it exactly; else just
3528 move to the beginning of the region. */
3529 if (old_pos
>= XFASTINT (end
))
3530 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3531 else if (old_pos
> XFASTINT (beg
))
3532 old_pos
= XFASTINT (beg
);
3533 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3535 return make_number (inserted_chars
);
3538 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3540 doc
: /* Base64-decode STRING and return the result. */)
3545 int length
, decoded_length
;
3546 Lisp_Object decoded_string
;
3549 CHECK_STRING (string
);
3551 length
= SBYTES (string
);
3552 /* We need to allocate enough room for decoding the text. */
3553 SAFE_ALLOCA (decoded
, char *, length
);
3555 /* The decoded result should be unibyte. */
3556 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3558 if (decoded_length
> length
)
3560 else if (decoded_length
>= 0)
3561 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3563 decoded_string
= Qnil
;
3566 if (!STRINGP (decoded_string
))
3567 error ("Invalid base64 data");
3569 return decoded_string
;
3572 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3573 MULTIBYTE is nonzero, the decoded result should be in multibyte
3574 form. If NCHARS_RETRUN is not NULL, store the number of produced
3575 characters in *NCHARS_RETURN. */
3578 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3588 unsigned long value
;
3593 /* Process first byte of a quadruplet. */
3595 READ_QUADRUPLET_BYTE (e
-to
);
3599 value
= base64_char_to_value
[c
] << 18;
3601 /* Process second byte of a quadruplet. */
3603 READ_QUADRUPLET_BYTE (-1);
3607 value
|= base64_char_to_value
[c
] << 12;
3609 c
= (unsigned char) (value
>> 16);
3610 if (multibyte
&& c
>= 128)
3611 e
+= BYTE8_STRING (c
, e
);
3616 /* Process third byte of a quadruplet. */
3618 READ_QUADRUPLET_BYTE (-1);
3622 READ_QUADRUPLET_BYTE (-1);
3631 value
|= base64_char_to_value
[c
] << 6;
3633 c
= (unsigned char) (0xff & value
>> 8);
3634 if (multibyte
&& c
>= 128)
3635 e
+= BYTE8_STRING (c
, e
);
3640 /* Process fourth byte of a quadruplet. */
3642 READ_QUADRUPLET_BYTE (-1);
3649 value
|= base64_char_to_value
[c
];
3651 c
= (unsigned char) (0xff & value
);
3652 if (multibyte
&& c
>= 128)
3653 e
+= BYTE8_STRING (c
, e
);
3662 /***********************************************************************
3664 ***** Hash Tables *****
3666 ***********************************************************************/
3668 /* Implemented by gerd@gnu.org. This hash table implementation was
3669 inspired by CMUCL hash tables. */
3673 1. For small tables, association lists are probably faster than
3674 hash tables because they have lower overhead.
3676 For uses of hash tables where the O(1) behavior of table
3677 operations is not a requirement, it might therefore be a good idea
3678 not to hash. Instead, we could just do a linear search in the
3679 key_and_value vector of the hash table. This could be done
3680 if a `:linear-search t' argument is given to make-hash-table. */
3683 /* The list of all weak hash tables. Don't staticpro this one. */
3685 struct Lisp_Hash_Table
*weak_hash_tables
;
3687 /* Various symbols. */
3689 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3690 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3691 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3693 /* Function prototypes. */
3695 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3696 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3697 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3698 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3699 Lisp_Object
, unsigned));
3700 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3701 Lisp_Object
, unsigned));
3702 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3703 unsigned, Lisp_Object
, unsigned));
3704 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3705 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3706 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3707 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3709 static unsigned sxhash_string
P_ ((unsigned char *, int));
3710 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3711 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3712 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3713 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3717 /***********************************************************************
3719 ***********************************************************************/
3721 /* If OBJ is a Lisp hash table, return a pointer to its struct
3722 Lisp_Hash_Table. Otherwise, signal an error. */
3724 static struct Lisp_Hash_Table
*
3725 check_hash_table (obj
)
3728 CHECK_HASH_TABLE (obj
);
3729 return XHASH_TABLE (obj
);
3733 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3737 next_almost_prime (n
)
3750 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3751 which USED[I] is non-zero. If found at index I in ARGS, set
3752 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3753 -1. This function is used to extract a keyword/argument pair from
3754 a DEFUN parameter list. */
3757 get_key_arg (key
, nargs
, args
, used
)
3765 for (i
= 0; i
< nargs
- 1; ++i
)
3766 if (!used
[i
] && EQ (args
[i
], key
))
3781 /* Return a Lisp vector which has the same contents as VEC but has
3782 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3783 vector that are not copied from VEC are set to INIT. */
3786 larger_vector (vec
, new_size
, init
)
3791 struct Lisp_Vector
*v
;
3794 xassert (VECTORP (vec
));
3795 old_size
= ASIZE (vec
);
3796 xassert (new_size
>= old_size
);
3798 v
= allocate_vector (new_size
);
3799 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3800 old_size
* sizeof *v
->contents
);
3801 for (i
= old_size
; i
< new_size
; ++i
)
3802 v
->contents
[i
] = init
;
3803 XSETVECTOR (vec
, v
);
3808 /***********************************************************************
3810 ***********************************************************************/
3812 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3813 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3814 KEY2 are the same. */
3817 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3818 struct Lisp_Hash_Table
*h
;
3819 Lisp_Object key1
, key2
;
3820 unsigned hash1
, hash2
;
3822 return (FLOATP (key1
)
3824 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3828 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3829 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3830 KEY2 are the same. */
3833 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3834 struct Lisp_Hash_Table
*h
;
3835 Lisp_Object key1
, key2
;
3836 unsigned hash1
, hash2
;
3838 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3842 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3843 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3844 if KEY1 and KEY2 are the same. */
3847 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3848 struct Lisp_Hash_Table
*h
;
3849 Lisp_Object key1
, key2
;
3850 unsigned hash1
, hash2
;
3854 Lisp_Object args
[3];
3856 args
[0] = h
->user_cmp_function
;
3859 return !NILP (Ffuncall (3, args
));
3866 /* Value is a hash code for KEY for use in hash table H which uses
3867 `eq' to compare keys. The hash code returned is guaranteed to fit
3868 in a Lisp integer. */
3872 struct Lisp_Hash_Table
*h
;
3875 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3876 xassert ((hash
& ~INTMASK
) == 0);
3881 /* Value is a hash code for KEY for use in hash table H which uses
3882 `eql' to compare keys. The hash code returned is guaranteed to fit
3883 in a Lisp integer. */
3887 struct Lisp_Hash_Table
*h
;
3892 hash
= sxhash (key
, 0);
3894 hash
= XUINT (key
) ^ XTYPE (key
);
3895 xassert ((hash
& ~INTMASK
) == 0);
3900 /* Value is a hash code for KEY for use in hash table H which uses
3901 `equal' to compare keys. The hash code returned is guaranteed to fit
3902 in a Lisp integer. */
3905 hashfn_equal (h
, key
)
3906 struct Lisp_Hash_Table
*h
;
3909 unsigned hash
= sxhash (key
, 0);
3910 xassert ((hash
& ~INTMASK
) == 0);
3915 /* Value is a hash code for KEY for use in hash table H which uses as
3916 user-defined function to compare keys. The hash code returned is
3917 guaranteed to fit in a Lisp integer. */
3920 hashfn_user_defined (h
, key
)
3921 struct Lisp_Hash_Table
*h
;
3924 Lisp_Object args
[2], hash
;
3926 args
[0] = h
->user_hash_function
;
3928 hash
= Ffuncall (2, args
);
3929 if (!INTEGERP (hash
))
3930 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3931 return XUINT (hash
);
3935 /* Create and initialize a new hash table.
3937 TEST specifies the test the hash table will use to compare keys.
3938 It must be either one of the predefined tests `eq', `eql' or
3939 `equal' or a symbol denoting a user-defined test named TEST with
3940 test and hash functions USER_TEST and USER_HASH.
3942 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3944 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3945 new size when it becomes full is computed by adding REHASH_SIZE to
3946 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3947 table's new size is computed by multiplying its old size with
3950 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3951 be resized when the ratio of (number of entries in the table) /
3952 (table size) is >= REHASH_THRESHOLD.
3954 WEAK specifies the weakness of the table. If non-nil, it must be
3955 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3958 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3959 user_test
, user_hash
)
3960 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3961 Lisp_Object user_test
, user_hash
;
3963 struct Lisp_Hash_Table
*h
;
3965 int index_size
, i
, sz
;
3967 /* Preconditions. */
3968 xassert (SYMBOLP (test
));
3969 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3970 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3971 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3972 xassert (FLOATP (rehash_threshold
)
3973 && XFLOATINT (rehash_threshold
) > 0
3974 && XFLOATINT (rehash_threshold
) <= 1.0);
3976 if (XFASTINT (size
) == 0)
3977 size
= make_number (1);
3979 /* Allocate a table and initialize it. */
3980 h
= allocate_hash_table ();
3982 /* Initialize hash table slots. */
3983 sz
= XFASTINT (size
);
3986 if (EQ (test
, Qeql
))
3988 h
->cmpfn
= cmpfn_eql
;
3989 h
->hashfn
= hashfn_eql
;
3991 else if (EQ (test
, Qeq
))
3994 h
->hashfn
= hashfn_eq
;
3996 else if (EQ (test
, Qequal
))
3998 h
->cmpfn
= cmpfn_equal
;
3999 h
->hashfn
= hashfn_equal
;
4003 h
->user_cmp_function
= user_test
;
4004 h
->user_hash_function
= user_hash
;
4005 h
->cmpfn
= cmpfn_user_defined
;
4006 h
->hashfn
= hashfn_user_defined
;
4010 h
->rehash_threshold
= rehash_threshold
;
4011 h
->rehash_size
= rehash_size
;
4013 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4014 h
->hash
= Fmake_vector (size
, Qnil
);
4015 h
->next
= Fmake_vector (size
, Qnil
);
4016 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4017 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4018 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4020 /* Set up the free list. */
4021 for (i
= 0; i
< sz
- 1; ++i
)
4022 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4023 h
->next_free
= make_number (0);
4025 XSET_HASH_TABLE (table
, h
);
4026 xassert (HASH_TABLE_P (table
));
4027 xassert (XHASH_TABLE (table
) == h
);
4029 /* Maybe add this hash table to the list of all weak hash tables. */
4031 h
->next_weak
= NULL
;
4034 h
->next_weak
= weak_hash_tables
;
4035 weak_hash_tables
= h
;
4042 /* Return a copy of hash table H1. Keys and values are not copied,
4043 only the table itself is. */
4046 copy_hash_table (h1
)
4047 struct Lisp_Hash_Table
*h1
;
4050 struct Lisp_Hash_Table
*h2
;
4051 struct Lisp_Vector
*next
;
4053 h2
= allocate_hash_table ();
4054 next
= h2
->vec_next
;
4055 bcopy (h1
, h2
, sizeof *h2
);
4056 h2
->vec_next
= next
;
4057 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4058 h2
->hash
= Fcopy_sequence (h1
->hash
);
4059 h2
->next
= Fcopy_sequence (h1
->next
);
4060 h2
->index
= Fcopy_sequence (h1
->index
);
4061 XSET_HASH_TABLE (table
, h2
);
4063 /* Maybe add this hash table to the list of all weak hash tables. */
4064 if (!NILP (h2
->weak
))
4066 h2
->next_weak
= weak_hash_tables
;
4067 weak_hash_tables
= h2
;
4074 /* Resize hash table H if it's too full. If H cannot be resized
4075 because it's already too large, throw an error. */
4078 maybe_resize_hash_table (h
)
4079 struct Lisp_Hash_Table
*h
;
4081 if (NILP (h
->next_free
))
4083 int old_size
= HASH_TABLE_SIZE (h
);
4084 int i
, new_size
, index_size
;
4087 if (INTEGERP (h
->rehash_size
))
4088 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4090 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4091 new_size
= max (old_size
+ 1, new_size
);
4092 index_size
= next_almost_prime ((int)
4094 / XFLOATINT (h
->rehash_threshold
)));
4095 /* Assignment to EMACS_INT stops GCC whining about limited range
4097 nsize
= max (index_size
, 2 * new_size
);
4098 if (nsize
> MOST_POSITIVE_FIXNUM
)
4099 error ("Hash table too large to resize");
4101 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4102 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4103 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4104 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4106 /* Update the free list. Do it so that new entries are added at
4107 the end of the free list. This makes some operations like
4109 for (i
= old_size
; i
< new_size
- 1; ++i
)
4110 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4112 if (!NILP (h
->next_free
))
4114 Lisp_Object last
, next
;
4116 last
= h
->next_free
;
4117 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4121 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4124 XSETFASTINT (h
->next_free
, old_size
);
4127 for (i
= 0; i
< old_size
; ++i
)
4128 if (!NILP (HASH_HASH (h
, i
)))
4130 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4131 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4132 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4133 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4139 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4140 the hash code of KEY. Value is the index of the entry in H
4141 matching KEY, or -1 if not found. */
4144 hash_lookup (h
, key
, hash
)
4145 struct Lisp_Hash_Table
*h
;
4150 int start_of_bucket
;
4153 hash_code
= h
->hashfn (h
, key
);
4157 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4158 idx
= HASH_INDEX (h
, start_of_bucket
);
4160 /* We need not gcpro idx since it's either an integer or nil. */
4163 int i
= XFASTINT (idx
);
4164 if (EQ (key
, HASH_KEY (h
, i
))
4166 && h
->cmpfn (h
, key
, hash_code
,
4167 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4169 idx
= HASH_NEXT (h
, i
);
4172 return NILP (idx
) ? -1 : XFASTINT (idx
);
4176 /* Put an entry into hash table H that associates KEY with VALUE.
4177 HASH is a previously computed hash code of KEY.
4178 Value is the index of the entry in H matching KEY. */
4181 hash_put (h
, key
, value
, hash
)
4182 struct Lisp_Hash_Table
*h
;
4183 Lisp_Object key
, value
;
4186 int start_of_bucket
, i
;
4188 xassert ((hash
& ~INTMASK
) == 0);
4190 /* Increment count after resizing because resizing may fail. */
4191 maybe_resize_hash_table (h
);
4194 /* Store key/value in the key_and_value vector. */
4195 i
= XFASTINT (h
->next_free
);
4196 h
->next_free
= HASH_NEXT (h
, i
);
4197 HASH_KEY (h
, i
) = key
;
4198 HASH_VALUE (h
, i
) = value
;
4200 /* Remember its hash code. */
4201 HASH_HASH (h
, i
) = make_number (hash
);
4203 /* Add new entry to its collision chain. */
4204 start_of_bucket
= hash
% ASIZE (h
->index
);
4205 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4206 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4211 /* Remove the entry matching KEY from hash table H, if there is one. */
4214 hash_remove_from_table (h
, key
)
4215 struct Lisp_Hash_Table
*h
;
4219 int start_of_bucket
;
4220 Lisp_Object idx
, prev
;
4222 hash_code
= h
->hashfn (h
, key
);
4223 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4224 idx
= HASH_INDEX (h
, start_of_bucket
);
4227 /* We need not gcpro idx, prev since they're either integers or nil. */
4230 int i
= XFASTINT (idx
);
4232 if (EQ (key
, HASH_KEY (h
, i
))
4234 && h
->cmpfn (h
, key
, hash_code
,
4235 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4237 /* Take entry out of collision chain. */
4239 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4241 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4243 /* Clear slots in key_and_value and add the slots to
4245 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4246 HASH_NEXT (h
, i
) = h
->next_free
;
4247 h
->next_free
= make_number (i
);
4249 xassert (h
->count
>= 0);
4255 idx
= HASH_NEXT (h
, i
);
4261 /* Clear hash table H. */
4265 struct Lisp_Hash_Table
*h
;
4269 int i
, size
= HASH_TABLE_SIZE (h
);
4271 for (i
= 0; i
< size
; ++i
)
4273 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4274 HASH_KEY (h
, i
) = Qnil
;
4275 HASH_VALUE (h
, i
) = Qnil
;
4276 HASH_HASH (h
, i
) = Qnil
;
4279 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4280 ASET (h
->index
, i
, Qnil
);
4282 h
->next_free
= make_number (0);
4289 /************************************************************************
4291 ************************************************************************/
4294 init_weak_hash_tables ()
4296 weak_hash_tables
= NULL
;
4299 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4300 entries from the table that don't survive the current GC.
4301 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4302 non-zero if anything was marked. */
4305 sweep_weak_table (h
, remove_entries_p
)
4306 struct Lisp_Hash_Table
*h
;
4307 int remove_entries_p
;
4309 int bucket
, n
, marked
;
4311 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4314 for (bucket
= 0; bucket
< n
; ++bucket
)
4316 Lisp_Object idx
, next
, prev
;
4318 /* Follow collision chain, removing entries that
4319 don't survive this garbage collection. */
4321 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4323 int i
= XFASTINT (idx
);
4324 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4325 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4328 if (EQ (h
->weak
, Qkey
))
4329 remove_p
= !key_known_to_survive_p
;
4330 else if (EQ (h
->weak
, Qvalue
))
4331 remove_p
= !value_known_to_survive_p
;
4332 else if (EQ (h
->weak
, Qkey_or_value
))
4333 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4334 else if (EQ (h
->weak
, Qkey_and_value
))
4335 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4339 next
= HASH_NEXT (h
, i
);
4341 if (remove_entries_p
)
4345 /* Take out of collision chain. */
4347 HASH_INDEX (h
, bucket
) = next
;
4349 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4351 /* Add to free list. */
4352 HASH_NEXT (h
, i
) = h
->next_free
;
4355 /* Clear key, value, and hash. */
4356 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4357 HASH_HASH (h
, i
) = Qnil
;
4370 /* Make sure key and value survive. */
4371 if (!key_known_to_survive_p
)
4373 mark_object (HASH_KEY (h
, i
));
4377 if (!value_known_to_survive_p
)
4379 mark_object (HASH_VALUE (h
, i
));
4390 /* Remove elements from weak hash tables that don't survive the
4391 current garbage collection. Remove weak tables that don't survive
4392 from Vweak_hash_tables. Called from gc_sweep. */
4395 sweep_weak_hash_tables ()
4397 struct Lisp_Hash_Table
*h
, *used
, *next
;
4400 /* Mark all keys and values that are in use. Keep on marking until
4401 there is no more change. This is necessary for cases like
4402 value-weak table A containing an entry X -> Y, where Y is used in a
4403 key-weak table B, Z -> Y. If B comes after A in the list of weak
4404 tables, X -> Y might be removed from A, although when looking at B
4405 one finds that it shouldn't. */
4409 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4411 if (h
->size
& ARRAY_MARK_FLAG
)
4412 marked
|= sweep_weak_table (h
, 0);
4417 /* Remove tables and entries that aren't used. */
4418 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4420 next
= h
->next_weak
;
4422 if (h
->size
& ARRAY_MARK_FLAG
)
4424 /* TABLE is marked as used. Sweep its contents. */
4426 sweep_weak_table (h
, 1);
4428 /* Add table to the list of used weak hash tables. */
4429 h
->next_weak
= used
;
4434 weak_hash_tables
= used
;
4439 /***********************************************************************
4440 Hash Code Computation
4441 ***********************************************************************/
4443 /* Maximum depth up to which to dive into Lisp structures. */
4445 #define SXHASH_MAX_DEPTH 3
4447 /* Maximum length up to which to take list and vector elements into
4450 #define SXHASH_MAX_LEN 7
4452 /* Combine two integers X and Y for hashing. */
4454 #define SXHASH_COMBINE(X, Y) \
4455 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4459 /* Return a hash for string PTR which has length LEN. The hash
4460 code returned is guaranteed to fit in a Lisp integer. */
4463 sxhash_string (ptr
, len
)
4467 unsigned char *p
= ptr
;
4468 unsigned char *end
= p
+ len
;
4477 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4480 return hash
& INTMASK
;
4484 /* Return a hash for list LIST. DEPTH is the current depth in the
4485 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4488 sxhash_list (list
, depth
)
4495 if (depth
< SXHASH_MAX_DEPTH
)
4497 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4498 list
= XCDR (list
), ++i
)
4500 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4501 hash
= SXHASH_COMBINE (hash
, hash2
);
4506 unsigned hash2
= sxhash (list
, depth
+ 1);
4507 hash
= SXHASH_COMBINE (hash
, hash2
);
4514 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4515 the Lisp structure. */
4518 sxhash_vector (vec
, depth
)
4522 unsigned hash
= ASIZE (vec
);
4525 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4526 for (i
= 0; i
< n
; ++i
)
4528 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4529 hash
= SXHASH_COMBINE (hash
, hash2
);
4536 /* Return a hash for bool-vector VECTOR. */
4539 sxhash_bool_vector (vec
)
4542 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4545 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4546 for (i
= 0; i
< n
; ++i
)
4547 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4553 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4554 structure. Value is an unsigned integer clipped to INTMASK. */
4563 if (depth
> SXHASH_MAX_DEPTH
)
4566 switch (XTYPE (obj
))
4577 obj
= SYMBOL_NAME (obj
);
4581 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4584 /* This can be everything from a vector to an overlay. */
4585 case Lisp_Vectorlike
:
4587 /* According to the CL HyperSpec, two arrays are equal only if
4588 they are `eq', except for strings and bit-vectors. In
4589 Emacs, this works differently. We have to compare element
4591 hash
= sxhash_vector (obj
, depth
);
4592 else if (BOOL_VECTOR_P (obj
))
4593 hash
= sxhash_bool_vector (obj
);
4595 /* Others are `equal' if they are `eq', so let's take their
4601 hash
= sxhash_list (obj
, depth
);
4606 double val
= XFLOAT_DATA (obj
);
4607 unsigned char *p
= (unsigned char *) &val
;
4608 unsigned char *e
= p
+ sizeof val
;
4609 for (hash
= 0; p
< e
; ++p
)
4610 hash
= SXHASH_COMBINE (hash
, *p
);
4618 return hash
& INTMASK
;
4623 /***********************************************************************
4625 ***********************************************************************/
4628 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4629 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4633 unsigned hash
= sxhash (obj
, 0);
4634 return make_number (hash
);
4638 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4639 doc
: /* Create and return a new hash table.
4641 Arguments are specified as keyword/argument pairs. The following
4642 arguments are defined:
4644 :test TEST -- TEST must be a symbol that specifies how to compare
4645 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4646 `equal'. User-supplied test and hash functions can be specified via
4647 `define-hash-table-test'.
4649 :size SIZE -- A hint as to how many elements will be put in the table.
4652 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4653 fills up. If REHASH-SIZE is an integer, add that many space. If it
4654 is a float, it must be > 1.0, and the new size is computed by
4655 multiplying the old size with that factor. Default is 1.5.
4657 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4658 Resize the hash table when ratio of the number of entries in the
4659 table. Default is 0.8.
4661 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4662 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4663 returned is a weak table. Key/value pairs are removed from a weak
4664 hash table when there are no non-weak references pointing to their
4665 key, value, one of key or value, or both key and value, depending on
4666 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4669 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4674 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4675 Lisp_Object user_test
, user_hash
;
4679 /* The vector `used' is used to keep track of arguments that
4680 have been consumed. */
4681 used
= (char *) alloca (nargs
* sizeof *used
);
4682 bzero (used
, nargs
* sizeof *used
);
4684 /* See if there's a `:test TEST' among the arguments. */
4685 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4686 test
= i
< 0 ? Qeql
: args
[i
];
4687 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4689 /* See if it is a user-defined test. */
4692 prop
= Fget (test
, Qhash_table_test
);
4693 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4694 signal_error ("Invalid hash table test", test
);
4695 user_test
= XCAR (prop
);
4696 user_hash
= XCAR (XCDR (prop
));
4699 user_test
= user_hash
= Qnil
;
4701 /* See if there's a `:size SIZE' argument. */
4702 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4703 size
= i
< 0 ? Qnil
: args
[i
];
4705 size
= make_number (DEFAULT_HASH_SIZE
);
4706 else if (!INTEGERP (size
) || XINT (size
) < 0)
4707 signal_error ("Invalid hash table size", size
);
4709 /* Look for `:rehash-size SIZE'. */
4710 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4711 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4712 if (!NUMBERP (rehash_size
)
4713 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4714 || XFLOATINT (rehash_size
) <= 1.0)
4715 signal_error ("Invalid hash table rehash size", rehash_size
);
4717 /* Look for `:rehash-threshold THRESHOLD'. */
4718 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4719 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4720 if (!FLOATP (rehash_threshold
)
4721 || XFLOATINT (rehash_threshold
) <= 0.0
4722 || XFLOATINT (rehash_threshold
) > 1.0)
4723 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4725 /* Look for `:weakness WEAK'. */
4726 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4727 weak
= i
< 0 ? Qnil
: args
[i
];
4729 weak
= Qkey_and_value
;
4732 && !EQ (weak
, Qvalue
)
4733 && !EQ (weak
, Qkey_or_value
)
4734 && !EQ (weak
, Qkey_and_value
))
4735 signal_error ("Invalid hash table weakness", weak
);
4737 /* Now, all args should have been used up, or there's a problem. */
4738 for (i
= 0; i
< nargs
; ++i
)
4740 signal_error ("Invalid argument list", args
[i
]);
4742 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4743 user_test
, user_hash
);
4747 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4748 doc
: /* Return a copy of hash table TABLE. */)
4752 return copy_hash_table (check_hash_table (table
));
4756 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4757 doc
: /* Return the number of elements in TABLE. */)
4761 return make_number (check_hash_table (table
)->count
);
4765 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4766 Shash_table_rehash_size
, 1, 1, 0,
4767 doc
: /* Return the current rehash size of TABLE. */)
4771 return check_hash_table (table
)->rehash_size
;
4775 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4776 Shash_table_rehash_threshold
, 1, 1, 0,
4777 doc
: /* Return the current rehash threshold of TABLE. */)
4781 return check_hash_table (table
)->rehash_threshold
;
4785 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4786 doc
: /* Return the size of TABLE.
4787 The size can be used as an argument to `make-hash-table' to create
4788 a hash table than can hold as many elements of TABLE holds
4789 without need for resizing. */)
4793 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4794 return make_number (HASH_TABLE_SIZE (h
));
4798 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4799 doc
: /* Return the test TABLE uses. */)
4803 return check_hash_table (table
)->test
;
4807 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4809 doc
: /* Return the weakness of TABLE. */)
4813 return check_hash_table (table
)->weak
;
4817 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4818 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4822 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4826 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4827 doc
: /* Clear hash table TABLE and return it. */)
4831 hash_clear (check_hash_table (table
));
4832 /* Be compatible with XEmacs. */
4837 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4838 doc
: /* Look up KEY in TABLE and return its associated value.
4839 If KEY is not found, return DFLT which defaults to nil. */)
4841 Lisp_Object key
, table
, dflt
;
4843 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4844 int i
= hash_lookup (h
, key
, NULL
);
4845 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4849 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4850 doc
: /* Associate KEY with VALUE in hash table TABLE.
4851 If KEY is already present in table, replace its current value with
4854 Lisp_Object key
, value
, table
;
4856 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4860 i
= hash_lookup (h
, key
, &hash
);
4862 HASH_VALUE (h
, i
) = value
;
4864 hash_put (h
, key
, value
, hash
);
4870 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4871 doc
: /* Remove KEY from TABLE. */)
4873 Lisp_Object key
, table
;
4875 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4876 hash_remove_from_table (h
, key
);
4881 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4882 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4883 FUNCTION is called with two arguments, KEY and VALUE. */)
4885 Lisp_Object function
, table
;
4887 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4888 Lisp_Object args
[3];
4891 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4892 if (!NILP (HASH_HASH (h
, i
)))
4895 args
[1] = HASH_KEY (h
, i
);
4896 args
[2] = HASH_VALUE (h
, i
);
4904 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4905 Sdefine_hash_table_test
, 3, 3, 0,
4906 doc
: /* Define a new hash table test with name NAME, a symbol.
4908 In hash tables created with NAME specified as test, use TEST to
4909 compare keys, and HASH for computing hash codes of keys.
4911 TEST must be a function taking two arguments and returning non-nil if
4912 both arguments are the same. HASH must be a function taking one
4913 argument and return an integer that is the hash code of the argument.
4914 Hash code computation should use the whole value range of integers,
4915 including negative integers. */)
4917 Lisp_Object name
, test
, hash
;
4919 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4924 /************************************************************************
4926 ************************************************************************/
4930 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4931 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4933 A message digest is a cryptographic checksum of a document, and the
4934 algorithm to calculate it is defined in RFC 1321.
4936 The two optional arguments START and END are character positions
4937 specifying for which part of OBJECT the message digest should be
4938 computed. If nil or omitted, the digest is computed for the whole
4941 The MD5 message digest is computed from the result of encoding the
4942 text in a coding system, not directly from the internal Emacs form of
4943 the text. The optional fourth argument CODING-SYSTEM specifies which
4944 coding system to encode the text with. It should be the same coding
4945 system that you used or will use when actually writing the text into a
4948 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4949 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4950 system would be chosen by default for writing this text into a file.
4952 If OBJECT is a string, the most preferred coding system (see the
4953 command `prefer-coding-system') is used.
4955 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4956 guesswork fails. Normally, an error is signaled in such case. */)
4957 (object
, start
, end
, coding_system
, noerror
)
4958 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4960 unsigned char digest
[16];
4961 unsigned char value
[33];
4965 int start_char
= 0, end_char
= 0;
4966 int start_byte
= 0, end_byte
= 0;
4968 register struct buffer
*bp
;
4971 if (STRINGP (object
))
4973 if (NILP (coding_system
))
4975 /* Decide the coding-system to encode the data with. */
4977 if (STRING_MULTIBYTE (object
))
4978 /* use default, we can't guess correct value */
4979 coding_system
= preferred_coding_system ();
4981 coding_system
= Qraw_text
;
4984 if (NILP (Fcoding_system_p (coding_system
)))
4986 /* Invalid coding system. */
4988 if (!NILP (noerror
))
4989 coding_system
= Qraw_text
;
4991 xsignal1 (Qcoding_system_error
, coding_system
);
4994 if (STRING_MULTIBYTE (object
))
4995 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4997 size
= SCHARS (object
);
4998 size_byte
= SBYTES (object
);
5002 CHECK_NUMBER (start
);
5004 start_char
= XINT (start
);
5009 start_byte
= string_char_to_byte (object
, start_char
);
5015 end_byte
= size_byte
;
5021 end_char
= XINT (end
);
5026 end_byte
= string_char_to_byte (object
, end_char
);
5029 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5030 args_out_of_range_3 (object
, make_number (start_char
),
5031 make_number (end_char
));
5035 struct buffer
*prev
= current_buffer
;
5037 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5039 CHECK_BUFFER (object
);
5041 bp
= XBUFFER (object
);
5042 if (bp
!= current_buffer
)
5043 set_buffer_internal (bp
);
5049 CHECK_NUMBER_COERCE_MARKER (start
);
5057 CHECK_NUMBER_COERCE_MARKER (end
);
5062 temp
= b
, b
= e
, e
= temp
;
5064 if (!(BEGV
<= b
&& e
<= ZV
))
5065 args_out_of_range (start
, end
);
5067 if (NILP (coding_system
))
5069 /* Decide the coding-system to encode the data with.
5070 See fileio.c:Fwrite-region */
5072 if (!NILP (Vcoding_system_for_write
))
5073 coding_system
= Vcoding_system_for_write
;
5076 int force_raw_text
= 0;
5078 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5079 if (NILP (coding_system
)
5080 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5082 coding_system
= Qnil
;
5083 if (NILP (current_buffer
->enable_multibyte_characters
))
5087 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5089 /* Check file-coding-system-alist. */
5090 Lisp_Object args
[4], val
;
5092 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5093 args
[3] = Fbuffer_file_name(object
);
5094 val
= Ffind_operation_coding_system (4, args
);
5095 if (CONSP (val
) && !NILP (XCDR (val
)))
5096 coding_system
= XCDR (val
);
5099 if (NILP (coding_system
)
5100 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5102 /* If we still have not decided a coding system, use the
5103 default value of buffer-file-coding-system. */
5104 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5108 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5109 /* Confirm that VAL can surely encode the current region. */
5110 coding_system
= call4 (Vselect_safe_coding_system_function
,
5111 make_number (b
), make_number (e
),
5112 coding_system
, Qnil
);
5115 coding_system
= Qraw_text
;
5118 if (NILP (Fcoding_system_p (coding_system
)))
5120 /* Invalid coding system. */
5122 if (!NILP (noerror
))
5123 coding_system
= Qraw_text
;
5125 xsignal1 (Qcoding_system_error
, coding_system
);
5129 object
= make_buffer_string (b
, e
, 0);
5130 if (prev
!= current_buffer
)
5131 set_buffer_internal (prev
);
5132 /* Discard the unwind protect for recovering the current
5136 if (STRING_MULTIBYTE (object
))
5137 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5140 md5_buffer (SDATA (object
) + start_byte
,
5141 SBYTES (object
) - (size_byte
- end_byte
),
5144 for (i
= 0; i
< 16; i
++)
5145 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5148 return make_string (value
, 32);
5155 /* Hash table stuff. */
5156 Qhash_table_p
= intern ("hash-table-p");
5157 staticpro (&Qhash_table_p
);
5158 Qeq
= intern ("eq");
5160 Qeql
= intern ("eql");
5162 Qequal
= intern ("equal");
5163 staticpro (&Qequal
);
5164 QCtest
= intern (":test");
5165 staticpro (&QCtest
);
5166 QCsize
= intern (":size");
5167 staticpro (&QCsize
);
5168 QCrehash_size
= intern (":rehash-size");
5169 staticpro (&QCrehash_size
);
5170 QCrehash_threshold
= intern (":rehash-threshold");
5171 staticpro (&QCrehash_threshold
);
5172 QCweakness
= intern (":weakness");
5173 staticpro (&QCweakness
);
5174 Qkey
= intern ("key");
5176 Qvalue
= intern ("value");
5177 staticpro (&Qvalue
);
5178 Qhash_table_test
= intern ("hash-table-test");
5179 staticpro (&Qhash_table_test
);
5180 Qkey_or_value
= intern ("key-or-value");
5181 staticpro (&Qkey_or_value
);
5182 Qkey_and_value
= intern ("key-and-value");
5183 staticpro (&Qkey_and_value
);
5186 defsubr (&Smake_hash_table
);
5187 defsubr (&Scopy_hash_table
);
5188 defsubr (&Shash_table_count
);
5189 defsubr (&Shash_table_rehash_size
);
5190 defsubr (&Shash_table_rehash_threshold
);
5191 defsubr (&Shash_table_size
);
5192 defsubr (&Shash_table_test
);
5193 defsubr (&Shash_table_weakness
);
5194 defsubr (&Shash_table_p
);
5195 defsubr (&Sclrhash
);
5196 defsubr (&Sgethash
);
5197 defsubr (&Sputhash
);
5198 defsubr (&Sremhash
);
5199 defsubr (&Smaphash
);
5200 defsubr (&Sdefine_hash_table_test
);
5202 Qstring_lessp
= intern ("string-lessp");
5203 staticpro (&Qstring_lessp
);
5204 Qprovide
= intern ("provide");
5205 staticpro (&Qprovide
);
5206 Qrequire
= intern ("require");
5207 staticpro (&Qrequire
);
5208 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5209 staticpro (&Qyes_or_no_p_history
);
5210 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5211 staticpro (&Qcursor_in_echo_area
);
5212 Qwidget_type
= intern ("widget-type");
5213 staticpro (&Qwidget_type
);
5215 staticpro (&string_char_byte_cache_string
);
5216 string_char_byte_cache_string
= Qnil
;
5218 require_nesting_list
= Qnil
;
5219 staticpro (&require_nesting_list
);
5221 Fset (Qyes_or_no_p_history
, Qnil
);
5223 DEFVAR_LISP ("features", &Vfeatures
,
5224 doc
: /* A list of symbols which are the features of the executing Emacs.
5225 Used by `featurep' and `require', and altered by `provide'. */);
5226 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5227 Qsubfeatures
= intern ("subfeatures");
5228 staticpro (&Qsubfeatures
);
5230 #ifdef HAVE_LANGINFO_CODESET
5231 Qcodeset
= intern ("codeset");
5232 staticpro (&Qcodeset
);
5233 Qdays
= intern ("days");
5235 Qmonths
= intern ("months");
5236 staticpro (&Qmonths
);
5237 Qpaper
= intern ("paper");
5238 staticpro (&Qpaper
);
5239 #endif /* HAVE_LANGINFO_CODESET */
5241 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5242 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5243 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5244 invoked by mouse clicks and mouse menu items.
5246 On some platforms, file selection dialogs are also enabled if this is
5250 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5251 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5252 This applies to commands from menus and tool bar buttons even when
5253 they are initiated from the keyboard. If `use-dialog-box' is nil,
5254 that disables the use of a file dialog, regardless of the value of
5256 use_file_dialog
= 1;
5258 defsubr (&Sidentity
);
5261 defsubr (&Ssafe_length
);
5262 defsubr (&Sstring_bytes
);
5263 defsubr (&Sstring_equal
);
5264 defsubr (&Scompare_strings
);
5265 defsubr (&Sstring_lessp
);
5268 defsubr (&Svconcat
);
5269 defsubr (&Scopy_sequence
);
5270 defsubr (&Sstring_make_multibyte
);
5271 defsubr (&Sstring_make_unibyte
);
5272 defsubr (&Sstring_as_multibyte
);
5273 defsubr (&Sstring_as_unibyte
);
5274 defsubr (&Sstring_to_multibyte
);
5275 defsubr (&Sstring_to_unibyte
);
5276 defsubr (&Scopy_alist
);
5277 defsubr (&Ssubstring
);
5278 defsubr (&Ssubstring_no_properties
);
5291 defsubr (&Snreverse
);
5292 defsubr (&Sreverse
);
5294 defsubr (&Splist_get
);
5296 defsubr (&Splist_put
);
5298 defsubr (&Slax_plist_get
);
5299 defsubr (&Slax_plist_put
);
5302 defsubr (&Sequal_including_properties
);
5303 defsubr (&Sfillarray
);
5304 defsubr (&Sclear_string
);
5308 defsubr (&Smapconcat
);
5309 defsubr (&Sy_or_n_p
);
5310 defsubr (&Syes_or_no_p
);
5311 defsubr (&Sload_average
);
5312 defsubr (&Sfeaturep
);
5313 defsubr (&Srequire
);
5314 defsubr (&Sprovide
);
5315 defsubr (&Splist_member
);
5316 defsubr (&Swidget_put
);
5317 defsubr (&Swidget_get
);
5318 defsubr (&Swidget_apply
);
5319 defsubr (&Sbase64_encode_region
);
5320 defsubr (&Sbase64_decode_region
);
5321 defsubr (&Sbase64_encode_string
);
5322 defsubr (&Sbase64_decode_string
);
5324 defsubr (&Slocale_info
);
5333 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5334 (do not change this comment) */