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, 2010
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
79 extern long get_random ();
80 extern void seed_random
P_ ((long));
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer LIMIT, return random number in interval [0,LIMIT).
99 With argument t, set the random number seed from the current time and pid.
100 Other values of LIMIT are ignored. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (limit
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
144 if (STRINGP (sequence
))
145 XSETFASTINT (val
, SCHARS (sequence
));
146 else if (VECTORP (sequence
))
147 XSETFASTINT (val
, ASIZE (sequence
));
148 else if (CHAR_TABLE_P (sequence
))
149 XSETFASTINT (val
, MAX_CHAR
);
150 else if (BOOL_VECTOR_P (sequence
))
151 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
152 else if (COMPILEDP (sequence
))
153 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
154 else if (CONSP (sequence
))
157 while (CONSP (sequence
))
159 sequence
= XCDR (sequence
);
162 if (!CONSP (sequence
))
165 sequence
= XCDR (sequence
);
170 CHECK_LIST_END (sequence
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
177 wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe since it must terminate. */
184 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
185 doc
: /* Return the length of a list, but avoid error or infinite loop.
186 This function never gets an error. If LIST is not really a list,
187 it returns 0. If LIST is circular, it returns a finite value
188 which is at least the number of distinct elements. */)
192 Lisp_Object tail
, halftail
, length
;
195 /* halftail is used to detect circular lists. */
197 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
199 if (EQ (tail
, halftail
) && len
!= 0)
203 halftail
= XCDR (halftail
);
206 XSETINT (length
, len
);
210 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
211 doc
: /* Return the number of bytes in STRING.
212 If STRING is multibyte, this may be greater than the length of STRING. */)
216 CHECK_STRING (string
);
217 return make_number (SBYTES (string
));
220 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
221 doc
: /* Return t if two strings have identical contents.
222 Case is significant, but text properties are ignored.
223 Symbols are also allowed; their print names are used instead. */)
225 register Lisp_Object s1
, s2
;
228 s1
= SYMBOL_NAME (s1
);
230 s2
= SYMBOL_NAME (s2
);
234 if (SCHARS (s1
) != SCHARS (s2
)
235 || SBYTES (s1
) != SBYTES (s2
)
236 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
241 DEFUN ("compare-strings", Fcompare_strings
,
242 Scompare_strings
, 6, 7, 0,
243 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
244 In string STR1, skip the first START1 characters and stop at END1.
245 In string STR2, skip the first START2 characters and stop at END2.
246 END1 and END2 default to the full lengths of the respective strings.
248 Case is significant in this comparison if IGNORE-CASE is nil.
249 Unibyte strings are converted to multibyte for comparison.
251 The value is t if the strings (or specified portions) match.
252 If string STR1 is less, the value is a negative number N;
253 - 1 - N is the number of characters that match at the beginning.
254 If string STR1 is greater, the value is a positive number N;
255 N - 1 is the number of characters that match at the beginning. */)
256 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
257 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
259 register int end1_char
, end2_char
;
260 register int i1
, i1_byte
, i2
, i2_byte
;
265 start1
= make_number (0);
267 start2
= make_number (0);
268 CHECK_NATNUM (start1
);
269 CHECK_NATNUM (start2
);
278 i1_byte
= string_char_to_byte (str1
, i1
);
279 i2_byte
= string_char_to_byte (str2
, i2
);
281 end1_char
= SCHARS (str1
);
282 if (! NILP (end1
) && end1_char
> XINT (end1
))
283 end1_char
= XINT (end1
);
285 end2_char
= SCHARS (str2
);
286 if (! NILP (end2
) && end2_char
> XINT (end2
))
287 end2_char
= XINT (end2
);
289 while (i1
< end1_char
&& i2
< end2_char
)
291 /* When we find a mismatch, we must compare the
292 characters, not just the bytes. */
295 if (STRING_MULTIBYTE (str1
))
296 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
299 c1
= SREF (str1
, i1
++);
300 MAKE_CHAR_MULTIBYTE (c1
);
303 if (STRING_MULTIBYTE (str2
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
307 c2
= SREF (str2
, i2
++);
308 MAKE_CHAR_MULTIBYTE (c2
);
314 if (! NILP (ignore_case
))
318 tem
= Fupcase (make_number (c1
));
320 tem
= Fupcase (make_number (c2
));
327 /* Note that I1 has already been incremented
328 past the character that we are comparing;
329 hence we don't add or subtract 1 here. */
331 return make_number (- i1
+ XINT (start1
));
333 return make_number (i1
- XINT (start1
));
337 return make_number (i1
- XINT (start1
) + 1);
339 return make_number (- i1
+ XINT (start1
) - 1);
344 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
345 doc
: /* Return t if first arg string is less than second in lexicographic order.
347 Symbols are also allowed; their print names are used instead. */)
349 register Lisp_Object s1
, s2
;
352 register int i1
, i1_byte
, i2
, i2_byte
;
355 s1
= SYMBOL_NAME (s1
);
357 s2
= SYMBOL_NAME (s2
);
361 i1
= i1_byte
= i2
= i2_byte
= 0;
364 if (end
> SCHARS (s2
))
369 /* When we find a mismatch, we must compare the
370 characters, not just the bytes. */
373 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
374 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
377 return c1
< c2
? Qt
: Qnil
;
379 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 /* "gcc -O3" enables automatic function inlining, which optimizes out
384 the arguments for the invocations of this function, whereas it
385 expects these values on the stack. */
386 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
387 #else /* !__GNUC__ */
388 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
461 doc
: /* Return a copy of a list, vector, string or char-table.
462 The elements of a list or vector are not copied; they are shared
463 with the original. */)
467 if (NILP (arg
)) return arg
;
469 if (CHAR_TABLE_P (arg
))
471 return copy_char_table (arg
);
474 if (BOOL_VECTOR_P (arg
))
478 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
479 / BOOL_VECTOR_BITS_PER_CHAR
);
481 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
482 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
487 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
488 wrong_type_argument (Qsequencep
, arg
);
490 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
493 /* This structure holds information of an argument of `concat' that is
494 a string and has text properties to be copied. */
497 int argnum
; /* refer to ARGS (arguments of `concat') */
498 int from
; /* refer to ARGS[argnum] (argument string) */
499 int to
; /* refer to VAL (the target string) */
503 concat (nargs
, args
, target_type
, last_special
)
506 enum Lisp_Type target_type
;
510 register Lisp_Object tail
;
511 register Lisp_Object
this;
513 int toindex_byte
= 0;
514 register int result_len
;
515 register int result_len_byte
;
517 Lisp_Object last_tail
;
520 /* When we make a multibyte string, we can't copy text properties
521 while concatinating each string because the length of resulting
522 string can't be decided until we finish the whole concatination.
523 So, we record strings that have text properties to be copied
524 here, and copy the text properties after the concatination. */
525 struct textprop_rec
*textprops
= NULL
;
526 /* Number of elements in textprops. */
527 int num_textprops
= 0;
532 /* In append, the last arg isn't treated like the others */
533 if (last_special
&& nargs
> 0)
536 last_tail
= args
[nargs
];
541 /* Check each argument. */
542 for (argnum
= 0; argnum
< nargs
; argnum
++)
545 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
546 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
547 wrong_type_argument (Qsequencep
, this);
550 /* Compute total length in chars of arguments in RESULT_LEN.
551 If desired output is a string, also compute length in bytes
552 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
553 whether the result should be a multibyte string. */
557 for (argnum
= 0; argnum
< nargs
; argnum
++)
561 len
= XFASTINT (Flength (this));
562 if (target_type
== Lisp_String
)
564 /* We must count the number of bytes needed in the string
565 as well as the number of characters. */
571 for (i
= 0; i
< len
; i
++)
574 CHECK_CHARACTER (ch
);
575 this_len_byte
= CHAR_BYTES (XINT (ch
));
576 result_len_byte
+= this_len_byte
;
577 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
580 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
581 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
582 else if (CONSP (this))
583 for (; CONSP (this); this = XCDR (this))
586 CHECK_CHARACTER (ch
);
587 this_len_byte
= CHAR_BYTES (XINT (ch
));
588 result_len_byte
+= this_len_byte
;
589 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
592 else if (STRINGP (this))
594 if (STRING_MULTIBYTE (this))
597 result_len_byte
+= SBYTES (this);
600 result_len_byte
+= count_size_as_multibyte (SDATA (this),
607 error ("String overflow");
610 if (! some_multibyte
)
611 result_len_byte
= result_len
;
613 /* Create the output object. */
614 if (target_type
== Lisp_Cons
)
615 val
= Fmake_list (make_number (result_len
), Qnil
);
616 else if (target_type
== Lisp_Vectorlike
)
617 val
= Fmake_vector (make_number (result_len
), Qnil
);
618 else if (some_multibyte
)
619 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
621 val
= make_uninit_string (result_len
);
623 /* In `append', if all but last arg are nil, return last arg. */
624 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
627 /* Copy the contents of the args into the result. */
629 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
631 toindex
= 0, toindex_byte
= 0;
635 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
637 for (argnum
= 0; argnum
< nargs
; argnum
++)
641 register unsigned int thisindex
= 0;
642 register unsigned int thisindex_byte
= 0;
646 thislen
= Flength (this), thisleni
= XINT (thislen
);
648 /* Between strings of the same kind, copy fast. */
649 if (STRINGP (this) && STRINGP (val
)
650 && STRING_MULTIBYTE (this) == some_multibyte
)
652 int thislen_byte
= SBYTES (this);
654 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
656 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
658 textprops
[num_textprops
].argnum
= argnum
;
659 textprops
[num_textprops
].from
= 0;
660 textprops
[num_textprops
++].to
= toindex
;
662 toindex_byte
+= thislen_byte
;
665 /* Copy a single-byte string to a multibyte string. */
666 else if (STRINGP (this) && STRINGP (val
))
668 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
670 textprops
[num_textprops
].argnum
= argnum
;
671 textprops
[num_textprops
].from
= 0;
672 textprops
[num_textprops
++].to
= toindex
;
674 toindex_byte
+= copy_text (SDATA (this),
675 SDATA (val
) + toindex_byte
,
676 SCHARS (this), 0, 1);
680 /* Copy element by element. */
683 register Lisp_Object elt
;
685 /* Fetch next element of `this' arg into `elt', or break if
686 `this' is exhausted. */
687 if (NILP (this)) break;
689 elt
= XCAR (this), this = XCDR (this);
690 else if (thisindex
>= thisleni
)
692 else if (STRINGP (this))
695 if (STRING_MULTIBYTE (this))
697 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
700 XSETFASTINT (elt
, c
);
704 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
706 && !ASCII_CHAR_P (XINT (elt
))
707 && XINT (elt
) < 0400)
709 c
= BYTE8_TO_CHAR (XINT (elt
));
714 else if (BOOL_VECTOR_P (this))
717 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
718 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
726 elt
= AREF (this, thisindex
);
730 /* Store this element into the result. */
737 else if (VECTORP (val
))
739 ASET (val
, toindex
, elt
);
746 toindex_byte
+= CHAR_STRING (XINT (elt
),
747 SDATA (val
) + toindex_byte
);
749 SSET (val
, toindex_byte
++, XINT (elt
));
755 XSETCDR (prev
, last_tail
);
757 if (num_textprops
> 0)
760 int last_to_end
= -1;
762 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
764 this = args
[textprops
[argnum
].argnum
];
765 props
= text_property_list (this,
767 make_number (SCHARS (this)),
769 /* If successive arguments have properites, be sure that the
770 value of `composition' property be the copy. */
771 if (last_to_end
== textprops
[argnum
].to
)
772 make_composition_value_copy (props
);
773 add_text_properties_from_list (val
, props
,
774 make_number (textprops
[argnum
].to
));
775 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
783 static Lisp_Object string_char_byte_cache_string
;
784 static EMACS_INT string_char_byte_cache_charpos
;
785 static EMACS_INT string_char_byte_cache_bytepos
;
788 clear_string_char_byte_cache ()
790 string_char_byte_cache_string
= Qnil
;
793 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
796 string_char_to_byte (string
, char_index
)
798 EMACS_INT char_index
;
801 EMACS_INT best_below
, best_below_byte
;
802 EMACS_INT best_above
, best_above_byte
;
804 best_below
= best_below_byte
= 0;
805 best_above
= SCHARS (string
);
806 best_above_byte
= SBYTES (string
);
807 if (best_above
== best_above_byte
)
810 if (EQ (string
, string_char_byte_cache_string
))
812 if (string_char_byte_cache_charpos
< char_index
)
814 best_below
= string_char_byte_cache_charpos
;
815 best_below_byte
= string_char_byte_cache_bytepos
;
819 best_above
= string_char_byte_cache_charpos
;
820 best_above_byte
= string_char_byte_cache_bytepos
;
824 if (char_index
- best_below
< best_above
- char_index
)
826 unsigned char *p
= SDATA (string
) + best_below_byte
;
828 while (best_below
< char_index
)
830 p
+= BYTES_BY_CHAR_HEAD (*p
);
833 i_byte
= p
- SDATA (string
);
837 unsigned char *p
= SDATA (string
) + best_above_byte
;
839 while (best_above
> char_index
)
842 while (!CHAR_HEAD_P (*p
)) p
--;
845 i_byte
= p
- SDATA (string
);
848 string_char_byte_cache_bytepos
= i_byte
;
849 string_char_byte_cache_charpos
= char_index
;
850 string_char_byte_cache_string
= string
;
855 /* Return the character index corresponding to BYTE_INDEX in STRING. */
858 string_byte_to_char (string
, byte_index
)
860 EMACS_INT byte_index
;
863 EMACS_INT best_below
, best_below_byte
;
864 EMACS_INT best_above
, best_above_byte
;
866 best_below
= best_below_byte
= 0;
867 best_above
= SCHARS (string
);
868 best_above_byte
= SBYTES (string
);
869 if (best_above
== best_above_byte
)
872 if (EQ (string
, string_char_byte_cache_string
))
874 if (string_char_byte_cache_bytepos
< byte_index
)
876 best_below
= string_char_byte_cache_charpos
;
877 best_below_byte
= string_char_byte_cache_bytepos
;
881 best_above
= string_char_byte_cache_charpos
;
882 best_above_byte
= string_char_byte_cache_bytepos
;
886 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
888 unsigned char *p
= SDATA (string
) + best_below_byte
;
889 unsigned char *pend
= SDATA (string
) + byte_index
;
893 p
+= BYTES_BY_CHAR_HEAD (*p
);
897 i_byte
= p
- SDATA (string
);
901 unsigned char *p
= SDATA (string
) + best_above_byte
;
902 unsigned char *pbeg
= SDATA (string
) + byte_index
;
907 while (!CHAR_HEAD_P (*p
)) p
--;
911 i_byte
= p
- SDATA (string
);
914 string_char_byte_cache_bytepos
= i_byte
;
915 string_char_byte_cache_charpos
= i
;
916 string_char_byte_cache_string
= string
;
921 /* Convert STRING to a multibyte string. */
924 string_make_multibyte (string
)
932 if (STRING_MULTIBYTE (string
))
935 nbytes
= count_size_as_multibyte (SDATA (string
),
937 /* If all the chars are ASCII, they won't need any more bytes
938 once converted. In that case, we can return STRING itself. */
939 if (nbytes
== SBYTES (string
))
942 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
943 copy_text (SDATA (string
), buf
, SBYTES (string
),
946 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
953 /* Convert STRING (if unibyte) to a multibyte string without changing
954 the number of characters. Characters 0200 trough 0237 are
955 converted to eight-bit characters. */
958 string_to_multibyte (string
)
966 if (STRING_MULTIBYTE (string
))
969 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
970 /* If all the chars are ASCII, they won't need any more bytes once
972 if (nbytes
== SBYTES (string
))
973 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
975 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
976 bcopy (SDATA (string
), buf
, SBYTES (string
));
977 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
979 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
986 /* Convert STRING to a single-byte string. */
989 string_make_unibyte (string
)
997 if (! STRING_MULTIBYTE (string
))
1000 nchars
= SCHARS (string
);
1002 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1003 copy_text (SDATA (string
), buf
, SBYTES (string
),
1006 ret
= make_unibyte_string (buf
, nchars
);
1012 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1014 doc
: /* Return the multibyte equivalent of STRING.
1015 If STRING is unibyte and contains non-ASCII characters, the function
1016 `unibyte-char-to-multibyte' is used to convert each unibyte character
1017 to a multibyte character. In this case, the returned string is a
1018 newly created string with no text properties. If STRING is multibyte
1019 or entirely ASCII, it is returned unchanged. In particular, when
1020 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1021 \(When the characters are all ASCII, Emacs primitives will treat the
1022 string the same way whether it is unibyte or multibyte.) */)
1026 CHECK_STRING (string
);
1028 return string_make_multibyte (string
);
1031 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1033 doc
: /* Return the unibyte equivalent of STRING.
1034 Multibyte character codes are converted to unibyte according to
1035 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1036 If the lookup in the translation table fails, this function takes just
1037 the low 8 bits of each character. */)
1041 CHECK_STRING (string
);
1043 return string_make_unibyte (string
);
1046 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1048 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1049 If STRING is unibyte, the result is STRING itself.
1050 Otherwise it is a newly created string, with no text properties.
1051 If STRING is multibyte and contains a character of charset
1052 `eight-bit', it is converted to the corresponding single byte. */)
1056 CHECK_STRING (string
);
1058 if (STRING_MULTIBYTE (string
))
1060 int bytes
= SBYTES (string
);
1061 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1063 bcopy (SDATA (string
), str
, bytes
);
1064 bytes
= str_as_unibyte (str
, bytes
);
1065 string
= make_unibyte_string (str
, bytes
);
1071 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1073 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1074 If STRING is multibyte, the result is STRING itself.
1075 Otherwise it is a newly created string, with no text properties.
1077 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1078 part of a correct utf-8 sequence), it is converted to the corresponding
1079 multibyte character of charset `eight-bit'.
1080 See also `string-to-multibyte'.
1082 Beware, this often doesn't really do what you think it does.
1083 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1084 If you're not sure, whether to use `string-as-multibyte' or
1085 `string-to-multibyte', use `string-to-multibyte'. */)
1089 CHECK_STRING (string
);
1091 if (! STRING_MULTIBYTE (string
))
1093 Lisp_Object new_string
;
1096 parse_str_as_multibyte (SDATA (string
),
1099 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1100 bcopy (SDATA (string
), SDATA (new_string
),
1102 if (nbytes
!= SBYTES (string
))
1103 str_as_multibyte (SDATA (new_string
), nbytes
,
1104 SBYTES (string
), NULL
);
1105 string
= new_string
;
1106 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1111 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1113 doc
: /* Return a multibyte string with the same individual chars as STRING.
1114 If STRING is multibyte, the result is STRING itself.
1115 Otherwise it is a newly created string, with no text properties.
1117 If STRING is unibyte and contains an 8-bit byte, it is converted to
1118 the corresponding multibyte character of charset `eight-bit'.
1120 This differs from `string-as-multibyte' by converting each byte of a correct
1121 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1122 correct sequence. */)
1126 CHECK_STRING (string
);
1128 return string_to_multibyte (string
);
1131 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1133 doc
: /* Return a unibyte string with the same individual chars as STRING.
1134 If STRING is unibyte, the result is STRING itself.
1135 Otherwise it is a newly created string, with no text properties,
1136 where each `eight-bit' character is converted to the corresponding byte.
1137 If STRING contains a non-ASCII, non-`eight-bit' character,
1138 an error is signaled. */)
1142 CHECK_STRING (string
);
1144 if (STRING_MULTIBYTE (string
))
1146 EMACS_INT chars
= SCHARS (string
);
1147 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1148 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1150 if (converted
< chars
)
1151 error ("Can't convert the %dth character to unibyte", converted
);
1152 string
= make_unibyte_string (str
, chars
);
1159 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1160 doc
: /* Return a copy of ALIST.
1161 This is an alist which represents the same mapping from objects to objects,
1162 but does not share the alist structure with ALIST.
1163 The objects mapped (cars and cdrs of elements of the alist)
1164 are shared, however.
1165 Elements of ALIST that are not conses are also shared. */)
1169 register Lisp_Object tem
;
1174 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1175 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1177 register Lisp_Object car
;
1181 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1186 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1187 doc
: /* Return a new string whose contents are a substring of STRING.
1188 The returned string consists of the characters between index FROM
1189 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1190 zero-indexed: 0 means the first character of STRING. Negative values
1191 are counted from the end of STRING. If TO is nil, the substring runs
1192 to the end of STRING.
1194 The STRING argument may also be a vector. In that case, the return
1195 value is a new vector that contains the elements between index FROM
1196 \(inclusive) and index TO (exclusive) of that vector argument. */)
1199 register Lisp_Object from
, to
;
1204 int from_char
, to_char
;
1205 int from_byte
= 0, to_byte
= 0;
1207 CHECK_VECTOR_OR_STRING (string
);
1208 CHECK_NUMBER (from
);
1210 if (STRINGP (string
))
1212 size
= SCHARS (string
);
1213 size_byte
= SBYTES (string
);
1216 size
= ASIZE (string
);
1221 to_byte
= size_byte
;
1227 to_char
= XINT (to
);
1231 if (STRINGP (string
))
1232 to_byte
= string_char_to_byte (string
, to_char
);
1235 from_char
= XINT (from
);
1238 if (STRINGP (string
))
1239 from_byte
= string_char_to_byte (string
, from_char
);
1241 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1242 args_out_of_range_3 (string
, make_number (from_char
),
1243 make_number (to_char
));
1245 if (STRINGP (string
))
1247 res
= make_specified_string (SDATA (string
) + from_byte
,
1248 to_char
- from_char
, to_byte
- from_byte
,
1249 STRING_MULTIBYTE (string
));
1250 copy_text_properties (make_number (from_char
), make_number (to_char
),
1251 string
, make_number (0), res
, Qnil
);
1254 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1260 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1261 doc
: /* Return a substring of STRING, without text properties.
1262 It starts at index FROM and ending before TO.
1263 TO may be nil or omitted; then the substring runs to the end of STRING.
1264 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1265 If FROM or TO is negative, it counts from the end.
1267 With one argument, just copy STRING without its properties. */)
1270 register Lisp_Object from
, to
;
1272 int size
, size_byte
;
1273 int from_char
, to_char
;
1274 int from_byte
, to_byte
;
1276 CHECK_STRING (string
);
1278 size
= SCHARS (string
);
1279 size_byte
= SBYTES (string
);
1282 from_char
= from_byte
= 0;
1285 CHECK_NUMBER (from
);
1286 from_char
= XINT (from
);
1290 from_byte
= string_char_to_byte (string
, from_char
);
1296 to_byte
= size_byte
;
1302 to_char
= XINT (to
);
1306 to_byte
= string_char_to_byte (string
, to_char
);
1309 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1310 args_out_of_range_3 (string
, make_number (from_char
),
1311 make_number (to_char
));
1313 return make_specified_string (SDATA (string
) + from_byte
,
1314 to_char
- from_char
, to_byte
- from_byte
,
1315 STRING_MULTIBYTE (string
));
1318 /* Extract a substring of STRING, giving start and end positions
1319 both in characters and in bytes. */
1322 substring_both (string
, from
, from_byte
, to
, to_byte
)
1324 int from
, from_byte
, to
, to_byte
;
1330 CHECK_VECTOR_OR_STRING (string
);
1332 if (STRINGP (string
))
1334 size
= SCHARS (string
);
1335 size_byte
= SBYTES (string
);
1338 size
= ASIZE (string
);
1340 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1341 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1343 if (STRINGP (string
))
1345 res
= make_specified_string (SDATA (string
) + from_byte
,
1346 to
- from
, to_byte
- from_byte
,
1347 STRING_MULTIBYTE (string
));
1348 copy_text_properties (make_number (from
), make_number (to
),
1349 string
, make_number (0), res
, Qnil
);
1352 res
= Fvector (to
- from
, &AREF (string
, from
));
1357 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1358 doc
: /* Take cdr N times on LIST, returns the result. */)
1361 register Lisp_Object list
;
1363 register int i
, num
;
1366 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1369 CHECK_LIST_CONS (list
, list
);
1375 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1376 doc
: /* Return the Nth element of LIST.
1377 N counts from zero. If LIST is not that long, nil is returned. */)
1379 Lisp_Object n
, list
;
1381 return Fcar (Fnthcdr (n
, list
));
1384 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1385 doc
: /* Return element of SEQUENCE at index N. */)
1387 register Lisp_Object sequence
, n
;
1390 if (CONSP (sequence
) || NILP (sequence
))
1391 return Fcar (Fnthcdr (n
, sequence
));
1393 /* Faref signals a "not array" error, so check here. */
1394 CHECK_ARRAY (sequence
, Qsequencep
);
1395 return Faref (sequence
, n
);
1398 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1399 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1400 The value is actually the tail of LIST whose car is ELT. */)
1402 register Lisp_Object elt
;
1405 register Lisp_Object tail
;
1406 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1408 register Lisp_Object tem
;
1409 CHECK_LIST_CONS (tail
, list
);
1411 if (! NILP (Fequal (elt
, tem
)))
1418 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1419 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1420 The value is actually the tail of LIST whose car is ELT. */)
1422 register Lisp_Object elt
, list
;
1426 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1430 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1434 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1445 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1446 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1447 The value is actually the tail of LIST whose car is ELT. */)
1449 register Lisp_Object elt
;
1452 register Lisp_Object tail
;
1455 return Fmemq (elt
, list
);
1457 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1459 register Lisp_Object tem
;
1460 CHECK_LIST_CONS (tail
, list
);
1462 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1469 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1470 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1471 The value is actually the first element of LIST whose car is KEY.
1472 Elements of LIST that are not conses are ignored. */)
1474 Lisp_Object key
, list
;
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCAR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCAR (XCAR (list
)), key
)))
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCAR (XCAR (list
)), key
)))
1502 /* Like Fassq but never report an error and do not allow quits.
1503 Use only on lists known never to be circular. */
1506 assq_no_quit (key
, list
)
1507 Lisp_Object key
, list
;
1510 && (!CONSP (XCAR (list
))
1511 || !EQ (XCAR (XCAR (list
)), key
)))
1514 return CAR_SAFE (list
);
1517 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1518 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1519 The value is actually the first element of LIST whose car equals KEY. */)
1521 Lisp_Object key
, list
;
1528 || (CONSP (XCAR (list
))
1529 && (car
= XCAR (XCAR (list
)),
1530 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1535 || (CONSP (XCAR (list
))
1536 && (car
= XCAR (XCAR (list
)),
1537 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1542 || (CONSP (XCAR (list
))
1543 && (car
= XCAR (XCAR (list
)),
1544 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1554 /* Like Fassoc but never report an error and do not allow quits.
1555 Use only on lists known never to be circular. */
1558 assoc_no_quit (key
, list
)
1559 Lisp_Object key
, list
;
1562 && (!CONSP (XCAR (list
))
1563 || (!EQ (XCAR (XCAR (list
)), key
)
1564 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1567 return CONSP (list
) ? XCAR (list
) : Qnil
;
1570 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1571 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1572 The value is actually the first element of LIST whose cdr is KEY. */)
1574 register Lisp_Object key
;
1580 || (CONSP (XCAR (list
))
1581 && EQ (XCDR (XCAR (list
)), key
)))
1586 || (CONSP (XCAR (list
))
1587 && EQ (XCDR (XCAR (list
)), key
)))
1592 || (CONSP (XCAR (list
))
1593 && EQ (XCDR (XCAR (list
)), key
)))
1603 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1604 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1605 The value is actually the first element of LIST whose cdr equals KEY. */)
1607 Lisp_Object key
, list
;
1614 || (CONSP (XCAR (list
))
1615 && (cdr
= XCDR (XCAR (list
)),
1616 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1621 || (CONSP (XCAR (list
))
1622 && (cdr
= XCDR (XCAR (list
)),
1623 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1628 || (CONSP (XCAR (list
))
1629 && (cdr
= XCDR (XCAR (list
)),
1630 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1640 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1641 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1642 The modified LIST is returned. Comparison is done with `eq'.
1643 If the first member of LIST is ELT, there is no way to remove it by side effect;
1644 therefore, write `(setq foo (delq element foo))'
1645 to be sure of changing the value of `foo'. */)
1647 register Lisp_Object elt
;
1650 register Lisp_Object tail
, prev
;
1651 register Lisp_Object tem
;
1655 while (!NILP (tail
))
1657 CHECK_LIST_CONS (tail
, list
);
1664 Fsetcdr (prev
, XCDR (tail
));
1674 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1675 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1676 SEQ must be a list, a vector, or a string.
1677 The modified SEQ is returned. Comparison is done with `equal'.
1678 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1679 is not a side effect; it is simply using a different sequence.
1680 Therefore, write `(setq foo (delete element foo))'
1681 to be sure of changing the value of `foo'. */)
1683 Lisp_Object elt
, seq
;
1689 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1690 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1693 if (n
!= ASIZE (seq
))
1695 struct Lisp_Vector
*p
= allocate_vector (n
);
1697 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1698 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1699 p
->contents
[n
++] = AREF (seq
, i
);
1701 XSETVECTOR (seq
, p
);
1704 else if (STRINGP (seq
))
1706 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1709 for (i
= nchars
= nbytes
= ibyte
= 0;
1711 ++i
, ibyte
+= cbytes
)
1713 if (STRING_MULTIBYTE (seq
))
1715 c
= STRING_CHAR (SDATA (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 cbytes
= CHAR_BYTES (c
);
1754 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1756 unsigned char *from
= SDATA (seq
) + ibyte
;
1757 unsigned char *to
= SDATA (tem
) + nbytes
;
1763 for (n
= cbytes
; n
--; )
1773 Lisp_Object tail
, prev
;
1775 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1777 CHECK_LIST_CONS (tail
, seq
);
1779 if (!NILP (Fequal (elt
, XCAR (tail
))))
1784 Fsetcdr (prev
, XCDR (tail
));
1795 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1796 doc
: /* Reverse LIST by modifying cdr pointers.
1797 Return the reversed list. */)
1801 register Lisp_Object prev
, tail
, next
;
1803 if (NILP (list
)) return list
;
1806 while (!NILP (tail
))
1809 CHECK_LIST_CONS (tail
, list
);
1811 Fsetcdr (tail
, prev
);
1818 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1819 doc
: /* Reverse LIST, copying. Return the reversed list.
1820 See also the function `nreverse', which is used more often. */)
1826 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1829 new = Fcons (XCAR (list
), new);
1831 CHECK_LIST_END (list
, list
);
1835 Lisp_Object
merge ();
1837 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1838 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1839 Returns the sorted list. LIST is modified by side effects.
1840 PREDICATE is called with two elements of LIST, and should return non-nil
1841 if the first element should sort before the second. */)
1843 Lisp_Object list
, predicate
;
1845 Lisp_Object front
, back
;
1846 register Lisp_Object len
, tem
;
1847 struct gcpro gcpro1
, gcpro2
;
1848 register int length
;
1851 len
= Flength (list
);
1852 length
= XINT (len
);
1856 XSETINT (len
, (length
/ 2) - 1);
1857 tem
= Fnthcdr (len
, list
);
1859 Fsetcdr (tem
, Qnil
);
1861 GCPRO2 (front
, back
);
1862 front
= Fsort (front
, predicate
);
1863 back
= Fsort (back
, predicate
);
1865 return merge (front
, back
, predicate
);
1869 merge (org_l1
, org_l2
, pred
)
1870 Lisp_Object org_l1
, org_l2
;
1874 register Lisp_Object tail
;
1876 register Lisp_Object l1
, l2
;
1877 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1884 /* It is sufficient to protect org_l1 and org_l2.
1885 When l1 and l2 are updated, we copy the new values
1886 back into the org_ vars. */
1887 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1907 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1923 Fsetcdr (tail
, tem
);
1929 /* This does not check for quits. That is safe since it must terminate. */
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 one of the
1936 properties on the list. This function never signals an error. */)
1941 Lisp_Object tail
, halftail
;
1943 /* halftail is used to detect circular lists. */
1944 tail
= halftail
= plist
;
1945 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1947 if (EQ (prop
, XCAR (tail
)))
1948 return XCAR (XCDR (tail
));
1950 tail
= XCDR (XCDR (tail
));
1951 halftail
= XCDR (halftail
);
1952 if (EQ (tail
, halftail
))
1955 #if 0 /* Unsafe version. */
1956 /* This function can be called asynchronously
1957 (setup_coding_system). Don't QUIT in that case. */
1958 if (!interrupt_input_blocked
)
1966 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1967 doc
: /* Return the value of SYMBOL's PROPNAME property.
1968 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1970 Lisp_Object symbol
, propname
;
1972 CHECK_SYMBOL (symbol
);
1973 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1976 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1977 doc
: /* Change value in PLIST of PROP to VAL.
1978 PLIST is a property list, which is a list of the form
1979 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1980 If PROP is already a property on the list, its value is set to VAL,
1981 otherwise the new PROP VAL pair is added. The new plist is returned;
1982 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1983 The PLIST is modified by side effects. */)
1986 register Lisp_Object prop
;
1989 register Lisp_Object tail
, prev
;
1990 Lisp_Object newcell
;
1992 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1993 tail
= XCDR (XCDR (tail
)))
1995 if (EQ (prop
, XCAR (tail
)))
1997 Fsetcar (XCDR (tail
), val
);
2004 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2008 Fsetcdr (XCDR (prev
), newcell
);
2012 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2013 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2014 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2015 (symbol
, propname
, value
)
2016 Lisp_Object symbol
, propname
, value
;
2018 CHECK_SYMBOL (symbol
);
2019 XSYMBOL (symbol
)->plist
2020 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2024 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2025 doc
: /* Extract a value from a property list, comparing with `equal'.
2026 PLIST is a property list, which is a list of the form
2027 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2028 corresponding to the given PROP, or nil if PROP is not
2029 one of the properties on the list. */)
2037 CONSP (tail
) && CONSP (XCDR (tail
));
2038 tail
= XCDR (XCDR (tail
)))
2040 if (! NILP (Fequal (prop
, XCAR (tail
))))
2041 return XCAR (XCDR (tail
));
2046 CHECK_LIST_END (tail
, prop
);
2051 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2052 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2053 PLIST is a property list, which is a list of the form
2054 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2055 If PROP is already a property on the list, its value is set to VAL,
2056 otherwise the new PROP VAL pair is added. The new plist is returned;
2057 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2058 The PLIST is modified by side effects. */)
2061 register Lisp_Object prop
;
2064 register Lisp_Object tail
, prev
;
2065 Lisp_Object newcell
;
2067 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2068 tail
= XCDR (XCDR (tail
)))
2070 if (! NILP (Fequal (prop
, XCAR (tail
))))
2072 Fsetcar (XCDR (tail
), val
);
2079 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2083 Fsetcdr (XCDR (prev
), newcell
);
2087 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2088 doc
: /* Return t if the two args are the same Lisp object.
2089 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2091 Lisp_Object obj1
, obj2
;
2094 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2096 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2099 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2100 doc
: /* Return t if two Lisp objects have similar structure and contents.
2101 They must have the same data type.
2102 Conses are compared by comparing the cars and the cdrs.
2103 Vectors and strings are compared element by element.
2104 Numbers are compared by value, but integers cannot equal floats.
2105 (Use `=' if you want integers and floats to be able to be equal.)
2106 Symbols must match exactly. */)
2108 register Lisp_Object o1
, o2
;
2110 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2113 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2114 doc
: /* Return t if two Lisp objects have similar structure and contents.
2115 This is like `equal' except that it compares the text properties
2116 of strings. (`equal' ignores text properties.) */)
2118 register Lisp_Object o1
, o2
;
2120 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2123 /* DEPTH is current depth of recursion. Signal an error if it
2125 PROPS, if non-nil, means compare string text properties too. */
2128 internal_equal (o1
, o2
, depth
, props
)
2129 register Lisp_Object o1
, o2
;
2133 error ("Stack overflow in equal");
2139 if (XTYPE (o1
) != XTYPE (o2
))
2148 d1
= extract_float (o1
);
2149 d2
= extract_float (o2
);
2150 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2151 though they are not =. */
2152 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2156 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2163 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2167 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2169 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2172 o1
= XOVERLAY (o1
)->plist
;
2173 o2
= XOVERLAY (o2
)->plist
;
2178 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2179 && (XMARKER (o1
)->buffer
== 0
2180 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2184 case Lisp_Vectorlike
:
2187 EMACS_INT size
= ASIZE (o1
);
2188 /* Pseudovectors have the type encoded in the size field, so this test
2189 actually checks that the objects have the same type as well as the
2191 if (ASIZE (o2
) != size
)
2193 /* Boolvectors are compared much like strings. */
2194 if (BOOL_VECTOR_P (o1
))
2197 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2198 / BOOL_VECTOR_BITS_PER_CHAR
);
2200 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2202 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2207 if (WINDOW_CONFIGURATIONP (o1
))
2208 return compare_window_configurations (o1
, o2
, 0);
2210 /* Aside from them, only true vectors, char-tables, compiled
2211 functions, and fonts (font-spec, font-entity, font-ojbect)
2212 are sensible to compare, so eliminate the others now. */
2213 if (size
& PSEUDOVECTOR_FLAG
)
2215 if (!(size
& (PVEC_COMPILED
2216 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2218 size
&= PSEUDOVECTOR_SIZE_MASK
;
2220 for (i
= 0; i
< size
; i
++)
2225 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2233 if (SCHARS (o1
) != SCHARS (o2
))
2235 if (SBYTES (o1
) != SBYTES (o2
))
2237 if (bcmp (SDATA (o1
), SDATA (o2
),
2240 if (props
&& !compare_string_intervals (o1
, o2
))
2251 extern Lisp_Object
Fmake_char_internal ();
2253 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2254 doc
: /* Store each element of ARRAY with ITEM.
2255 ARRAY is a vector, string, char-table, or bool-vector. */)
2257 Lisp_Object array
, item
;
2259 register int size
, index
, charval
;
2260 if (VECTORP (array
))
2262 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2263 size
= ASIZE (array
);
2264 for (index
= 0; index
< size
; index
++)
2267 else if (CHAR_TABLE_P (array
))
2271 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2272 XCHAR_TABLE (array
)->contents
[i
] = item
;
2273 XCHAR_TABLE (array
)->defalt
= item
;
2275 else if (STRINGP (array
))
2277 register unsigned char *p
= SDATA (array
);
2278 CHECK_NUMBER (item
);
2279 charval
= XINT (item
);
2280 size
= SCHARS (array
);
2281 if (STRING_MULTIBYTE (array
))
2283 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2284 int len
= CHAR_STRING (charval
, str
);
2285 int size_byte
= SBYTES (array
);
2286 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2289 if (size
!= size_byte
)
2292 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2293 if (len
!= this_len
)
2294 error ("Attempt to change byte length of a string");
2297 for (i
= 0; i
< size_byte
; i
++)
2298 *p
++ = str
[i
% len
];
2301 for (index
= 0; index
< size
; index
++)
2304 else if (BOOL_VECTOR_P (array
))
2306 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2308 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2309 / BOOL_VECTOR_BITS_PER_CHAR
);
2311 charval
= (! NILP (item
) ? -1 : 0);
2312 for (index
= 0; index
< size_in_chars
- 1; index
++)
2314 if (index
< size_in_chars
)
2316 /* Mask out bits beyond the vector size. */
2317 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2318 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2323 wrong_type_argument (Qarrayp
, array
);
2327 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2329 doc
: /* Clear the contents of STRING.
2330 This makes STRING unibyte and may change its length. */)
2335 CHECK_STRING (string
);
2336 len
= SBYTES (string
);
2337 bzero (SDATA (string
), len
);
2338 STRING_SET_CHARS (string
, len
);
2339 STRING_SET_UNIBYTE (string
);
2349 Lisp_Object args
[2];
2352 return Fnconc (2, args
);
2354 return Fnconc (2, &s1
);
2355 #endif /* NO_ARG_ARRAY */
2358 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2359 doc
: /* Concatenate any number of lists by altering them.
2360 Only the last argument is not altered, and need not be a list.
2361 usage: (nconc &rest LISTS) */)
2366 register int argnum
;
2367 register Lisp_Object tail
, tem
, val
;
2371 for (argnum
= 0; argnum
< nargs
; argnum
++)
2374 if (NILP (tem
)) continue;
2379 if (argnum
+ 1 == nargs
) break;
2381 CHECK_LIST_CONS (tem
, tem
);
2390 tem
= args
[argnum
+ 1];
2391 Fsetcdr (tail
, tem
);
2393 args
[argnum
+ 1] = tail
;
2399 /* This is the guts of all mapping functions.
2400 Apply FN to each element of SEQ, one by one,
2401 storing the results into elements of VALS, a C vector of Lisp_Objects.
2402 LENI is the length of VALS, which should also be the length of SEQ. */
2405 mapcar1 (leni
, vals
, fn
, seq
)
2408 Lisp_Object fn
, seq
;
2410 register Lisp_Object tail
;
2413 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2417 /* Don't let vals contain any garbage when GC happens. */
2418 for (i
= 0; i
< leni
; i
++)
2421 GCPRO3 (dummy
, fn
, seq
);
2423 gcpro1
.nvars
= leni
;
2427 /* We need not explicitly protect `tail' because it is used only on lists, and
2428 1) lists are not relocated and 2) the list is marked via `seq' so will not
2433 for (i
= 0; i
< leni
; i
++)
2435 dummy
= call1 (fn
, AREF (seq
, i
));
2440 else if (BOOL_VECTOR_P (seq
))
2442 for (i
= 0; i
< leni
; i
++)
2445 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2446 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2447 dummy
= call1 (fn
, dummy
);
2452 else if (STRINGP (seq
))
2456 for (i
= 0, i_byte
= 0; i
< leni
;)
2461 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2462 XSETFASTINT (dummy
, c
);
2463 dummy
= call1 (fn
, dummy
);
2465 vals
[i_before
] = dummy
;
2468 else /* Must be a list, since Flength did not get an error */
2471 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2473 dummy
= call1 (fn
, XCAR (tail
));
2483 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2484 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2485 In between each pair of results, stick in SEPARATOR. Thus, " " as
2486 SEPARATOR results in spaces between the values returned by FUNCTION.
2487 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2488 (function
, sequence
, separator
)
2489 Lisp_Object function
, sequence
, separator
;
2494 register Lisp_Object
*args
;
2496 struct gcpro gcpro1
;
2500 len
= Flength (sequence
);
2501 if (CHAR_TABLE_P (sequence
))
2502 wrong_type_argument (Qlistp
, sequence
);
2504 nargs
= leni
+ leni
- 1;
2505 if (nargs
< 0) return empty_unibyte_string
;
2507 SAFE_ALLOCA_LISP (args
, nargs
);
2510 mapcar1 (leni
, args
, function
, sequence
);
2513 for (i
= leni
- 1; i
> 0; i
--)
2514 args
[i
+ i
] = args
[i
];
2516 for (i
= 1; i
< nargs
; i
+= 2)
2517 args
[i
] = separator
;
2519 ret
= Fconcat (nargs
, args
);
2525 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2526 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2527 The result is a list just as long as SEQUENCE.
2528 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2529 (function
, sequence
)
2530 Lisp_Object function
, sequence
;
2532 register Lisp_Object len
;
2534 register Lisp_Object
*args
;
2538 len
= Flength (sequence
);
2539 if (CHAR_TABLE_P (sequence
))
2540 wrong_type_argument (Qlistp
, sequence
);
2541 leni
= XFASTINT (len
);
2543 SAFE_ALLOCA_LISP (args
, leni
);
2545 mapcar1 (leni
, args
, function
, sequence
);
2547 ret
= Flist (leni
, args
);
2553 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2554 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2555 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2556 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2557 (function
, sequence
)
2558 Lisp_Object function
, sequence
;
2562 leni
= XFASTINT (Flength (sequence
));
2563 if (CHAR_TABLE_P (sequence
))
2564 wrong_type_argument (Qlistp
, sequence
);
2565 mapcar1 (leni
, 0, function
, sequence
);
2570 /* Anything that calls this function must protect from GC! */
2572 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2573 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2574 Takes one argument, which is the string to display to ask the question.
2575 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2576 No confirmation of the answer is requested; a single character is enough.
2577 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2578 the bindings in `query-replace-map'; see the documentation of that variable
2579 for more information. In this case, the useful bindings are `act', `skip',
2580 `recenter', and `quit'.\)
2582 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2583 is nil and `use-dialog-box' is non-nil. */)
2587 register Lisp_Object obj
, key
, def
, map
;
2588 register int answer
;
2589 Lisp_Object xprompt
;
2590 Lisp_Object args
[2];
2591 struct gcpro gcpro1
, gcpro2
;
2592 int count
= SPECPDL_INDEX ();
2594 specbind (Qcursor_in_echo_area
, Qt
);
2596 map
= Fsymbol_value (intern ("query-replace-map"));
2598 CHECK_STRING (prompt
);
2600 GCPRO2 (prompt
, xprompt
);
2602 #ifdef HAVE_WINDOW_SYSTEM
2603 if (display_hourglass_p
)
2604 cancel_hourglass ();
2611 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2612 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2616 Lisp_Object pane
, menu
;
2617 redisplay_preserve_echo_area (3);
2618 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2619 Fcons (Fcons (build_string ("No"), Qnil
),
2621 menu
= Fcons (prompt
, pane
);
2622 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2623 answer
= !NILP (obj
);
2626 #endif /* HAVE_MENUS */
2627 cursor_in_echo_area
= 1;
2628 choose_minibuf_frame ();
2631 Lisp_Object pargs
[3];
2633 /* Colorize prompt according to `minibuffer-prompt' face. */
2634 pargs
[0] = build_string ("%s(y or n) ");
2635 pargs
[1] = intern ("face");
2636 pargs
[2] = intern ("minibuffer-prompt");
2637 args
[0] = Fpropertize (3, pargs
);
2642 if (minibuffer_auto_raise
)
2644 Lisp_Object mini_frame
;
2646 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2648 Fraise_frame (mini_frame
);
2651 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2652 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2653 cursor_in_echo_area
= 0;
2654 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2657 key
= Fmake_vector (make_number (1), obj
);
2658 def
= Flookup_key (map
, key
, Qt
);
2660 if (EQ (def
, intern ("skip")))
2665 else if (EQ (def
, intern ("act")))
2670 else if (EQ (def
, intern ("recenter")))
2676 else if (EQ (def
, intern ("quit")))
2678 /* We want to exit this command for exit-prefix,
2679 and this is the only way to do it. */
2680 else if (EQ (def
, intern ("exit-prefix")))
2685 /* If we don't clear this, then the next call to read_char will
2686 return quit_char again, and we'll enter an infinite loop. */
2691 if (EQ (xprompt
, prompt
))
2693 args
[0] = build_string ("Please answer y or n. ");
2695 xprompt
= Fconcat (2, args
);
2700 if (! noninteractive
)
2702 cursor_in_echo_area
= -1;
2703 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2707 unbind_to (count
, Qnil
);
2708 return answer
? Qt
: Qnil
;
2711 /* This is how C code calls `yes-or-no-p' and allows the user
2714 Anything that calls this function must protect from GC! */
2717 do_yes_or_no_p (prompt
)
2720 return call1 (intern ("yes-or-no-p"), prompt
);
2723 /* Anything that calls this function must protect from GC! */
2725 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2726 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2727 Takes one argument, which is the string to display to ask the question.
2728 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2729 The user must confirm the answer with RET,
2730 and can edit it until it has been confirmed.
2732 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2733 is nil, and `use-dialog-box' is non-nil. */)
2737 register Lisp_Object ans
;
2738 Lisp_Object args
[2];
2739 struct gcpro gcpro1
;
2741 CHECK_STRING (prompt
);
2744 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2745 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2749 Lisp_Object pane
, menu
, obj
;
2750 redisplay_preserve_echo_area (4);
2751 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2752 Fcons (Fcons (build_string ("No"), Qnil
),
2755 menu
= Fcons (prompt
, pane
);
2756 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2760 #endif /* HAVE_MENUS */
2763 args
[1] = build_string ("(yes or no) ");
2764 prompt
= Fconcat (2, args
);
2770 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2771 Qyes_or_no_p_history
, Qnil
,
2773 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2778 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2786 message ("Please answer yes or no.");
2787 Fsleep_for (make_number (2), Qnil
);
2791 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2792 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2794 Each of the three load averages is multiplied by 100, then converted
2797 When USE-FLOATS is non-nil, floats will be used instead of integers.
2798 These floats are not multiplied by 100.
2800 If the 5-minute or 15-minute load averages are not available, return a
2801 shortened list, containing only those averages which are available.
2803 An error is thrown if the load average can't be obtained. In some
2804 cases making it work would require Emacs being installed setuid or
2805 setgid so that it can read kernel information, and that usually isn't
2808 Lisp_Object use_floats
;
2811 int loads
= getloadavg (load_ave
, 3);
2812 Lisp_Object ret
= Qnil
;
2815 error ("load-average not implemented for this operating system");
2819 Lisp_Object load
= (NILP (use_floats
) ?
2820 make_number ((int) (100.0 * load_ave
[loads
]))
2821 : make_float (load_ave
[loads
]));
2822 ret
= Fcons (load
, ret
);
2828 Lisp_Object Vfeatures
, Qsubfeatures
;
2829 extern Lisp_Object Vafter_load_alist
;
2831 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2832 doc
: /* Returns t if FEATURE is present in this Emacs.
2834 Use this to conditionalize execution of lisp code based on the
2835 presence or absence of Emacs or environment extensions.
2836 Use `provide' to declare that a feature is available. This function
2837 looks at the value of the variable `features'. The optional argument
2838 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2839 (feature
, subfeature
)
2840 Lisp_Object feature
, subfeature
;
2842 register Lisp_Object tem
;
2843 CHECK_SYMBOL (feature
);
2844 tem
= Fmemq (feature
, Vfeatures
);
2845 if (!NILP (tem
) && !NILP (subfeature
))
2846 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2847 return (NILP (tem
)) ? Qnil
: Qt
;
2850 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2851 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2852 The optional argument SUBFEATURES should be a list of symbols listing
2853 particular subfeatures supported in this version of FEATURE. */)
2854 (feature
, subfeatures
)
2855 Lisp_Object feature
, subfeatures
;
2857 register Lisp_Object tem
;
2858 CHECK_SYMBOL (feature
);
2859 CHECK_LIST (subfeatures
);
2860 if (!NILP (Vautoload_queue
))
2861 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2863 tem
= Fmemq (feature
, Vfeatures
);
2865 Vfeatures
= Fcons (feature
, Vfeatures
);
2866 if (!NILP (subfeatures
))
2867 Fput (feature
, Qsubfeatures
, subfeatures
);
2868 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2870 /* Run any load-hooks for this file. */
2871 tem
= Fassq (feature
, Vafter_load_alist
);
2873 Fprogn (XCDR (tem
));
2878 /* `require' and its subroutines. */
2880 /* List of features currently being require'd, innermost first. */
2882 Lisp_Object require_nesting_list
;
2885 require_unwind (old_value
)
2886 Lisp_Object old_value
;
2888 return require_nesting_list
= old_value
;
2891 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2892 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2893 If FEATURE is not a member of the list `features', then the feature
2894 is not loaded; so load the file FILENAME.
2895 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2896 and `load' will try to load this name appended with the suffix `.elc' or
2897 `.el', in that order. The name without appended suffix will not be used.
2898 If the optional third argument NOERROR is non-nil,
2899 then return nil if the file is not found instead of signaling an error.
2900 Normally the return value is FEATURE.
2901 The normal messages at start and end of loading FILENAME are suppressed. */)
2902 (feature
, filename
, noerror
)
2903 Lisp_Object feature
, filename
, noerror
;
2905 register Lisp_Object tem
;
2906 struct gcpro gcpro1
, gcpro2
;
2907 int from_file
= load_in_progress
;
2909 CHECK_SYMBOL (feature
);
2911 /* Record the presence of `require' in this file
2912 even if the feature specified is already loaded.
2913 But not more than once in any file,
2914 and not when we aren't loading or reading from a file. */
2916 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2917 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2922 tem
= Fcons (Qrequire
, feature
);
2923 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2924 LOADHIST_ATTACH (tem
);
2926 tem
= Fmemq (feature
, Vfeatures
);
2930 int count
= SPECPDL_INDEX ();
2933 /* This is to make sure that loadup.el gives a clear picture
2934 of what files are preloaded and when. */
2935 if (! NILP (Vpurify_flag
))
2936 error ("(require %s) while preparing to dump",
2937 SDATA (SYMBOL_NAME (feature
)));
2939 /* A certain amount of recursive `require' is legitimate,
2940 but if we require the same feature recursively 3 times,
2942 tem
= require_nesting_list
;
2943 while (! NILP (tem
))
2945 if (! NILP (Fequal (feature
, XCAR (tem
))))
2950 error ("Recursive `require' for feature `%s'",
2951 SDATA (SYMBOL_NAME (feature
)));
2953 /* Update the list for any nested `require's that occur. */
2954 record_unwind_protect (require_unwind
, require_nesting_list
);
2955 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2957 /* Value saved here is to be restored into Vautoload_queue */
2958 record_unwind_protect (un_autoload
, Vautoload_queue
);
2959 Vautoload_queue
= Qt
;
2961 /* Load the file. */
2962 GCPRO2 (feature
, filename
);
2963 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2964 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2967 /* If load failed entirely, return nil. */
2969 return unbind_to (count
, Qnil
);
2971 tem
= Fmemq (feature
, Vfeatures
);
2973 error ("Required feature `%s' was not provided",
2974 SDATA (SYMBOL_NAME (feature
)));
2976 /* Once loading finishes, don't undo it. */
2977 Vautoload_queue
= Qt
;
2978 feature
= unbind_to (count
, feature
);
2984 /* Primitives for work of the "widget" library.
2985 In an ideal world, this section would not have been necessary.
2986 However, lisp function calls being as slow as they are, it turns
2987 out that some functions in the widget library (wid-edit.el) are the
2988 bottleneck of Widget operation. Here is their translation to C,
2989 for the sole reason of efficiency. */
2991 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2992 doc
: /* Return non-nil if PLIST has the property PROP.
2993 PLIST is a property list, which is a list of the form
2994 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2995 Unlike `plist-get', this allows you to distinguish between a missing
2996 property and a property with the value nil.
2997 The value is actually the tail of PLIST whose car is PROP. */)
2999 Lisp_Object plist
, prop
;
3001 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3004 plist
= XCDR (plist
);
3005 plist
= CDR (plist
);
3010 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3011 doc
: /* In WIDGET, set PROPERTY to VALUE.
3012 The value can later be retrieved with `widget-get'. */)
3013 (widget
, property
, value
)
3014 Lisp_Object widget
, property
, value
;
3016 CHECK_CONS (widget
);
3017 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3021 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3022 doc
: /* In WIDGET, get the value of PROPERTY.
3023 The value could either be specified when the widget was created, or
3024 later with `widget-put'. */)
3026 Lisp_Object widget
, property
;
3034 CHECK_CONS (widget
);
3035 tmp
= Fplist_member (XCDR (widget
), property
);
3041 tmp
= XCAR (widget
);
3044 widget
= Fget (tmp
, Qwidget_type
);
3048 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3049 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3050 ARGS are passed as extra arguments to the function.
3051 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3056 /* This function can GC. */
3057 Lisp_Object newargs
[3];
3058 struct gcpro gcpro1
, gcpro2
;
3061 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3062 newargs
[1] = args
[0];
3063 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3064 GCPRO2 (newargs
[0], newargs
[2]);
3065 result
= Fapply (3, newargs
);
3070 #ifdef HAVE_LANGINFO_CODESET
3071 #include <langinfo.h>
3074 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3075 doc
: /* Access locale data ITEM for the current C locale, if available.
3076 ITEM should be one of the following:
3078 `codeset', returning the character set as a string (locale item CODESET);
3080 `days', returning a 7-element vector of day names (locale items DAY_n);
3082 `months', returning a 12-element vector of month names (locale items MON_n);
3084 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3085 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3087 If the system can't provide such information through a call to
3088 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3090 See also Info node `(libc)Locales'.
3092 The data read from the system are decoded using `locale-coding-system'. */)
3097 #ifdef HAVE_LANGINFO_CODESET
3099 if (EQ (item
, Qcodeset
))
3101 str
= nl_langinfo (CODESET
);
3102 return build_string (str
);
3105 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3107 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3108 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3110 struct gcpro gcpro1
;
3112 synchronize_system_time_locale ();
3113 for (i
= 0; i
< 7; i
++)
3115 str
= nl_langinfo (days
[i
]);
3116 val
= make_unibyte_string (str
, strlen (str
));
3117 /* Fixme: Is this coding system necessarily right, even if
3118 it is consistent with CODESET? If not, what to do? */
3119 Faset (v
, make_number (i
),
3120 code_convert_string_norecord (val
, Vlocale_coding_system
,
3128 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3130 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3131 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3132 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3134 struct gcpro gcpro1
;
3136 synchronize_system_time_locale ();
3137 for (i
= 0; i
< 12; i
++)
3139 str
= nl_langinfo (months
[i
]);
3140 val
= make_unibyte_string (str
, strlen (str
));
3141 Faset (v
, make_number (i
),
3142 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3148 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3149 but is in the locale files. This could be used by ps-print. */
3151 else if (EQ (item
, Qpaper
))
3153 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3154 make_number (nl_langinfo (PAPER_HEIGHT
)));
3156 #endif /* PAPER_WIDTH */
3157 #endif /* HAVE_LANGINFO_CODESET*/
3161 /* base64 encode/decode functions (RFC 2045).
3162 Based on code from GNU recode. */
3164 #define MIME_LINE_LENGTH 76
3166 #define IS_ASCII(Character) \
3168 #define IS_BASE64(Character) \
3169 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3170 #define IS_BASE64_IGNORABLE(Character) \
3171 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3172 || (Character) == '\f' || (Character) == '\r')
3174 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3175 character or return retval if there are no characters left to
3177 #define READ_QUADRUPLET_BYTE(retval) \
3182 if (nchars_return) \
3183 *nchars_return = nchars; \
3188 while (IS_BASE64_IGNORABLE (c))
3190 /* Table of characters coding the 64 values. */
3191 static const char base64_value_to_char
[64] =
3193 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3194 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3195 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3196 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3197 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3198 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3199 '8', '9', '+', '/' /* 60-63 */
3202 /* Table of base64 values for first 128 characters. */
3203 static const short base64_char_to_value
[128] =
3205 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3206 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3207 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3208 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3209 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3210 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3211 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3212 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3213 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3214 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3215 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3216 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3217 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3220 /* The following diagram shows the logical steps by which three octets
3221 get transformed into four base64 characters.
3223 .--------. .--------. .--------.
3224 |aaaaaabb| |bbbbcccc| |ccdddddd|
3225 `--------' `--------' `--------'
3227 .--------+--------+--------+--------.
3228 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3229 `--------+--------+--------+--------'
3231 .--------+--------+--------+--------.
3232 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3233 `--------+--------+--------+--------'
3235 The octets are divided into 6 bit chunks, which are then encoded into
3236 base64 characters. */
3239 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3240 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3242 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3244 doc
: /* Base64-encode the region between BEG and END.
3245 Return the length of the encoded text.
3246 Optional third argument NO-LINE-BREAK means do not break long lines
3247 into shorter lines. */)
3248 (beg
, end
, no_line_break
)
3249 Lisp_Object beg
, end
, no_line_break
;
3252 int allength
, length
;
3253 int ibeg
, iend
, encoded_length
;
3257 validate_region (&beg
, &end
);
3259 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3260 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3261 move_gap_both (XFASTINT (beg
), ibeg
);
3263 /* We need to allocate enough room for encoding the text.
3264 We need 33 1/3% more space, plus a newline every 76
3265 characters, and then we round up. */
3266 length
= iend
- ibeg
;
3267 allength
= length
+ length
/3 + 1;
3268 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3270 SAFE_ALLOCA (encoded
, char *, allength
);
3271 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3272 NILP (no_line_break
),
3273 !NILP (current_buffer
->enable_multibyte_characters
));
3274 if (encoded_length
> allength
)
3277 if (encoded_length
< 0)
3279 /* The encoding wasn't possible. */
3281 error ("Multibyte character in data for base64 encoding");
3284 /* Now we have encoded the region, so we insert the new contents
3285 and delete the old. (Insert first in order to preserve markers.) */
3286 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3287 insert (encoded
, encoded_length
);
3289 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3291 /* If point was outside of the region, restore it exactly; else just
3292 move to the beginning of the region. */
3293 if (old_pos
>= XFASTINT (end
))
3294 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3295 else if (old_pos
> XFASTINT (beg
))
3296 old_pos
= XFASTINT (beg
);
3299 /* We return the length of the encoded text. */
3300 return make_number (encoded_length
);
3303 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3305 doc
: /* Base64-encode STRING and return the result.
3306 Optional second argument NO-LINE-BREAK means do not break long lines
3307 into shorter lines. */)
3308 (string
, no_line_break
)
3309 Lisp_Object string
, no_line_break
;
3311 int allength
, length
, encoded_length
;
3313 Lisp_Object encoded_string
;
3316 CHECK_STRING (string
);
3318 /* We need to allocate enough room for encoding the text.
3319 We need 33 1/3% more space, plus a newline every 76
3320 characters, and then we round up. */
3321 length
= SBYTES (string
);
3322 allength
= length
+ length
/3 + 1;
3323 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3325 /* We need to allocate enough room for decoding the text. */
3326 SAFE_ALLOCA (encoded
, char *, allength
);
3328 encoded_length
= base64_encode_1 (SDATA (string
),
3329 encoded
, length
, NILP (no_line_break
),
3330 STRING_MULTIBYTE (string
));
3331 if (encoded_length
> allength
)
3334 if (encoded_length
< 0)
3336 /* The encoding wasn't possible. */
3338 error ("Multibyte character in data for base64 encoding");
3341 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3344 return encoded_string
;
3348 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3355 int counter
= 0, i
= 0;
3365 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3366 if (CHAR_BYTE8_P (c
))
3367 c
= CHAR_TO_BYTE8 (c
);
3375 /* Wrap line every 76 characters. */
3379 if (counter
< MIME_LINE_LENGTH
/ 4)
3388 /* Process first byte of a triplet. */
3390 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3391 value
= (0x03 & c
) << 4;
3393 /* Process second byte of a triplet. */
3397 *e
++ = base64_value_to_char
[value
];
3405 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3406 if (CHAR_BYTE8_P (c
))
3407 c
= CHAR_TO_BYTE8 (c
);
3415 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3416 value
= (0x0f & c
) << 2;
3418 /* Process third byte of a triplet. */
3422 *e
++ = base64_value_to_char
[value
];
3429 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3430 if (CHAR_BYTE8_P (c
))
3431 c
= CHAR_TO_BYTE8 (c
);
3439 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3440 *e
++ = base64_value_to_char
[0x3f & c
];
3447 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3449 doc
: /* Base64-decode the region between BEG and END.
3450 Return the length of the decoded text.
3451 If the region can't be decoded, signal an error and don't modify the buffer. */)
3453 Lisp_Object beg
, end
;
3455 int ibeg
, iend
, length
, allength
;
3460 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3463 validate_region (&beg
, &end
);
3465 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3466 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3468 length
= iend
- ibeg
;
3470 /* We need to allocate enough room for decoding the text. If we are
3471 working on a multibyte buffer, each decoded code may occupy at
3473 allength
= multibyte
? length
* 2 : length
;
3474 SAFE_ALLOCA (decoded
, char *, allength
);
3476 move_gap_both (XFASTINT (beg
), ibeg
);
3477 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3478 multibyte
, &inserted_chars
);
3479 if (decoded_length
> allength
)
3482 if (decoded_length
< 0)
3484 /* The decoding wasn't possible. */
3486 error ("Invalid base64 data");
3489 /* Now we have decoded the region, so we insert the new contents
3490 and delete the old. (Insert first in order to preserve markers.) */
3491 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3492 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3495 /* Delete the original text. */
3496 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3497 iend
+ decoded_length
, 1);
3499 /* If point was outside of the region, restore it exactly; else just
3500 move to the beginning of the region. */
3501 if (old_pos
>= XFASTINT (end
))
3502 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3503 else if (old_pos
> XFASTINT (beg
))
3504 old_pos
= XFASTINT (beg
);
3505 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3507 return make_number (inserted_chars
);
3510 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3512 doc
: /* Base64-decode STRING and return the result. */)
3517 int length
, decoded_length
;
3518 Lisp_Object decoded_string
;
3521 CHECK_STRING (string
);
3523 length
= SBYTES (string
);
3524 /* We need to allocate enough room for decoding the text. */
3525 SAFE_ALLOCA (decoded
, char *, length
);
3527 /* The decoded result should be unibyte. */
3528 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3530 if (decoded_length
> length
)
3532 else if (decoded_length
>= 0)
3533 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3535 decoded_string
= Qnil
;
3538 if (!STRINGP (decoded_string
))
3539 error ("Invalid base64 data");
3541 return decoded_string
;
3544 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3545 MULTIBYTE is nonzero, the decoded result should be in multibyte
3546 form. If NCHARS_RETRUN is not NULL, store the number of produced
3547 characters in *NCHARS_RETURN. */
3550 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3560 unsigned long value
;
3565 /* Process first byte of a quadruplet. */
3567 READ_QUADRUPLET_BYTE (e
-to
);
3571 value
= base64_char_to_value
[c
] << 18;
3573 /* Process second byte of a quadruplet. */
3575 READ_QUADRUPLET_BYTE (-1);
3579 value
|= base64_char_to_value
[c
] << 12;
3581 c
= (unsigned char) (value
>> 16);
3582 if (multibyte
&& c
>= 128)
3583 e
+= BYTE8_STRING (c
, e
);
3588 /* Process third byte of a quadruplet. */
3590 READ_QUADRUPLET_BYTE (-1);
3594 READ_QUADRUPLET_BYTE (-1);
3603 value
|= base64_char_to_value
[c
] << 6;
3605 c
= (unsigned char) (0xff & value
>> 8);
3606 if (multibyte
&& c
>= 128)
3607 e
+= BYTE8_STRING (c
, e
);
3612 /* Process fourth byte of a quadruplet. */
3614 READ_QUADRUPLET_BYTE (-1);
3621 value
|= base64_char_to_value
[c
];
3623 c
= (unsigned char) (0xff & value
);
3624 if (multibyte
&& c
>= 128)
3625 e
+= BYTE8_STRING (c
, e
);
3634 /***********************************************************************
3636 ***** Hash Tables *****
3638 ***********************************************************************/
3640 /* Implemented by gerd@gnu.org. This hash table implementation was
3641 inspired by CMUCL hash tables. */
3645 1. For small tables, association lists are probably faster than
3646 hash tables because they have lower overhead.
3648 For uses of hash tables where the O(1) behavior of table
3649 operations is not a requirement, it might therefore be a good idea
3650 not to hash. Instead, we could just do a linear search in the
3651 key_and_value vector of the hash table. This could be done
3652 if a `:linear-search t' argument is given to make-hash-table. */
3655 /* The list of all weak hash tables. Don't staticpro this one. */
3657 struct Lisp_Hash_Table
*weak_hash_tables
;
3659 /* Various symbols. */
3661 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3662 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3663 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3665 /* Function prototypes. */
3667 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3668 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3669 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3670 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3671 Lisp_Object
, unsigned));
3672 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3673 Lisp_Object
, unsigned));
3674 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3675 unsigned, Lisp_Object
, unsigned));
3676 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3677 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3678 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3679 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3681 static unsigned sxhash_string
P_ ((unsigned char *, int));
3682 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3683 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3684 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3685 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3689 /***********************************************************************
3691 ***********************************************************************/
3693 /* If OBJ is a Lisp hash table, return a pointer to its struct
3694 Lisp_Hash_Table. Otherwise, signal an error. */
3696 static struct Lisp_Hash_Table
*
3697 check_hash_table (obj
)
3700 CHECK_HASH_TABLE (obj
);
3701 return XHASH_TABLE (obj
);
3705 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3709 next_almost_prime (n
)
3722 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3723 which USED[I] is non-zero. If found at index I in ARGS, set
3724 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3725 -1. This function is used to extract a keyword/argument pair from
3726 a DEFUN parameter list. */
3729 get_key_arg (key
, nargs
, args
, used
)
3737 for (i
= 0; i
< nargs
- 1; ++i
)
3738 if (!used
[i
] && EQ (args
[i
], key
))
3753 /* Return a Lisp vector which has the same contents as VEC but has
3754 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3755 vector that are not copied from VEC are set to INIT. */
3758 larger_vector (vec
, new_size
, init
)
3763 struct Lisp_Vector
*v
;
3766 xassert (VECTORP (vec
));
3767 old_size
= ASIZE (vec
);
3768 xassert (new_size
>= old_size
);
3770 v
= allocate_vector (new_size
);
3771 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3772 old_size
* sizeof *v
->contents
);
3773 for (i
= old_size
; i
< new_size
; ++i
)
3774 v
->contents
[i
] = init
;
3775 XSETVECTOR (vec
, v
);
3780 /***********************************************************************
3782 ***********************************************************************/
3784 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3785 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3786 KEY2 are the same. */
3789 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3790 struct Lisp_Hash_Table
*h
;
3791 Lisp_Object key1
, key2
;
3792 unsigned hash1
, hash2
;
3794 return (FLOATP (key1
)
3796 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3800 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3801 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3802 KEY2 are the same. */
3805 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3806 struct Lisp_Hash_Table
*h
;
3807 Lisp_Object key1
, key2
;
3808 unsigned hash1
, hash2
;
3810 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3814 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3815 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3816 if KEY1 and KEY2 are the same. */
3819 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3820 struct Lisp_Hash_Table
*h
;
3821 Lisp_Object key1
, key2
;
3822 unsigned hash1
, hash2
;
3826 Lisp_Object args
[3];
3828 args
[0] = h
->user_cmp_function
;
3831 return !NILP (Ffuncall (3, args
));
3838 /* Value is a hash code for KEY for use in hash table H which uses
3839 `eq' to compare keys. The hash code returned is guaranteed to fit
3840 in a Lisp integer. */
3844 struct Lisp_Hash_Table
*h
;
3847 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3848 xassert ((hash
& ~INTMASK
) == 0);
3853 /* Value is a hash code for KEY for use in hash table H which uses
3854 `eql' to compare keys. The hash code returned is guaranteed to fit
3855 in a Lisp integer. */
3859 struct Lisp_Hash_Table
*h
;
3864 hash
= sxhash (key
, 0);
3866 hash
= XUINT (key
) ^ XTYPE (key
);
3867 xassert ((hash
& ~INTMASK
) == 0);
3872 /* Value is a hash code for KEY for use in hash table H which uses
3873 `equal' to compare keys. The hash code returned is guaranteed to fit
3874 in a Lisp integer. */
3877 hashfn_equal (h
, key
)
3878 struct Lisp_Hash_Table
*h
;
3881 unsigned hash
= sxhash (key
, 0);
3882 xassert ((hash
& ~INTMASK
) == 0);
3887 /* Value is a hash code for KEY for use in hash table H which uses as
3888 user-defined function to compare keys. The hash code returned is
3889 guaranteed to fit in a Lisp integer. */
3892 hashfn_user_defined (h
, key
)
3893 struct Lisp_Hash_Table
*h
;
3896 Lisp_Object args
[2], hash
;
3898 args
[0] = h
->user_hash_function
;
3900 hash
= Ffuncall (2, args
);
3901 if (!INTEGERP (hash
))
3902 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3903 return XUINT (hash
);
3907 /* Create and initialize a new hash table.
3909 TEST specifies the test the hash table will use to compare keys.
3910 It must be either one of the predefined tests `eq', `eql' or
3911 `equal' or a symbol denoting a user-defined test named TEST with
3912 test and hash functions USER_TEST and USER_HASH.
3914 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3916 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3917 new size when it becomes full is computed by adding REHASH_SIZE to
3918 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3919 table's new size is computed by multiplying its old size with
3922 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3923 be resized when the ratio of (number of entries in the table) /
3924 (table size) is >= REHASH_THRESHOLD.
3926 WEAK specifies the weakness of the table. If non-nil, it must be
3927 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3930 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3931 user_test
, user_hash
)
3932 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3933 Lisp_Object user_test
, user_hash
;
3935 struct Lisp_Hash_Table
*h
;
3937 int index_size
, i
, sz
;
3939 /* Preconditions. */
3940 xassert (SYMBOLP (test
));
3941 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3942 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3943 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3944 xassert (FLOATP (rehash_threshold
)
3945 && XFLOATINT (rehash_threshold
) > 0
3946 && XFLOATINT (rehash_threshold
) <= 1.0);
3948 if (XFASTINT (size
) == 0)
3949 size
= make_number (1);
3951 /* Allocate a table and initialize it. */
3952 h
= allocate_hash_table ();
3954 /* Initialize hash table slots. */
3955 sz
= XFASTINT (size
);
3958 if (EQ (test
, Qeql
))
3960 h
->cmpfn
= cmpfn_eql
;
3961 h
->hashfn
= hashfn_eql
;
3963 else if (EQ (test
, Qeq
))
3966 h
->hashfn
= hashfn_eq
;
3968 else if (EQ (test
, Qequal
))
3970 h
->cmpfn
= cmpfn_equal
;
3971 h
->hashfn
= hashfn_equal
;
3975 h
->user_cmp_function
= user_test
;
3976 h
->user_hash_function
= user_hash
;
3977 h
->cmpfn
= cmpfn_user_defined
;
3978 h
->hashfn
= hashfn_user_defined
;
3982 h
->rehash_threshold
= rehash_threshold
;
3983 h
->rehash_size
= rehash_size
;
3985 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3986 h
->hash
= Fmake_vector (size
, Qnil
);
3987 h
->next
= Fmake_vector (size
, Qnil
);
3988 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3989 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3990 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3992 /* Set up the free list. */
3993 for (i
= 0; i
< sz
- 1; ++i
)
3994 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3995 h
->next_free
= make_number (0);
3997 XSET_HASH_TABLE (table
, h
);
3998 xassert (HASH_TABLE_P (table
));
3999 xassert (XHASH_TABLE (table
) == h
);
4001 /* Maybe add this hash table to the list of all weak hash tables. */
4003 h
->next_weak
= NULL
;
4006 h
->next_weak
= weak_hash_tables
;
4007 weak_hash_tables
= h
;
4014 /* Return a copy of hash table H1. Keys and values are not copied,
4015 only the table itself is. */
4018 copy_hash_table (h1
)
4019 struct Lisp_Hash_Table
*h1
;
4022 struct Lisp_Hash_Table
*h2
;
4023 struct Lisp_Vector
*next
;
4025 h2
= allocate_hash_table ();
4026 next
= h2
->vec_next
;
4027 bcopy (h1
, h2
, sizeof *h2
);
4028 h2
->vec_next
= next
;
4029 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4030 h2
->hash
= Fcopy_sequence (h1
->hash
);
4031 h2
->next
= Fcopy_sequence (h1
->next
);
4032 h2
->index
= Fcopy_sequence (h1
->index
);
4033 XSET_HASH_TABLE (table
, h2
);
4035 /* Maybe add this hash table to the list of all weak hash tables. */
4036 if (!NILP (h2
->weak
))
4038 h2
->next_weak
= weak_hash_tables
;
4039 weak_hash_tables
= h2
;
4046 /* Resize hash table H if it's too full. If H cannot be resized
4047 because it's already too large, throw an error. */
4050 maybe_resize_hash_table (h
)
4051 struct Lisp_Hash_Table
*h
;
4053 if (NILP (h
->next_free
))
4055 int old_size
= HASH_TABLE_SIZE (h
);
4056 int i
, new_size
, index_size
;
4059 if (INTEGERP (h
->rehash_size
))
4060 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4062 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4063 new_size
= max (old_size
+ 1, new_size
);
4064 index_size
= next_almost_prime ((int)
4066 / XFLOATINT (h
->rehash_threshold
)));
4067 /* Assignment to EMACS_INT stops GCC whining about limited range
4069 nsize
= max (index_size
, 2 * new_size
);
4070 if (nsize
> MOST_POSITIVE_FIXNUM
)
4071 error ("Hash table too large to resize");
4073 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4074 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4075 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4076 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4078 /* Update the free list. Do it so that new entries are added at
4079 the end of the free list. This makes some operations like
4081 for (i
= old_size
; i
< new_size
- 1; ++i
)
4082 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4084 if (!NILP (h
->next_free
))
4086 Lisp_Object last
, next
;
4088 last
= h
->next_free
;
4089 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4093 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4096 XSETFASTINT (h
->next_free
, old_size
);
4099 for (i
= 0; i
< old_size
; ++i
)
4100 if (!NILP (HASH_HASH (h
, i
)))
4102 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4103 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4104 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4105 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4111 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4112 the hash code of KEY. Value is the index of the entry in H
4113 matching KEY, or -1 if not found. */
4116 hash_lookup (h
, key
, hash
)
4117 struct Lisp_Hash_Table
*h
;
4122 int start_of_bucket
;
4125 hash_code
= h
->hashfn (h
, key
);
4129 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4130 idx
= HASH_INDEX (h
, start_of_bucket
);
4132 /* We need not gcpro idx since it's either an integer or nil. */
4135 int i
= XFASTINT (idx
);
4136 if (EQ (key
, HASH_KEY (h
, i
))
4138 && h
->cmpfn (h
, key
, hash_code
,
4139 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4141 idx
= HASH_NEXT (h
, i
);
4144 return NILP (idx
) ? -1 : XFASTINT (idx
);
4148 /* Put an entry into hash table H that associates KEY with VALUE.
4149 HASH is a previously computed hash code of KEY.
4150 Value is the index of the entry in H matching KEY. */
4153 hash_put (h
, key
, value
, hash
)
4154 struct Lisp_Hash_Table
*h
;
4155 Lisp_Object key
, value
;
4158 int start_of_bucket
, i
;
4160 xassert ((hash
& ~INTMASK
) == 0);
4162 /* Increment count after resizing because resizing may fail. */
4163 maybe_resize_hash_table (h
);
4166 /* Store key/value in the key_and_value vector. */
4167 i
= XFASTINT (h
->next_free
);
4168 h
->next_free
= HASH_NEXT (h
, i
);
4169 HASH_KEY (h
, i
) = key
;
4170 HASH_VALUE (h
, i
) = value
;
4172 /* Remember its hash code. */
4173 HASH_HASH (h
, i
) = make_number (hash
);
4175 /* Add new entry to its collision chain. */
4176 start_of_bucket
= hash
% ASIZE (h
->index
);
4177 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4178 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4183 /* Remove the entry matching KEY from hash table H, if there is one. */
4186 hash_remove_from_table (h
, key
)
4187 struct Lisp_Hash_Table
*h
;
4191 int start_of_bucket
;
4192 Lisp_Object idx
, prev
;
4194 hash_code
= h
->hashfn (h
, key
);
4195 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4196 idx
= HASH_INDEX (h
, start_of_bucket
);
4199 /* We need not gcpro idx, prev since they're either integers or nil. */
4202 int i
= XFASTINT (idx
);
4204 if (EQ (key
, HASH_KEY (h
, i
))
4206 && h
->cmpfn (h
, key
, hash_code
,
4207 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4209 /* Take entry out of collision chain. */
4211 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4213 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4215 /* Clear slots in key_and_value and add the slots to
4217 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4218 HASH_NEXT (h
, i
) = h
->next_free
;
4219 h
->next_free
= make_number (i
);
4221 xassert (h
->count
>= 0);
4227 idx
= HASH_NEXT (h
, i
);
4233 /* Clear hash table H. */
4237 struct Lisp_Hash_Table
*h
;
4241 int i
, size
= HASH_TABLE_SIZE (h
);
4243 for (i
= 0; i
< size
; ++i
)
4245 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4246 HASH_KEY (h
, i
) = Qnil
;
4247 HASH_VALUE (h
, i
) = Qnil
;
4248 HASH_HASH (h
, i
) = Qnil
;
4251 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4252 ASET (h
->index
, i
, Qnil
);
4254 h
->next_free
= make_number (0);
4261 /************************************************************************
4263 ************************************************************************/
4266 init_weak_hash_tables ()
4268 weak_hash_tables
= NULL
;
4271 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4272 entries from the table that don't survive the current GC.
4273 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4274 non-zero if anything was marked. */
4277 sweep_weak_table (h
, remove_entries_p
)
4278 struct Lisp_Hash_Table
*h
;
4279 int remove_entries_p
;
4281 int bucket
, n
, marked
;
4283 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4286 for (bucket
= 0; bucket
< n
; ++bucket
)
4288 Lisp_Object idx
, next
, prev
;
4290 /* Follow collision chain, removing entries that
4291 don't survive this garbage collection. */
4293 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4295 int i
= XFASTINT (idx
);
4296 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4297 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4300 if (EQ (h
->weak
, Qkey
))
4301 remove_p
= !key_known_to_survive_p
;
4302 else if (EQ (h
->weak
, Qvalue
))
4303 remove_p
= !value_known_to_survive_p
;
4304 else if (EQ (h
->weak
, Qkey_or_value
))
4305 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4306 else if (EQ (h
->weak
, Qkey_and_value
))
4307 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4311 next
= HASH_NEXT (h
, i
);
4313 if (remove_entries_p
)
4317 /* Take out of collision chain. */
4319 HASH_INDEX (h
, bucket
) = next
;
4321 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4323 /* Add to free list. */
4324 HASH_NEXT (h
, i
) = h
->next_free
;
4327 /* Clear key, value, and hash. */
4328 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4329 HASH_HASH (h
, i
) = Qnil
;
4342 /* Make sure key and value survive. */
4343 if (!key_known_to_survive_p
)
4345 mark_object (HASH_KEY (h
, i
));
4349 if (!value_known_to_survive_p
)
4351 mark_object (HASH_VALUE (h
, i
));
4362 /* Remove elements from weak hash tables that don't survive the
4363 current garbage collection. Remove weak tables that don't survive
4364 from Vweak_hash_tables. Called from gc_sweep. */
4367 sweep_weak_hash_tables ()
4369 struct Lisp_Hash_Table
*h
, *used
, *next
;
4372 /* Mark all keys and values that are in use. Keep on marking until
4373 there is no more change. This is necessary for cases like
4374 value-weak table A containing an entry X -> Y, where Y is used in a
4375 key-weak table B, Z -> Y. If B comes after A in the list of weak
4376 tables, X -> Y might be removed from A, although when looking at B
4377 one finds that it shouldn't. */
4381 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4383 if (h
->size
& ARRAY_MARK_FLAG
)
4384 marked
|= sweep_weak_table (h
, 0);
4389 /* Remove tables and entries that aren't used. */
4390 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4392 next
= h
->next_weak
;
4394 if (h
->size
& ARRAY_MARK_FLAG
)
4396 /* TABLE is marked as used. Sweep its contents. */
4398 sweep_weak_table (h
, 1);
4400 /* Add table to the list of used weak hash tables. */
4401 h
->next_weak
= used
;
4406 weak_hash_tables
= used
;
4411 /***********************************************************************
4412 Hash Code Computation
4413 ***********************************************************************/
4415 /* Maximum depth up to which to dive into Lisp structures. */
4417 #define SXHASH_MAX_DEPTH 3
4419 /* Maximum length up to which to take list and vector elements into
4422 #define SXHASH_MAX_LEN 7
4424 /* Combine two integers X and Y for hashing. */
4426 #define SXHASH_COMBINE(X, Y) \
4427 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4431 /* Return a hash for string PTR which has length LEN. The hash
4432 code returned is guaranteed to fit in a Lisp integer. */
4435 sxhash_string (ptr
, len
)
4439 unsigned char *p
= ptr
;
4440 unsigned char *end
= p
+ len
;
4449 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4452 return hash
& INTMASK
;
4456 /* Return a hash for list LIST. DEPTH is the current depth in the
4457 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4460 sxhash_list (list
, depth
)
4467 if (depth
< SXHASH_MAX_DEPTH
)
4469 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4470 list
= XCDR (list
), ++i
)
4472 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4473 hash
= SXHASH_COMBINE (hash
, hash2
);
4478 unsigned hash2
= sxhash (list
, depth
+ 1);
4479 hash
= SXHASH_COMBINE (hash
, hash2
);
4486 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4487 the Lisp structure. */
4490 sxhash_vector (vec
, depth
)
4494 unsigned hash
= ASIZE (vec
);
4497 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4498 for (i
= 0; i
< n
; ++i
)
4500 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4501 hash
= SXHASH_COMBINE (hash
, hash2
);
4508 /* Return a hash for bool-vector VECTOR. */
4511 sxhash_bool_vector (vec
)
4514 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4517 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4518 for (i
= 0; i
< n
; ++i
)
4519 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4525 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4526 structure. Value is an unsigned integer clipped to INTMASK. */
4535 if (depth
> SXHASH_MAX_DEPTH
)
4538 switch (XTYPE (obj
))
4549 obj
= SYMBOL_NAME (obj
);
4553 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4556 /* This can be everything from a vector to an overlay. */
4557 case Lisp_Vectorlike
:
4559 /* According to the CL HyperSpec, two arrays are equal only if
4560 they are `eq', except for strings and bit-vectors. In
4561 Emacs, this works differently. We have to compare element
4563 hash
= sxhash_vector (obj
, depth
);
4564 else if (BOOL_VECTOR_P (obj
))
4565 hash
= sxhash_bool_vector (obj
);
4567 /* Others are `equal' if they are `eq', so let's take their
4573 hash
= sxhash_list (obj
, depth
);
4578 double val
= XFLOAT_DATA (obj
);
4579 unsigned char *p
= (unsigned char *) &val
;
4580 unsigned char *e
= p
+ sizeof val
;
4581 for (hash
= 0; p
< e
; ++p
)
4582 hash
= SXHASH_COMBINE (hash
, *p
);
4590 return hash
& INTMASK
;
4595 /***********************************************************************
4597 ***********************************************************************/
4600 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4601 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4605 unsigned hash
= sxhash (obj
, 0);
4606 return make_number (hash
);
4610 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4611 doc
: /* Create and return a new hash table.
4613 Arguments are specified as keyword/argument pairs. The following
4614 arguments are defined:
4616 :test TEST -- TEST must be a symbol that specifies how to compare
4617 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4618 `equal'. User-supplied test and hash functions can be specified via
4619 `define-hash-table-test'.
4621 :size SIZE -- A hint as to how many elements will be put in the table.
4624 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4625 fills up. If REHASH-SIZE is an integer, add that many space. If it
4626 is a float, it must be > 1.0, and the new size is computed by
4627 multiplying the old size with that factor. Default is 1.5.
4629 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4630 Resize the hash table when ratio of the number of entries in the
4631 table. Default is 0.8.
4633 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4634 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4635 returned is a weak table. Key/value pairs are removed from a weak
4636 hash table when there are no non-weak references pointing to their
4637 key, value, one of key or value, or both key and value, depending on
4638 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4641 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4646 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4647 Lisp_Object user_test
, user_hash
;
4651 /* The vector `used' is used to keep track of arguments that
4652 have been consumed. */
4653 used
= (char *) alloca (nargs
* sizeof *used
);
4654 bzero (used
, nargs
* sizeof *used
);
4656 /* See if there's a `:test TEST' among the arguments. */
4657 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4658 test
= i
< 0 ? Qeql
: args
[i
];
4659 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4661 /* See if it is a user-defined test. */
4664 prop
= Fget (test
, Qhash_table_test
);
4665 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4666 signal_error ("Invalid hash table test", test
);
4667 user_test
= XCAR (prop
);
4668 user_hash
= XCAR (XCDR (prop
));
4671 user_test
= user_hash
= Qnil
;
4673 /* See if there's a `:size SIZE' argument. */
4674 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4675 size
= i
< 0 ? Qnil
: args
[i
];
4677 size
= make_number (DEFAULT_HASH_SIZE
);
4678 else if (!INTEGERP (size
) || XINT (size
) < 0)
4679 signal_error ("Invalid hash table size", size
);
4681 /* Look for `:rehash-size SIZE'. */
4682 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4683 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4684 if (!NUMBERP (rehash_size
)
4685 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4686 || XFLOATINT (rehash_size
) <= 1.0)
4687 signal_error ("Invalid hash table rehash size", rehash_size
);
4689 /* Look for `:rehash-threshold THRESHOLD'. */
4690 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4691 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4692 if (!FLOATP (rehash_threshold
)
4693 || XFLOATINT (rehash_threshold
) <= 0.0
4694 || XFLOATINT (rehash_threshold
) > 1.0)
4695 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4697 /* Look for `:weakness WEAK'. */
4698 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4699 weak
= i
< 0 ? Qnil
: args
[i
];
4701 weak
= Qkey_and_value
;
4704 && !EQ (weak
, Qvalue
)
4705 && !EQ (weak
, Qkey_or_value
)
4706 && !EQ (weak
, Qkey_and_value
))
4707 signal_error ("Invalid hash table weakness", weak
);
4709 /* Now, all args should have been used up, or there's a problem. */
4710 for (i
= 0; i
< nargs
; ++i
)
4712 signal_error ("Invalid argument list", args
[i
]);
4714 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4715 user_test
, user_hash
);
4719 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4720 doc
: /* Return a copy of hash table TABLE. */)
4724 return copy_hash_table (check_hash_table (table
));
4728 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4729 doc
: /* Return the number of elements in TABLE. */)
4733 return make_number (check_hash_table (table
)->count
);
4737 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4738 Shash_table_rehash_size
, 1, 1, 0,
4739 doc
: /* Return the current rehash size of TABLE. */)
4743 return check_hash_table (table
)->rehash_size
;
4747 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4748 Shash_table_rehash_threshold
, 1, 1, 0,
4749 doc
: /* Return the current rehash threshold of TABLE. */)
4753 return check_hash_table (table
)->rehash_threshold
;
4757 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4758 doc
: /* Return the size of TABLE.
4759 The size can be used as an argument to `make-hash-table' to create
4760 a hash table than can hold as many elements of TABLE holds
4761 without need for resizing. */)
4765 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4766 return make_number (HASH_TABLE_SIZE (h
));
4770 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4771 doc
: /* Return the test TABLE uses. */)
4775 return check_hash_table (table
)->test
;
4779 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4781 doc
: /* Return the weakness of TABLE. */)
4785 return check_hash_table (table
)->weak
;
4789 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4790 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4794 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4798 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4799 doc
: /* Clear hash table TABLE and return it. */)
4803 hash_clear (check_hash_table (table
));
4804 /* Be compatible with XEmacs. */
4809 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4810 doc
: /* Look up KEY in TABLE and return its associated value.
4811 If KEY is not found, return DFLT which defaults to nil. */)
4813 Lisp_Object key
, table
, dflt
;
4815 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4816 int i
= hash_lookup (h
, key
, NULL
);
4817 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4821 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4822 doc
: /* Associate KEY with VALUE in hash table TABLE.
4823 If KEY is already present in table, replace its current value with
4826 Lisp_Object key
, value
, table
;
4828 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4832 i
= hash_lookup (h
, key
, &hash
);
4834 HASH_VALUE (h
, i
) = value
;
4836 hash_put (h
, key
, value
, hash
);
4842 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4843 doc
: /* Remove KEY from TABLE. */)
4845 Lisp_Object key
, table
;
4847 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4848 hash_remove_from_table (h
, key
);
4853 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4854 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4855 FUNCTION is called with two arguments, KEY and VALUE. */)
4857 Lisp_Object function
, table
;
4859 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4860 Lisp_Object args
[3];
4863 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4864 if (!NILP (HASH_HASH (h
, i
)))
4867 args
[1] = HASH_KEY (h
, i
);
4868 args
[2] = HASH_VALUE (h
, i
);
4876 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4877 Sdefine_hash_table_test
, 3, 3, 0,
4878 doc
: /* Define a new hash table test with name NAME, a symbol.
4880 In hash tables created with NAME specified as test, use TEST to
4881 compare keys, and HASH for computing hash codes of keys.
4883 TEST must be a function taking two arguments and returning non-nil if
4884 both arguments are the same. HASH must be a function taking one
4885 argument and return an integer that is the hash code of the argument.
4886 Hash code computation should use the whole value range of integers,
4887 including negative integers. */)
4889 Lisp_Object name
, test
, hash
;
4891 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4896 /************************************************************************
4898 ************************************************************************/
4902 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4903 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4905 A message digest is a cryptographic checksum of a document, and the
4906 algorithm to calculate it is defined in RFC 1321.
4908 The two optional arguments START and END are character positions
4909 specifying for which part of OBJECT the message digest should be
4910 computed. If nil or omitted, the digest is computed for the whole
4913 The MD5 message digest is computed from the result of encoding the
4914 text in a coding system, not directly from the internal Emacs form of
4915 the text. The optional fourth argument CODING-SYSTEM specifies which
4916 coding system to encode the text with. It should be the same coding
4917 system that you used or will use when actually writing the text into a
4920 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4921 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4922 system would be chosen by default for writing this text into a file.
4924 If OBJECT is a string, the most preferred coding system (see the
4925 command `prefer-coding-system') is used.
4927 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4928 guesswork fails. Normally, an error is signaled in such case. */)
4929 (object
, start
, end
, coding_system
, noerror
)
4930 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4932 unsigned char digest
[16];
4933 unsigned char value
[33];
4937 int start_char
= 0, end_char
= 0;
4938 int start_byte
= 0, end_byte
= 0;
4940 register struct buffer
*bp
;
4943 if (STRINGP (object
))
4945 if (NILP (coding_system
))
4947 /* Decide the coding-system to encode the data with. */
4949 if (STRING_MULTIBYTE (object
))
4950 /* use default, we can't guess correct value */
4951 coding_system
= preferred_coding_system ();
4953 coding_system
= Qraw_text
;
4956 if (NILP (Fcoding_system_p (coding_system
)))
4958 /* Invalid coding system. */
4960 if (!NILP (noerror
))
4961 coding_system
= Qraw_text
;
4963 xsignal1 (Qcoding_system_error
, coding_system
);
4966 if (STRING_MULTIBYTE (object
))
4967 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4969 size
= SCHARS (object
);
4970 size_byte
= SBYTES (object
);
4974 CHECK_NUMBER (start
);
4976 start_char
= XINT (start
);
4981 start_byte
= string_char_to_byte (object
, start_char
);
4987 end_byte
= size_byte
;
4993 end_char
= XINT (end
);
4998 end_byte
= string_char_to_byte (object
, end_char
);
5001 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5002 args_out_of_range_3 (object
, make_number (start_char
),
5003 make_number (end_char
));
5007 struct buffer
*prev
= current_buffer
;
5009 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5011 CHECK_BUFFER (object
);
5013 bp
= XBUFFER (object
);
5014 if (bp
!= current_buffer
)
5015 set_buffer_internal (bp
);
5021 CHECK_NUMBER_COERCE_MARKER (start
);
5029 CHECK_NUMBER_COERCE_MARKER (end
);
5034 temp
= b
, b
= e
, e
= temp
;
5036 if (!(BEGV
<= b
&& e
<= ZV
))
5037 args_out_of_range (start
, end
);
5039 if (NILP (coding_system
))
5041 /* Decide the coding-system to encode the data with.
5042 See fileio.c:Fwrite-region */
5044 if (!NILP (Vcoding_system_for_write
))
5045 coding_system
= Vcoding_system_for_write
;
5048 int force_raw_text
= 0;
5050 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5051 if (NILP (coding_system
)
5052 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5054 coding_system
= Qnil
;
5055 if (NILP (current_buffer
->enable_multibyte_characters
))
5059 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5061 /* Check file-coding-system-alist. */
5062 Lisp_Object args
[4], val
;
5064 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5065 args
[3] = Fbuffer_file_name(object
);
5066 val
= Ffind_operation_coding_system (4, args
);
5067 if (CONSP (val
) && !NILP (XCDR (val
)))
5068 coding_system
= XCDR (val
);
5071 if (NILP (coding_system
)
5072 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5074 /* If we still have not decided a coding system, use the
5075 default value of buffer-file-coding-system. */
5076 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5080 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5081 /* Confirm that VAL can surely encode the current region. */
5082 coding_system
= call4 (Vselect_safe_coding_system_function
,
5083 make_number (b
), make_number (e
),
5084 coding_system
, Qnil
);
5087 coding_system
= Qraw_text
;
5090 if (NILP (Fcoding_system_p (coding_system
)))
5092 /* Invalid coding system. */
5094 if (!NILP (noerror
))
5095 coding_system
= Qraw_text
;
5097 xsignal1 (Qcoding_system_error
, coding_system
);
5101 object
= make_buffer_string (b
, e
, 0);
5102 if (prev
!= current_buffer
)
5103 set_buffer_internal (prev
);
5104 /* Discard the unwind protect for recovering the current
5108 if (STRING_MULTIBYTE (object
))
5109 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5112 md5_buffer (SDATA (object
) + start_byte
,
5113 SBYTES (object
) - (size_byte
- end_byte
),
5116 for (i
= 0; i
< 16; i
++)
5117 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5120 return make_string (value
, 32);
5127 /* Hash table stuff. */
5128 Qhash_table_p
= intern_c_string ("hash-table-p");
5129 staticpro (&Qhash_table_p
);
5130 Qeq
= intern_c_string ("eq");
5132 Qeql
= intern_c_string ("eql");
5134 Qequal
= intern_c_string ("equal");
5135 staticpro (&Qequal
);
5136 QCtest
= intern_c_string (":test");
5137 staticpro (&QCtest
);
5138 QCsize
= intern_c_string (":size");
5139 staticpro (&QCsize
);
5140 QCrehash_size
= intern_c_string (":rehash-size");
5141 staticpro (&QCrehash_size
);
5142 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5143 staticpro (&QCrehash_threshold
);
5144 QCweakness
= intern_c_string (":weakness");
5145 staticpro (&QCweakness
);
5146 Qkey
= intern_c_string ("key");
5148 Qvalue
= intern_c_string ("value");
5149 staticpro (&Qvalue
);
5150 Qhash_table_test
= intern_c_string ("hash-table-test");
5151 staticpro (&Qhash_table_test
);
5152 Qkey_or_value
= intern_c_string ("key-or-value");
5153 staticpro (&Qkey_or_value
);
5154 Qkey_and_value
= intern_c_string ("key-and-value");
5155 staticpro (&Qkey_and_value
);
5158 defsubr (&Smake_hash_table
);
5159 defsubr (&Scopy_hash_table
);
5160 defsubr (&Shash_table_count
);
5161 defsubr (&Shash_table_rehash_size
);
5162 defsubr (&Shash_table_rehash_threshold
);
5163 defsubr (&Shash_table_size
);
5164 defsubr (&Shash_table_test
);
5165 defsubr (&Shash_table_weakness
);
5166 defsubr (&Shash_table_p
);
5167 defsubr (&Sclrhash
);
5168 defsubr (&Sgethash
);
5169 defsubr (&Sputhash
);
5170 defsubr (&Sremhash
);
5171 defsubr (&Smaphash
);
5172 defsubr (&Sdefine_hash_table_test
);
5174 Qstring_lessp
= intern_c_string ("string-lessp");
5175 staticpro (&Qstring_lessp
);
5176 Qprovide
= intern_c_string ("provide");
5177 staticpro (&Qprovide
);
5178 Qrequire
= intern_c_string ("require");
5179 staticpro (&Qrequire
);
5180 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5181 staticpro (&Qyes_or_no_p_history
);
5182 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5183 staticpro (&Qcursor_in_echo_area
);
5184 Qwidget_type
= intern_c_string ("widget-type");
5185 staticpro (&Qwidget_type
);
5187 staticpro (&string_char_byte_cache_string
);
5188 string_char_byte_cache_string
= Qnil
;
5190 require_nesting_list
= Qnil
;
5191 staticpro (&require_nesting_list
);
5193 Fset (Qyes_or_no_p_history
, Qnil
);
5195 DEFVAR_LISP ("features", &Vfeatures
,
5196 doc
: /* A list of symbols which are the features of the executing Emacs.
5197 Used by `featurep' and `require', and altered by `provide'. */);
5198 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5199 Qsubfeatures
= intern_c_string ("subfeatures");
5200 staticpro (&Qsubfeatures
);
5202 #ifdef HAVE_LANGINFO_CODESET
5203 Qcodeset
= intern_c_string ("codeset");
5204 staticpro (&Qcodeset
);
5205 Qdays
= intern_c_string ("days");
5207 Qmonths
= intern_c_string ("months");
5208 staticpro (&Qmonths
);
5209 Qpaper
= intern_c_string ("paper");
5210 staticpro (&Qpaper
);
5211 #endif /* HAVE_LANGINFO_CODESET */
5213 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5214 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5215 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5216 invoked by mouse clicks and mouse menu items.
5218 On some platforms, file selection dialogs are also enabled if this is
5222 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5223 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5224 This applies to commands from menus and tool bar buttons even when
5225 they are initiated from the keyboard. If `use-dialog-box' is nil,
5226 that disables the use of a file dialog, regardless of the value of
5228 use_file_dialog
= 1;
5230 defsubr (&Sidentity
);
5233 defsubr (&Ssafe_length
);
5234 defsubr (&Sstring_bytes
);
5235 defsubr (&Sstring_equal
);
5236 defsubr (&Scompare_strings
);
5237 defsubr (&Sstring_lessp
);
5240 defsubr (&Svconcat
);
5241 defsubr (&Scopy_sequence
);
5242 defsubr (&Sstring_make_multibyte
);
5243 defsubr (&Sstring_make_unibyte
);
5244 defsubr (&Sstring_as_multibyte
);
5245 defsubr (&Sstring_as_unibyte
);
5246 defsubr (&Sstring_to_multibyte
);
5247 defsubr (&Sstring_to_unibyte
);
5248 defsubr (&Scopy_alist
);
5249 defsubr (&Ssubstring
);
5250 defsubr (&Ssubstring_no_properties
);
5263 defsubr (&Snreverse
);
5264 defsubr (&Sreverse
);
5266 defsubr (&Splist_get
);
5268 defsubr (&Splist_put
);
5270 defsubr (&Slax_plist_get
);
5271 defsubr (&Slax_plist_put
);
5274 defsubr (&Sequal_including_properties
);
5275 defsubr (&Sfillarray
);
5276 defsubr (&Sclear_string
);
5280 defsubr (&Smapconcat
);
5281 defsubr (&Sy_or_n_p
);
5282 defsubr (&Syes_or_no_p
);
5283 defsubr (&Sload_average
);
5284 defsubr (&Sfeaturep
);
5285 defsubr (&Srequire
);
5286 defsubr (&Sprovide
);
5287 defsubr (&Splist_member
);
5288 defsubr (&Swidget_put
);
5289 defsubr (&Swidget_get
);
5290 defsubr (&Swidget_apply
);
5291 defsubr (&Sbase64_encode_region
);
5292 defsubr (&Sbase64_decode_region
);
5293 defsubr (&Sbase64_encode_string
);
5294 defsubr (&Sbase64_decode_string
);
5296 defsubr (&Slocale_info
);
5305 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5306 (do not change this comment) */