1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 /* Note on some machines this defines `vector' as a typedef,
29 so make sure we don't use that name in this file. */
35 #include "character.h"
40 #include "intervals.h"
43 #include "blockinput.h"
45 #if defined (HAVE_X_WINDOWS)
47 #elif defined (MAC_OS)
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
79 extern long get_random ();
80 extern void seed_random
P_ ((long));
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer 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 c1
= unibyte_char_to_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 c2
= unibyte_char_to_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 elments 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),
608 if (! some_multibyte
)
609 result_len_byte
= result_len
;
611 /* Create the output object. */
612 if (target_type
== Lisp_Cons
)
613 val
= Fmake_list (make_number (result_len
), Qnil
);
614 else if (target_type
== Lisp_Vectorlike
)
615 val
= Fmake_vector (make_number (result_len
), Qnil
);
616 else if (some_multibyte
)
617 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
619 val
= make_uninit_string (result_len
);
621 /* In `append', if all but last arg are nil, return last arg. */
622 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
625 /* Copy the contents of the args into the result. */
627 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
629 toindex
= 0, toindex_byte
= 0;
633 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
635 for (argnum
= 0; argnum
< nargs
; argnum
++)
639 register unsigned int thisindex
= 0;
640 register unsigned int thisindex_byte
= 0;
644 thislen
= Flength (this), thisleni
= XINT (thislen
);
646 /* Between strings of the same kind, copy fast. */
647 if (STRINGP (this) && STRINGP (val
)
648 && STRING_MULTIBYTE (this) == some_multibyte
)
650 int thislen_byte
= SBYTES (this);
652 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
654 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
656 textprops
[num_textprops
].argnum
= argnum
;
657 textprops
[num_textprops
].from
= 0;
658 textprops
[num_textprops
++].to
= toindex
;
660 toindex_byte
+= thislen_byte
;
662 STRING_SET_CHARS (val
, SCHARS (val
));
664 /* Copy a single-byte string to a multibyte string. */
665 else if (STRINGP (this) && STRINGP (val
))
667 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
669 textprops
[num_textprops
].argnum
= argnum
;
670 textprops
[num_textprops
].from
= 0;
671 textprops
[num_textprops
++].to
= toindex
;
673 toindex_byte
+= copy_text (SDATA (this),
674 SDATA (val
) + toindex_byte
,
675 SCHARS (this), 0, 1);
679 /* Copy element by element. */
682 register Lisp_Object elt
;
684 /* Fetch next element of `this' arg into `elt', or break if
685 `this' is exhausted. */
686 if (NILP (this)) break;
688 elt
= XCAR (this), this = XCDR (this);
689 else if (thisindex
>= thisleni
)
691 else if (STRINGP (this))
694 if (STRING_MULTIBYTE (this))
696 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
699 XSETFASTINT (elt
, c
);
703 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
705 && XINT (elt
) >= 0200
706 && XINT (elt
) < 0400)
708 c
= unibyte_char_to_multibyte (XINT (elt
));
713 else if (BOOL_VECTOR_P (this))
716 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
717 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
725 elt
= AREF (this, thisindex
);
729 /* Store this element into the result. */
736 else if (VECTORP (val
))
738 ASET (val
, toindex
, elt
);
745 toindex_byte
+= CHAR_STRING (XINT (elt
),
746 SDATA (val
) + toindex_byte
);
748 SSET (val
, toindex_byte
++, XINT (elt
));
754 XSETCDR (prev
, last_tail
);
756 if (num_textprops
> 0)
759 int last_to_end
= -1;
761 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
763 this = args
[textprops
[argnum
].argnum
];
764 props
= text_property_list (this,
766 make_number (SCHARS (this)),
768 /* If successive arguments have properites, be sure that the
769 value of `composition' property be the copy. */
770 if (last_to_end
== textprops
[argnum
].to
)
771 make_composition_value_copy (props
);
772 add_text_properties_from_list (val
, props
,
773 make_number (textprops
[argnum
].to
));
774 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
782 static Lisp_Object string_char_byte_cache_string
;
783 static EMACS_INT string_char_byte_cache_charpos
;
784 static EMACS_INT string_char_byte_cache_bytepos
;
787 clear_string_char_byte_cache ()
789 string_char_byte_cache_string
= Qnil
;
792 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
795 string_char_to_byte (string
, char_index
)
797 EMACS_INT char_index
;
800 EMACS_INT best_below
, best_below_byte
;
801 EMACS_INT best_above
, best_above_byte
;
803 best_below
= best_below_byte
= 0;
804 best_above
= SCHARS (string
);
805 best_above_byte
= SBYTES (string
);
806 if (best_above
== best_above_byte
)
809 if (EQ (string
, string_char_byte_cache_string
))
811 if (string_char_byte_cache_charpos
< char_index
)
813 best_below
= string_char_byte_cache_charpos
;
814 best_below_byte
= string_char_byte_cache_bytepos
;
818 best_above
= string_char_byte_cache_charpos
;
819 best_above_byte
= string_char_byte_cache_bytepos
;
823 if (char_index
- best_below
< best_above
- char_index
)
825 unsigned char *p
= SDATA (string
) + best_below_byte
;
827 while (best_below
< char_index
)
829 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
838 while (best_above
> char_index
)
841 while (!CHAR_HEAD_P (*p
)) p
--;
844 i_byte
= p
- SDATA (string
);
847 string_char_byte_cache_bytepos
= i_byte
;
848 string_char_byte_cache_charpos
= char_index
;
849 string_char_byte_cache_string
= string
;
854 /* Return the character index corresponding to BYTE_INDEX in STRING. */
857 string_byte_to_char (string
, byte_index
)
859 EMACS_INT byte_index
;
862 EMACS_INT best_below
, best_below_byte
;
863 EMACS_INT best_above
, best_above_byte
;
865 best_below
= best_below_byte
= 0;
866 best_above
= SCHARS (string
);
867 best_above_byte
= SBYTES (string
);
868 if (best_above
== best_above_byte
)
871 if (EQ (string
, string_char_byte_cache_string
))
873 if (string_char_byte_cache_bytepos
< byte_index
)
875 best_below
= string_char_byte_cache_charpos
;
876 best_below_byte
= string_char_byte_cache_bytepos
;
880 best_above
= string_char_byte_cache_charpos
;
881 best_above_byte
= string_char_byte_cache_bytepos
;
885 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
887 unsigned char *p
= SDATA (string
) + best_below_byte
;
888 unsigned char *pend
= SDATA (string
) + byte_index
;
892 p
+= BYTES_BY_CHAR_HEAD (*p
);
896 i_byte
= p
- SDATA (string
);
900 unsigned char *p
= SDATA (string
) + best_above_byte
;
901 unsigned char *pbeg
= SDATA (string
) + byte_index
;
906 while (!CHAR_HEAD_P (*p
)) p
--;
910 i_byte
= p
- SDATA (string
);
913 string_char_byte_cache_bytepos
= i_byte
;
914 string_char_byte_cache_charpos
= i
;
915 string_char_byte_cache_string
= string
;
920 /* Convert STRING to a multibyte string. */
923 string_make_multibyte (string
)
931 if (STRING_MULTIBYTE (string
))
934 nbytes
= count_size_as_multibyte (SDATA (string
),
936 /* If all the chars are ASCII, they won't need any more bytes
937 once converted. In that case, we can return STRING itself. */
938 if (nbytes
== SBYTES (string
))
941 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
942 copy_text (SDATA (string
), buf
, SBYTES (string
),
945 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
952 /* Convert STRING (if unibyte) to a multibyte string without changing
953 the number of characters. Characters 0200 trough 0237 are
954 converted to eight-bit characters. */
957 string_to_multibyte (string
)
965 if (STRING_MULTIBYTE (string
))
968 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
969 /* If all the chars are ASCII, they won't need any more bytes once
971 if (nbytes
== SBYTES (string
))
972 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
974 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
975 bcopy (SDATA (string
), buf
, SBYTES (string
));
976 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
978 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
985 /* Convert STRING to a single-byte string. */
988 string_make_unibyte (string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string (buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 \(When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1025 CHECK_STRING (string
);
1027 return string_make_multibyte (string
);
1030 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1032 doc
: /* Return the unibyte equivalent of STRING.
1033 Multibyte character codes are converted to unibyte according to
1034 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1035 If the lookup in the translation table fails, this function takes just
1036 the low 8 bits of each character. */)
1040 CHECK_STRING (string
);
1042 return string_make_unibyte (string
);
1045 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1047 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1048 If STRING is unibyte, the result is STRING itself.
1049 Otherwise it is a newly created string, with no text properties.
1050 If STRING is multibyte and contains a character of charset
1051 `eight-bit', it is converted to the corresponding single byte. */)
1055 CHECK_STRING (string
);
1057 if (STRING_MULTIBYTE (string
))
1059 int bytes
= SBYTES (string
);
1060 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1062 bcopy (SDATA (string
), str
, bytes
);
1063 bytes
= str_as_unibyte (str
, bytes
);
1064 string
= make_unibyte_string (str
, bytes
);
1070 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1072 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1073 If STRING is multibyte, the result is STRING itself.
1074 Otherwise it is a newly created string, with no text properties.
1076 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1077 part of a correct utf-8 sequence), it is converted to the corresponding
1078 multibyte character of charset `eight-bit'.
1079 See also `string-to-multibyte'.
1081 Beware, this often doesn't really do what you think it does.
1082 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1083 If you're not sure, whether to use `string-as-multibyte' or
1084 `string-to-multibyte', use `string-to-multibyte'. */)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 bcopy (SDATA (string
), SDATA (new_string
),
1101 if (nbytes
!= SBYTES (string
))
1102 str_as_multibyte (SDATA (new_string
), nbytes
,
1103 SBYTES (string
), NULL
);
1104 string
= new_string
;
1105 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1110 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1112 doc
: /* Return a multibyte string with the same individual chars as STRING.
1113 If STRING is multibyte, the result is STRING itself.
1114 Otherwise it is a newly created string, with no text properties.
1116 If STRING is unibyte and contains an 8-bit byte, it is converted to
1117 the corresponding multibyte character of charset `eight-bit'.
1119 This differs from `string-as-multibyte' by converting each byte of a correct
1120 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1121 correct sequence. */)
1125 CHECK_STRING (string
);
1127 return string_to_multibyte (string
);
1130 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1132 doc
: /* Return a unibyte string with the same individual chars as STRING.
1133 If STRING is unibyte, the result is STRING itself.
1134 Otherwise it is a newly created string, with no text properties,
1135 where each `eight-bit' character is converted to the corresponding byte.
1136 If STRING contains a non-ASCII, non-`eight-bit' character,
1137 an error is signaled. */)
1141 CHECK_STRING (string
);
1143 if (STRING_MULTIBYTE (string
))
1145 EMACS_INT chars
= SCHARS (string
);
1146 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1147 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1149 if (converted
< chars
)
1150 error ("Can't convert the %dth character to unibyte", converted
);
1151 string
= make_unibyte_string (str
, chars
);
1158 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1159 doc
: /* Return a copy of ALIST.
1160 This is an alist which represents the same mapping from objects to objects,
1161 but does not share the alist structure with ALIST.
1162 The objects mapped (cars and cdrs of elements of the alist)
1163 are shared, however.
1164 Elements of ALIST that are not conses are also shared. */)
1168 register Lisp_Object tem
;
1173 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1174 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1176 register Lisp_Object car
;
1180 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1185 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1186 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1187 TO may be nil or omitted; then the substring runs to the end of STRING.
1188 FROM and TO start at 0. If either is negative, it counts from the end.
1190 This function allows vectors as well as strings. */)
1193 register Lisp_Object from
, to
;
1198 int from_char
, to_char
;
1199 int from_byte
= 0, to_byte
= 0;
1201 CHECK_VECTOR_OR_STRING (string
);
1202 CHECK_NUMBER (from
);
1204 if (STRINGP (string
))
1206 size
= SCHARS (string
);
1207 size_byte
= SBYTES (string
);
1210 size
= ASIZE (string
);
1215 to_byte
= size_byte
;
1221 to_char
= XINT (to
);
1225 if (STRINGP (string
))
1226 to_byte
= string_char_to_byte (string
, to_char
);
1229 from_char
= XINT (from
);
1232 if (STRINGP (string
))
1233 from_byte
= string_char_to_byte (string
, from_char
);
1235 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1236 args_out_of_range_3 (string
, make_number (from_char
),
1237 make_number (to_char
));
1239 if (STRINGP (string
))
1241 res
= make_specified_string (SDATA (string
) + from_byte
,
1242 to_char
- from_char
, to_byte
- from_byte
,
1243 STRING_MULTIBYTE (string
));
1244 copy_text_properties (make_number (from_char
), make_number (to_char
),
1245 string
, make_number (0), res
, Qnil
);
1248 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1254 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1255 doc
: /* Return a substring of STRING, without text properties.
1256 It starts at index FROM and ending before TO.
1257 TO may be nil or omitted; then the substring runs to the end of STRING.
1258 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1259 If FROM or TO is negative, it counts from the end.
1261 With one argument, just copy STRING without its properties. */)
1264 register Lisp_Object from
, to
;
1266 int size
, size_byte
;
1267 int from_char
, to_char
;
1268 int from_byte
, to_byte
;
1270 CHECK_STRING (string
);
1272 size
= SCHARS (string
);
1273 size_byte
= SBYTES (string
);
1276 from_char
= from_byte
= 0;
1279 CHECK_NUMBER (from
);
1280 from_char
= XINT (from
);
1284 from_byte
= string_char_to_byte (string
, from_char
);
1290 to_byte
= size_byte
;
1296 to_char
= XINT (to
);
1300 to_byte
= string_char_to_byte (string
, to_char
);
1303 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1304 args_out_of_range_3 (string
, make_number (from_char
),
1305 make_number (to_char
));
1307 return make_specified_string (SDATA (string
) + from_byte
,
1308 to_char
- from_char
, to_byte
- from_byte
,
1309 STRING_MULTIBYTE (string
));
1312 /* Extract a substring of STRING, giving start and end positions
1313 both in characters and in bytes. */
1316 substring_both (string
, from
, from_byte
, to
, to_byte
)
1318 int from
, from_byte
, to
, to_byte
;
1324 CHECK_VECTOR_OR_STRING (string
);
1326 if (STRINGP (string
))
1328 size
= SCHARS (string
);
1329 size_byte
= SBYTES (string
);
1332 size
= ASIZE (string
);
1334 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1335 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1337 if (STRINGP (string
))
1339 res
= make_specified_string (SDATA (string
) + from_byte
,
1340 to
- from
, to_byte
- from_byte
,
1341 STRING_MULTIBYTE (string
));
1342 copy_text_properties (make_number (from
), make_number (to
),
1343 string
, make_number (0), res
, Qnil
);
1346 res
= Fvector (to
- from
, &AREF (string
, from
));
1351 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1352 doc
: /* Take cdr N times on LIST, returns the result. */)
1355 register Lisp_Object list
;
1357 register int i
, num
;
1360 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1363 CHECK_LIST_CONS (list
, list
);
1369 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1370 doc
: /* Return the Nth element of LIST.
1371 N counts from zero. If LIST is not that long, nil is returned. */)
1373 Lisp_Object n
, list
;
1375 return Fcar (Fnthcdr (n
, list
));
1378 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1379 doc
: /* Return element of SEQUENCE at index N. */)
1381 register Lisp_Object sequence
, n
;
1384 if (CONSP (sequence
) || NILP (sequence
))
1385 return Fcar (Fnthcdr (n
, sequence
));
1387 /* Faref signals a "not array" error, so check here. */
1388 CHECK_ARRAY (sequence
, Qsequencep
);
1389 return Faref (sequence
, n
);
1392 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1393 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1394 The value is actually the tail of LIST whose car is ELT. */)
1396 register Lisp_Object elt
;
1399 register Lisp_Object tail
;
1400 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1402 register Lisp_Object tem
;
1403 CHECK_LIST_CONS (tail
, list
);
1405 if (! NILP (Fequal (elt
, tem
)))
1412 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1413 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1414 The value is actually the tail of LIST whose car is ELT. */)
1416 register Lisp_Object elt
, list
;
1420 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1424 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1428 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1439 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1440 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1441 The value is actually the tail of LIST whose car is ELT. */)
1443 register Lisp_Object elt
;
1446 register Lisp_Object tail
;
1449 return Fmemq (elt
, list
);
1451 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1453 register Lisp_Object tem
;
1454 CHECK_LIST_CONS (tail
, list
);
1456 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1463 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1464 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1465 The value is actually the first element of LIST whose car is KEY.
1466 Elements of LIST that are not conses are ignored. */)
1468 Lisp_Object key
, list
;
1473 || (CONSP (XCAR (list
))
1474 && EQ (XCAR (XCAR (list
)), key
)))
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCAR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCAR (XCAR (list
)), key
)))
1496 /* Like Fassq but never report an error and do not allow quits.
1497 Use only on lists known never to be circular. */
1500 assq_no_quit (key
, list
)
1501 Lisp_Object key
, list
;
1504 && (!CONSP (XCAR (list
))
1505 || !EQ (XCAR (XCAR (list
)), key
)))
1508 return CAR_SAFE (list
);
1511 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1512 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1513 The value is actually the first element of LIST whose car equals KEY. */)
1515 Lisp_Object key
, list
;
1522 || (CONSP (XCAR (list
))
1523 && (car
= XCAR (XCAR (list
)),
1524 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1529 || (CONSP (XCAR (list
))
1530 && (car
= XCAR (XCAR (list
)),
1531 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1536 || (CONSP (XCAR (list
))
1537 && (car
= XCAR (XCAR (list
)),
1538 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1548 /* Like Fassoc but never report an error and do not allow quits.
1549 Use only on lists known never to be circular. */
1552 assoc_no_quit (key
, list
)
1553 Lisp_Object key
, list
;
1556 && (!CONSP (XCAR (list
))
1557 || (!EQ (XCAR (XCAR (list
)), key
)
1558 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1561 return CONSP (list
) ? XCAR (list
) : Qnil
;
1564 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1565 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1566 The value is actually the first element of LIST whose cdr is KEY. */)
1568 register Lisp_Object key
;
1574 || (CONSP (XCAR (list
))
1575 && EQ (XCDR (XCAR (list
)), key
)))
1580 || (CONSP (XCAR (list
))
1581 && EQ (XCDR (XCAR (list
)), key
)))
1586 || (CONSP (XCAR (list
))
1587 && EQ (XCDR (XCAR (list
)), key
)))
1597 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1598 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1599 The value is actually the first element of LIST whose cdr equals KEY. */)
1601 Lisp_Object key
, list
;
1608 || (CONSP (XCAR (list
))
1609 && (cdr
= XCDR (XCAR (list
)),
1610 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1615 || (CONSP (XCAR (list
))
1616 && (cdr
= XCDR (XCAR (list
)),
1617 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1622 || (CONSP (XCAR (list
))
1623 && (cdr
= XCDR (XCAR (list
)),
1624 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1634 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1635 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1636 The modified LIST is returned. Comparison is done with `eq'.
1637 If the first member of LIST is ELT, there is no way to remove it by side effect;
1638 therefore, write `(setq foo (delq element foo))'
1639 to be sure of changing the value of `foo'. */)
1641 register Lisp_Object elt
;
1644 register Lisp_Object tail
, prev
;
1645 register Lisp_Object tem
;
1649 while (!NILP (tail
))
1651 CHECK_LIST_CONS (tail
, list
);
1658 Fsetcdr (prev
, XCDR (tail
));
1668 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1669 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1670 SEQ must be a list, a vector, or a string.
1671 The modified SEQ is returned. Comparison is done with `equal'.
1672 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1673 is not a side effect; it is simply using a different sequence.
1674 Therefore, write `(setq foo (delete element foo))'
1675 to be sure of changing the value of `foo'. */)
1677 Lisp_Object elt
, seq
;
1683 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1684 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1687 if (n
!= ASIZE (seq
))
1689 struct Lisp_Vector
*p
= allocate_vector (n
);
1691 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1692 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1693 p
->contents
[n
++] = AREF (seq
, i
);
1695 XSETVECTOR (seq
, p
);
1698 else if (STRINGP (seq
))
1700 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1703 for (i
= nchars
= nbytes
= ibyte
= 0;
1705 ++i
, ibyte
+= cbytes
)
1707 if (STRING_MULTIBYTE (seq
))
1709 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1710 SBYTES (seq
) - ibyte
);
1711 cbytes
= CHAR_BYTES (c
);
1719 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1726 if (nchars
!= SCHARS (seq
))
1730 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1731 if (!STRING_MULTIBYTE (seq
))
1732 STRING_SET_UNIBYTE (tem
);
1734 for (i
= nchars
= nbytes
= ibyte
= 0;
1736 ++i
, ibyte
+= cbytes
)
1738 if (STRING_MULTIBYTE (seq
))
1740 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1741 SBYTES (seq
) - ibyte
);
1742 cbytes
= CHAR_BYTES (c
);
1750 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1752 unsigned char *from
= SDATA (seq
) + ibyte
;
1753 unsigned char *to
= SDATA (tem
) + nbytes
;
1759 for (n
= cbytes
; n
--; )
1769 Lisp_Object tail
, prev
;
1771 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1773 CHECK_LIST_CONS (tail
, seq
);
1775 if (!NILP (Fequal (elt
, XCAR (tail
))))
1780 Fsetcdr (prev
, XCDR (tail
));
1791 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1792 doc
: /* Reverse LIST by modifying cdr pointers.
1793 Return the reversed list. */)
1797 register Lisp_Object prev
, tail
, next
;
1799 if (NILP (list
)) return list
;
1802 while (!NILP (tail
))
1805 CHECK_LIST_CONS (tail
, list
);
1807 Fsetcdr (tail
, prev
);
1814 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1815 doc
: /* Reverse LIST, copying. Return the reversed list.
1816 See also the function `nreverse', which is used more often. */)
1822 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1825 new = Fcons (XCAR (list
), new);
1827 CHECK_LIST_END (list
, list
);
1831 Lisp_Object
merge ();
1833 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1834 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1835 Returns the sorted list. LIST is modified by side effects.
1836 PREDICATE is called with two elements of LIST, and should return non-nil
1837 if the first element should sort before the second. */)
1839 Lisp_Object list
, predicate
;
1841 Lisp_Object front
, back
;
1842 register Lisp_Object len
, tem
;
1843 struct gcpro gcpro1
, gcpro2
;
1844 register int length
;
1847 len
= Flength (list
);
1848 length
= XINT (len
);
1852 XSETINT (len
, (length
/ 2) - 1);
1853 tem
= Fnthcdr (len
, list
);
1855 Fsetcdr (tem
, Qnil
);
1857 GCPRO2 (front
, back
);
1858 front
= Fsort (front
, predicate
);
1859 back
= Fsort (back
, predicate
);
1861 return merge (front
, back
, predicate
);
1865 merge (org_l1
, org_l2
, pred
)
1866 Lisp_Object org_l1
, org_l2
;
1870 register Lisp_Object tail
;
1872 register Lisp_Object l1
, l2
;
1873 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1880 /* It is sufficient to protect org_l1 and org_l2.
1881 When l1 and l2 are updated, we copy the new values
1882 back into the org_ vars. */
1883 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1903 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1919 Fsetcdr (tail
, tem
);
1925 #if 0 /* Unsafe version. */
1926 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1927 doc
: /* Extract a value from a property list.
1928 PLIST is a property list, which is a list of the form
1929 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1930 corresponding to the given PROP, or nil if PROP is not
1931 one of the properties on the list. */)
1939 CONSP (tail
) && CONSP (XCDR (tail
));
1940 tail
= XCDR (XCDR (tail
)))
1942 if (EQ (prop
, XCAR (tail
)))
1943 return XCAR (XCDR (tail
));
1945 /* This function can be called asynchronously
1946 (setup_coding_system). Don't QUIT in that case. */
1947 if (!interrupt_input_blocked
)
1951 CHECK_LIST_END (tail
, prop
);
1957 /* This does not check for quits. That is safe since it must terminate. */
1959 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1960 doc
: /* Extract a value from a property list.
1961 PLIST is a property list, which is a list of the form
1962 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1963 corresponding to the given PROP, or nil if PROP is not one of the
1964 properties on the list. This function never signals an error. */)
1969 Lisp_Object tail
, halftail
;
1971 /* halftail is used to detect circular lists. */
1972 tail
= halftail
= plist
;
1973 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1975 if (EQ (prop
, XCAR (tail
)))
1976 return XCAR (XCDR (tail
));
1978 tail
= XCDR (XCDR (tail
));
1979 halftail
= XCDR (halftail
);
1980 if (EQ (tail
, halftail
))
1987 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1988 doc
: /* Return the value of SYMBOL's PROPNAME property.
1989 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1991 Lisp_Object symbol
, propname
;
1993 CHECK_SYMBOL (symbol
);
1994 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1997 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1998 doc
: /* Change value in PLIST of PROP to VAL.
1999 PLIST is a property list, which is a list of the form
2000 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2001 If PROP is already a property on the list, its value is set to VAL,
2002 otherwise the new PROP VAL pair is added. The new plist is returned;
2003 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2004 The PLIST is modified by side effects. */)
2007 register Lisp_Object prop
;
2010 register Lisp_Object tail
, prev
;
2011 Lisp_Object newcell
;
2013 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2014 tail
= XCDR (XCDR (tail
)))
2016 if (EQ (prop
, XCAR (tail
)))
2018 Fsetcar (XCDR (tail
), val
);
2025 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2029 Fsetcdr (XCDR (prev
), newcell
);
2033 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2034 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2035 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2036 (symbol
, propname
, value
)
2037 Lisp_Object symbol
, propname
, value
;
2039 CHECK_SYMBOL (symbol
);
2040 XSYMBOL (symbol
)->plist
2041 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2045 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2046 doc
: /* Extract a value from a property list, comparing with `equal'.
2047 PLIST is a property list, which is a list of the form
2048 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2049 corresponding to the given PROP, or nil if PROP is not
2050 one of the properties on the list. */)
2058 CONSP (tail
) && CONSP (XCDR (tail
));
2059 tail
= XCDR (XCDR (tail
)))
2061 if (! NILP (Fequal (prop
, XCAR (tail
))))
2062 return XCAR (XCDR (tail
));
2067 CHECK_LIST_END (tail
, prop
);
2072 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2073 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2074 PLIST is a property list, which is a list of the form
2075 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2076 If PROP is already a property on the list, its value is set to VAL,
2077 otherwise the new PROP VAL pair is added. The new plist is returned;
2078 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2079 The PLIST is modified by side effects. */)
2082 register Lisp_Object prop
;
2085 register Lisp_Object tail
, prev
;
2086 Lisp_Object newcell
;
2088 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2089 tail
= XCDR (XCDR (tail
)))
2091 if (! NILP (Fequal (prop
, XCAR (tail
))))
2093 Fsetcar (XCDR (tail
), val
);
2100 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2104 Fsetcdr (XCDR (prev
), newcell
);
2108 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2109 doc
: /* Return t if the two args are the same Lisp object.
2110 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2112 Lisp_Object obj1
, obj2
;
2115 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2117 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2120 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2121 doc
: /* Return t if two Lisp objects have similar structure and contents.
2122 They must have the same data type.
2123 Conses are compared by comparing the cars and the cdrs.
2124 Vectors and strings are compared element by element.
2125 Numbers are compared by value, but integers cannot equal floats.
2126 (Use `=' if you want integers and floats to be able to be equal.)
2127 Symbols must match exactly. */)
2129 register Lisp_Object o1
, o2
;
2131 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2134 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2135 doc
: /* Return t if two Lisp objects have similar structure and contents.
2136 This is like `equal' except that it compares the text properties
2137 of strings. (`equal' ignores text properties.) */)
2139 register Lisp_Object o1
, o2
;
2141 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2144 /* DEPTH is current depth of recursion. Signal an error if it
2146 PROPS, if non-nil, means compare string text properties too. */
2149 internal_equal (o1
, o2
, depth
, props
)
2150 register Lisp_Object o1
, o2
;
2154 error ("Stack overflow in equal");
2160 if (XTYPE (o1
) != XTYPE (o2
))
2169 d1
= extract_float (o1
);
2170 d2
= extract_float (o2
);
2171 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2172 though they are not =. */
2173 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2177 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2184 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2188 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2190 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2193 o1
= XOVERLAY (o1
)->plist
;
2194 o2
= XOVERLAY (o2
)->plist
;
2199 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2200 && (XMARKER (o1
)->buffer
== 0
2201 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2205 case Lisp_Vectorlike
:
2208 EMACS_INT size
= ASIZE (o1
);
2209 /* Pseudovectors have the type encoded in the size field, so this test
2210 actually checks that the objects have the same type as well as the
2212 if (ASIZE (o2
) != size
)
2214 /* Boolvectors are compared much like strings. */
2215 if (BOOL_VECTOR_P (o1
))
2218 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2219 / BOOL_VECTOR_BITS_PER_CHAR
);
2221 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2223 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2228 if (WINDOW_CONFIGURATIONP (o1
))
2229 return compare_window_configurations (o1
, o2
, 0);
2231 /* Aside from them, only true vectors, char-tables, compiled
2232 functions, and fonts (font-spec, font-entity, font-ojbect)
2233 are sensible to compare, so eliminate the others now. */
2234 if (size
& PSEUDOVECTOR_FLAG
)
2236 if (!(size
& (PVEC_COMPILED
2237 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2239 size
&= PSEUDOVECTOR_SIZE_MASK
;
2241 for (i
= 0; i
< size
; i
++)
2246 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2254 if (SCHARS (o1
) != SCHARS (o2
))
2256 if (SBYTES (o1
) != SBYTES (o2
))
2258 if (bcmp (SDATA (o1
), SDATA (o2
),
2261 if (props
&& !compare_string_intervals (o1
, o2
))
2267 case Lisp_Type_Limit
:
2274 extern Lisp_Object
Fmake_char_internal ();
2276 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2277 doc
: /* Store each element of ARRAY with ITEM.
2278 ARRAY is a vector, string, char-table, or bool-vector. */)
2280 Lisp_Object array
, item
;
2282 register int size
, index
, charval
;
2283 if (VECTORP (array
))
2285 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2286 size
= ASIZE (array
);
2287 for (index
= 0; index
< size
; index
++)
2290 else if (CHAR_TABLE_P (array
))
2294 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2295 XCHAR_TABLE (array
)->contents
[i
] = item
;
2296 XCHAR_TABLE (array
)->defalt
= item
;
2298 else if (STRINGP (array
))
2300 register unsigned char *p
= SDATA (array
);
2301 CHECK_NUMBER (item
);
2302 charval
= XINT (item
);
2303 size
= SCHARS (array
);
2304 if (STRING_MULTIBYTE (array
))
2306 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2307 int len
= CHAR_STRING (charval
, str
);
2308 int size_byte
= SBYTES (array
);
2309 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2312 if (size
!= size_byte
)
2315 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2316 if (len
!= this_len
)
2317 error ("Attempt to change byte length of a string");
2320 for (i
= 0; i
< size_byte
; i
++)
2321 *p
++ = str
[i
% len
];
2324 for (index
= 0; index
< size
; index
++)
2327 else if (BOOL_VECTOR_P (array
))
2329 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2331 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2332 / BOOL_VECTOR_BITS_PER_CHAR
);
2334 charval
= (! NILP (item
) ? -1 : 0);
2335 for (index
= 0; index
< size_in_chars
- 1; index
++)
2337 if (index
< size_in_chars
)
2339 /* Mask out bits beyond the vector size. */
2340 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2341 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2346 wrong_type_argument (Qarrayp
, array
);
2350 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2352 doc
: /* Clear the contents of STRING.
2353 This makes STRING unibyte and may change its length. */)
2358 CHECK_STRING (string
);
2359 len
= SBYTES (string
);
2360 bzero (SDATA (string
), len
);
2361 STRING_SET_CHARS (string
, len
);
2362 STRING_SET_UNIBYTE (string
);
2372 Lisp_Object args
[2];
2375 return Fnconc (2, args
);
2377 return Fnconc (2, &s1
);
2378 #endif /* NO_ARG_ARRAY */
2381 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2382 doc
: /* Concatenate any number of lists by altering them.
2383 Only the last argument is not altered, and need not be a list.
2384 usage: (nconc &rest LISTS) */)
2389 register int argnum
;
2390 register Lisp_Object tail
, tem
, val
;
2394 for (argnum
= 0; argnum
< nargs
; argnum
++)
2397 if (NILP (tem
)) continue;
2402 if (argnum
+ 1 == nargs
) break;
2404 CHECK_LIST_CONS (tem
, tem
);
2413 tem
= args
[argnum
+ 1];
2414 Fsetcdr (tail
, tem
);
2416 args
[argnum
+ 1] = tail
;
2422 /* This is the guts of all mapping functions.
2423 Apply FN to each element of SEQ, one by one,
2424 storing the results into elements of VALS, a C vector of Lisp_Objects.
2425 LENI is the length of VALS, which should also be the length of SEQ. */
2428 mapcar1 (leni
, vals
, fn
, seq
)
2431 Lisp_Object fn
, seq
;
2433 register Lisp_Object tail
;
2436 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2440 /* Don't let vals contain any garbage when GC happens. */
2441 for (i
= 0; i
< leni
; i
++)
2444 GCPRO3 (dummy
, fn
, seq
);
2446 gcpro1
.nvars
= leni
;
2450 /* We need not explicitly protect `tail' because it is used only on lists, and
2451 1) lists are not relocated and 2) the list is marked via `seq' so will not
2456 for (i
= 0; i
< leni
; i
++)
2458 dummy
= call1 (fn
, AREF (seq
, i
));
2463 else if (BOOL_VECTOR_P (seq
))
2465 for (i
= 0; i
< leni
; i
++)
2468 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2469 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2470 dummy
= call1 (fn
, dummy
);
2475 else if (STRINGP (seq
))
2479 for (i
= 0, i_byte
= 0; i
< leni
;)
2484 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2485 XSETFASTINT (dummy
, c
);
2486 dummy
= call1 (fn
, dummy
);
2488 vals
[i_before
] = dummy
;
2491 else /* Must be a list, since Flength did not get an error */
2494 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2496 dummy
= call1 (fn
, XCAR (tail
));
2506 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2507 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2508 In between each pair of results, stick in SEPARATOR. Thus, " " as
2509 SEPARATOR results in spaces between the values returned by FUNCTION.
2510 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2511 (function
, sequence
, separator
)
2512 Lisp_Object function
, sequence
, separator
;
2517 register Lisp_Object
*args
;
2519 struct gcpro gcpro1
;
2523 len
= Flength (sequence
);
2524 if (CHAR_TABLE_P (sequence
))
2525 wrong_type_argument (Qlistp
, sequence
);
2527 nargs
= leni
+ leni
- 1;
2528 if (nargs
< 0) return empty_unibyte_string
;
2530 SAFE_ALLOCA_LISP (args
, nargs
);
2533 mapcar1 (leni
, args
, function
, sequence
);
2536 for (i
= leni
- 1; i
> 0; i
--)
2537 args
[i
+ i
] = args
[i
];
2539 for (i
= 1; i
< nargs
; i
+= 2)
2540 args
[i
] = separator
;
2542 ret
= Fconcat (nargs
, args
);
2548 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2549 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2550 The result is a list just as long as SEQUENCE.
2551 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2552 (function
, sequence
)
2553 Lisp_Object function
, sequence
;
2555 register Lisp_Object len
;
2557 register Lisp_Object
*args
;
2561 len
= Flength (sequence
);
2562 if (CHAR_TABLE_P (sequence
))
2563 wrong_type_argument (Qlistp
, sequence
);
2564 leni
= XFASTINT (len
);
2566 SAFE_ALLOCA_LISP (args
, leni
);
2568 mapcar1 (leni
, args
, function
, sequence
);
2570 ret
= Flist (leni
, args
);
2576 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2577 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2578 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2579 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2580 (function
, sequence
)
2581 Lisp_Object function
, sequence
;
2585 leni
= XFASTINT (Flength (sequence
));
2586 if (CHAR_TABLE_P (sequence
))
2587 wrong_type_argument (Qlistp
, sequence
);
2588 mapcar1 (leni
, 0, function
, sequence
);
2593 /* Anything that calls this function must protect from GC! */
2595 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2596 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2597 Takes one argument, which is the string to display to ask the question.
2598 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2599 No confirmation of the answer is requested; a single character is enough.
2600 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2601 the bindings in `query-replace-map'; see the documentation of that variable
2602 for more information. In this case, the useful bindings are `act', `skip',
2603 `recenter', and `quit'.\)
2605 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2606 is nil and `use-dialog-box' is non-nil. */)
2610 register Lisp_Object obj
, key
, def
, map
;
2611 register int answer
;
2612 Lisp_Object xprompt
;
2613 Lisp_Object args
[2];
2614 struct gcpro gcpro1
, gcpro2
;
2615 int count
= SPECPDL_INDEX ();
2617 specbind (Qcursor_in_echo_area
, Qt
);
2619 map
= Fsymbol_value (intern ("query-replace-map"));
2621 CHECK_STRING (prompt
);
2623 GCPRO2 (prompt
, xprompt
);
2625 #ifdef HAVE_WINDOW_SYSTEM
2626 if (display_hourglass_p
)
2627 cancel_hourglass ();
2634 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2635 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2639 Lisp_Object pane
, menu
;
2640 redisplay_preserve_echo_area (3);
2641 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2642 Fcons (Fcons (build_string ("No"), Qnil
),
2644 menu
= Fcons (prompt
, pane
);
2645 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2646 answer
= !NILP (obj
);
2649 #endif /* HAVE_MENUS */
2650 cursor_in_echo_area
= 1;
2651 choose_minibuf_frame ();
2654 Lisp_Object pargs
[3];
2656 /* Colorize prompt according to `minibuffer-prompt' face. */
2657 pargs
[0] = build_string ("%s(y or n) ");
2658 pargs
[1] = intern ("face");
2659 pargs
[2] = intern ("minibuffer-prompt");
2660 args
[0] = Fpropertize (3, pargs
);
2665 if (minibuffer_auto_raise
)
2667 Lisp_Object mini_frame
;
2669 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2671 Fraise_frame (mini_frame
);
2674 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2675 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2676 cursor_in_echo_area
= 0;
2677 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2680 key
= Fmake_vector (make_number (1), obj
);
2681 def
= Flookup_key (map
, key
, Qt
);
2683 if (EQ (def
, intern ("skip")))
2688 else if (EQ (def
, intern ("act")))
2693 else if (EQ (def
, intern ("recenter")))
2699 else if (EQ (def
, intern ("quit")))
2701 /* We want to exit this command for exit-prefix,
2702 and this is the only way to do it. */
2703 else if (EQ (def
, intern ("exit-prefix")))
2708 /* If we don't clear this, then the next call to read_char will
2709 return quit_char again, and we'll enter an infinite loop. */
2714 if (EQ (xprompt
, prompt
))
2716 args
[0] = build_string ("Please answer y or n. ");
2718 xprompt
= Fconcat (2, args
);
2723 if (! noninteractive
)
2725 cursor_in_echo_area
= -1;
2726 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2730 unbind_to (count
, Qnil
);
2731 return answer
? Qt
: Qnil
;
2734 /* This is how C code calls `yes-or-no-p' and allows the user
2737 Anything that calls this function must protect from GC! */
2740 do_yes_or_no_p (prompt
)
2743 return call1 (intern ("yes-or-no-p"), prompt
);
2746 /* Anything that calls this function must protect from GC! */
2748 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2749 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2750 Takes one argument, which is the string to display to ask the question.
2751 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2752 The user must confirm the answer with RET,
2753 and can edit it until it has been confirmed.
2755 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2756 is nil, and `use-dialog-box' is non-nil. */)
2760 register Lisp_Object ans
;
2761 Lisp_Object args
[2];
2762 struct gcpro gcpro1
;
2764 CHECK_STRING (prompt
);
2767 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2768 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2772 Lisp_Object pane
, menu
, obj
;
2773 redisplay_preserve_echo_area (4);
2774 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2775 Fcons (Fcons (build_string ("No"), Qnil
),
2778 menu
= Fcons (prompt
, pane
);
2779 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2783 #endif /* HAVE_MENUS */
2786 args
[1] = build_string ("(yes or no) ");
2787 prompt
= Fconcat (2, args
);
2793 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2794 Qyes_or_no_p_history
, Qnil
,
2796 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2801 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2809 message ("Please answer yes or no.");
2810 Fsleep_for (make_number (2), Qnil
);
2814 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2815 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2817 Each of the three load averages is multiplied by 100, then converted
2820 When USE-FLOATS is non-nil, floats will be used instead of integers.
2821 These floats are not multiplied by 100.
2823 If the 5-minute or 15-minute load averages are not available, return a
2824 shortened list, containing only those averages which are available.
2826 An error is thrown if the load average can't be obtained. In some
2827 cases making it work would require Emacs being installed setuid or
2828 setgid so that it can read kernel information, and that usually isn't
2831 Lisp_Object use_floats
;
2834 int loads
= getloadavg (load_ave
, 3);
2835 Lisp_Object ret
= Qnil
;
2838 error ("load-average not implemented for this operating system");
2842 Lisp_Object load
= (NILP (use_floats
) ?
2843 make_number ((int) (100.0 * load_ave
[loads
]))
2844 : make_float (load_ave
[loads
]));
2845 ret
= Fcons (load
, ret
);
2851 Lisp_Object Vfeatures
, Qsubfeatures
;
2852 extern Lisp_Object Vafter_load_alist
;
2854 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2855 doc
: /* Returns t if FEATURE is present in this Emacs.
2857 Use this to conditionalize execution of lisp code based on the
2858 presence or absence of Emacs or environment extensions.
2859 Use `provide' to declare that a feature is available. This function
2860 looks at the value of the variable `features'. The optional argument
2861 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2862 (feature
, subfeature
)
2863 Lisp_Object feature
, subfeature
;
2865 register Lisp_Object tem
;
2866 CHECK_SYMBOL (feature
);
2867 tem
= Fmemq (feature
, Vfeatures
);
2868 if (!NILP (tem
) && !NILP (subfeature
))
2869 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2870 return (NILP (tem
)) ? Qnil
: Qt
;
2873 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2874 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2875 The optional argument SUBFEATURES should be a list of symbols listing
2876 particular subfeatures supported in this version of FEATURE. */)
2877 (feature
, subfeatures
)
2878 Lisp_Object feature
, subfeatures
;
2880 register Lisp_Object tem
;
2881 CHECK_SYMBOL (feature
);
2882 CHECK_LIST (subfeatures
);
2883 if (!NILP (Vautoload_queue
))
2884 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2886 tem
= Fmemq (feature
, Vfeatures
);
2888 Vfeatures
= Fcons (feature
, Vfeatures
);
2889 if (!NILP (subfeatures
))
2890 Fput (feature
, Qsubfeatures
, subfeatures
);
2891 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2893 /* Run any load-hooks for this file. */
2894 tem
= Fassq (feature
, Vafter_load_alist
);
2896 Fprogn (XCDR (tem
));
2901 /* `require' and its subroutines. */
2903 /* List of features currently being require'd, innermost first. */
2905 Lisp_Object require_nesting_list
;
2908 require_unwind (old_value
)
2909 Lisp_Object old_value
;
2911 return require_nesting_list
= old_value
;
2914 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2915 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2916 If FEATURE is not a member of the list `features', then the feature
2917 is not loaded; so load the file FILENAME.
2918 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2919 and `load' will try to load this name appended with the suffix `.elc' or
2920 `.el', in that order. The name without appended suffix will not be used.
2921 If the optional third argument NOERROR is non-nil,
2922 then return nil if the file is not found instead of signaling an error.
2923 Normally the return value is FEATURE.
2924 The normal messages at start and end of loading FILENAME are suppressed. */)
2925 (feature
, filename
, noerror
)
2926 Lisp_Object feature
, filename
, noerror
;
2928 register Lisp_Object tem
;
2929 struct gcpro gcpro1
, gcpro2
;
2930 int from_file
= load_in_progress
;
2932 CHECK_SYMBOL (feature
);
2934 /* Record the presence of `require' in this file
2935 even if the feature specified is already loaded.
2936 But not more than once in any file,
2937 and not when we aren't loading or reading from a file. */
2939 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2940 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2945 tem
= Fcons (Qrequire
, feature
);
2946 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2947 LOADHIST_ATTACH (tem
);
2949 tem
= Fmemq (feature
, Vfeatures
);
2953 int count
= SPECPDL_INDEX ();
2956 /* This is to make sure that loadup.el gives a clear picture
2957 of what files are preloaded and when. */
2958 if (! NILP (Vpurify_flag
))
2959 error ("(require %s) while preparing to dump",
2960 SDATA (SYMBOL_NAME (feature
)));
2962 /* A certain amount of recursive `require' is legitimate,
2963 but if we require the same feature recursively 3 times,
2965 tem
= require_nesting_list
;
2966 while (! NILP (tem
))
2968 if (! NILP (Fequal (feature
, XCAR (tem
))))
2973 error ("Recursive `require' for feature `%s'",
2974 SDATA (SYMBOL_NAME (feature
)));
2976 /* Update the list for any nested `require's that occur. */
2977 record_unwind_protect (require_unwind
, require_nesting_list
);
2978 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2980 /* Value saved here is to be restored into Vautoload_queue */
2981 record_unwind_protect (un_autoload
, Vautoload_queue
);
2982 Vautoload_queue
= Qt
;
2984 /* Load the file. */
2985 GCPRO2 (feature
, filename
);
2986 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2987 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2990 /* If load failed entirely, return nil. */
2992 return unbind_to (count
, Qnil
);
2994 tem
= Fmemq (feature
, Vfeatures
);
2996 error ("Required feature `%s' was not provided",
2997 SDATA (SYMBOL_NAME (feature
)));
2999 /* Once loading finishes, don't undo it. */
3000 Vautoload_queue
= Qt
;
3001 feature
= unbind_to (count
, feature
);
3007 /* Primitives for work of the "widget" library.
3008 In an ideal world, this section would not have been necessary.
3009 However, lisp function calls being as slow as they are, it turns
3010 out that some functions in the widget library (wid-edit.el) are the
3011 bottleneck of Widget operation. Here is their translation to C,
3012 for the sole reason of efficiency. */
3014 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3015 doc
: /* Return non-nil if PLIST has the property PROP.
3016 PLIST is a property list, which is a list of the form
3017 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3018 Unlike `plist-get', this allows you to distinguish between a missing
3019 property and a property with the value nil.
3020 The value is actually the tail of PLIST whose car is PROP. */)
3022 Lisp_Object plist
, prop
;
3024 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3027 plist
= XCDR (plist
);
3028 plist
= CDR (plist
);
3033 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3034 doc
: /* In WIDGET, set PROPERTY to VALUE.
3035 The value can later be retrieved with `widget-get'. */)
3036 (widget
, property
, value
)
3037 Lisp_Object widget
, property
, value
;
3039 CHECK_CONS (widget
);
3040 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3044 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3045 doc
: /* In WIDGET, get the value of PROPERTY.
3046 The value could either be specified when the widget was created, or
3047 later with `widget-put'. */)
3049 Lisp_Object widget
, property
;
3057 CHECK_CONS (widget
);
3058 tmp
= Fplist_member (XCDR (widget
), property
);
3064 tmp
= XCAR (widget
);
3067 widget
= Fget (tmp
, Qwidget_type
);
3071 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3072 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3073 ARGS are passed as extra arguments to the function.
3074 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3079 /* This function can GC. */
3080 Lisp_Object newargs
[3];
3081 struct gcpro gcpro1
, gcpro2
;
3084 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3085 newargs
[1] = args
[0];
3086 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3087 GCPRO2 (newargs
[0], newargs
[2]);
3088 result
= Fapply (3, newargs
);
3093 #ifdef HAVE_LANGINFO_CODESET
3094 #include <langinfo.h>
3097 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3098 doc
: /* Access locale data ITEM for the current C locale, if available.
3099 ITEM should be one of the following:
3101 `codeset', returning the character set as a string (locale item CODESET);
3103 `days', returning a 7-element vector of day names (locale items DAY_n);
3105 `months', returning a 12-element vector of month names (locale items MON_n);
3107 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3108 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3110 If the system can't provide such information through a call to
3111 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3113 See also Info node `(libc)Locales'.
3115 The data read from the system are decoded using `locale-coding-system'. */)
3120 #ifdef HAVE_LANGINFO_CODESET
3122 if (EQ (item
, Qcodeset
))
3124 str
= nl_langinfo (CODESET
);
3125 return build_string (str
);
3128 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3130 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3131 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3133 synchronize_system_time_locale ();
3134 for (i
= 0; i
< 7; i
++)
3136 str
= nl_langinfo (days
[i
]);
3137 val
= make_unibyte_string (str
, strlen (str
));
3138 /* Fixme: Is this coding system necessarily right, even if
3139 it is consistent with CODESET? If not, what to do? */
3140 Faset (v
, make_number (i
),
3141 code_convert_string_norecord (val
, Vlocale_coding_system
,
3148 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3150 struct Lisp_Vector
*p
= allocate_vector (12);
3151 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3152 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3154 synchronize_system_time_locale ();
3155 for (i
= 0; i
< 12; i
++)
3157 str
= nl_langinfo (months
[i
]);
3158 val
= make_unibyte_string (str
, strlen (str
));
3160 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3162 XSETVECTOR (val
, p
);
3166 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3167 but is in the locale files. This could be used by ps-print. */
3169 else if (EQ (item
, Qpaper
))
3171 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3172 make_number (nl_langinfo (PAPER_HEIGHT
)));
3174 #endif /* PAPER_WIDTH */
3175 #endif /* HAVE_LANGINFO_CODESET*/
3179 /* base64 encode/decode functions (RFC 2045).
3180 Based on code from GNU recode. */
3182 #define MIME_LINE_LENGTH 76
3184 #define IS_ASCII(Character) \
3186 #define IS_BASE64(Character) \
3187 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3188 #define IS_BASE64_IGNORABLE(Character) \
3189 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3190 || (Character) == '\f' || (Character) == '\r')
3192 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3193 character or return retval if there are no characters left to
3195 #define READ_QUADRUPLET_BYTE(retval) \
3200 if (nchars_return) \
3201 *nchars_return = nchars; \
3206 while (IS_BASE64_IGNORABLE (c))
3208 /* Table of characters coding the 64 values. */
3209 static char base64_value_to_char
[64] =
3211 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3212 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3213 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3214 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3215 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3216 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3217 '8', '9', '+', '/' /* 60-63 */
3220 /* Table of base64 values for first 128 characters. */
3221 static short base64_char_to_value
[128] =
3223 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3224 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3225 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3226 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3227 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3228 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3229 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3230 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3231 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3232 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3233 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3234 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3235 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3238 /* The following diagram shows the logical steps by which three octets
3239 get transformed into four base64 characters.
3241 .--------. .--------. .--------.
3242 |aaaaaabb| |bbbbcccc| |ccdddddd|
3243 `--------' `--------' `--------'
3245 .--------+--------+--------+--------.
3246 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3247 `--------+--------+--------+--------'
3249 .--------+--------+--------+--------.
3250 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3251 `--------+--------+--------+--------'
3253 The octets are divided into 6 bit chunks, which are then encoded into
3254 base64 characters. */
3257 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3258 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3260 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3262 doc
: /* Base64-encode the region between BEG and END.
3263 Return the length of the encoded text.
3264 Optional third argument NO-LINE-BREAK means do not break long lines
3265 into shorter lines. */)
3266 (beg
, end
, no_line_break
)
3267 Lisp_Object beg
, end
, no_line_break
;
3270 int allength
, length
;
3271 int ibeg
, iend
, encoded_length
;
3275 validate_region (&beg
, &end
);
3277 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3278 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3279 move_gap_both (XFASTINT (beg
), ibeg
);
3281 /* We need to allocate enough room for encoding the text.
3282 We need 33 1/3% more space, plus a newline every 76
3283 characters, and then we round up. */
3284 length
= iend
- ibeg
;
3285 allength
= length
+ length
/3 + 1;
3286 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3288 SAFE_ALLOCA (encoded
, char *, allength
);
3289 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3290 NILP (no_line_break
),
3291 !NILP (current_buffer
->enable_multibyte_characters
));
3292 if (encoded_length
> allength
)
3295 if (encoded_length
< 0)
3297 /* The encoding wasn't possible. */
3299 error ("Multibyte character in data for base64 encoding");
3302 /* Now we have encoded the region, so we insert the new contents
3303 and delete the old. (Insert first in order to preserve markers.) */
3304 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3305 insert (encoded
, encoded_length
);
3307 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3309 /* If point was outside of the region, restore it exactly; else just
3310 move to the beginning of the region. */
3311 if (old_pos
>= XFASTINT (end
))
3312 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3313 else if (old_pos
> XFASTINT (beg
))
3314 old_pos
= XFASTINT (beg
);
3317 /* We return the length of the encoded text. */
3318 return make_number (encoded_length
);
3321 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3323 doc
: /* Base64-encode STRING and return the result.
3324 Optional second argument NO-LINE-BREAK means do not break long lines
3325 into shorter lines. */)
3326 (string
, no_line_break
)
3327 Lisp_Object string
, no_line_break
;
3329 int allength
, length
, encoded_length
;
3331 Lisp_Object encoded_string
;
3334 CHECK_STRING (string
);
3336 /* We need to allocate enough room for encoding the text.
3337 We need 33 1/3% more space, plus a newline every 76
3338 characters, and then we round up. */
3339 length
= SBYTES (string
);
3340 allength
= length
+ length
/3 + 1;
3341 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3343 /* We need to allocate enough room for decoding the text. */
3344 SAFE_ALLOCA (encoded
, char *, allength
);
3346 encoded_length
= base64_encode_1 (SDATA (string
),
3347 encoded
, length
, NILP (no_line_break
),
3348 STRING_MULTIBYTE (string
));
3349 if (encoded_length
> allength
)
3352 if (encoded_length
< 0)
3354 /* The encoding wasn't possible. */
3356 error ("Multibyte character in data for base64 encoding");
3359 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3362 return encoded_string
;
3366 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3373 int counter
= 0, i
= 0;
3383 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3384 if (CHAR_BYTE8_P (c
))
3385 c
= CHAR_TO_BYTE8 (c
);
3393 /* Wrap line every 76 characters. */
3397 if (counter
< MIME_LINE_LENGTH
/ 4)
3406 /* Process first byte of a triplet. */
3408 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3409 value
= (0x03 & c
) << 4;
3411 /* Process second byte of a triplet. */
3415 *e
++ = base64_value_to_char
[value
];
3423 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3424 if (CHAR_BYTE8_P (c
))
3425 c
= CHAR_TO_BYTE8 (c
);
3433 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3434 value
= (0x0f & c
) << 2;
3436 /* Process third byte of a triplet. */
3440 *e
++ = base64_value_to_char
[value
];
3447 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3448 if (CHAR_BYTE8_P (c
))
3449 c
= CHAR_TO_BYTE8 (c
);
3457 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3458 *e
++ = base64_value_to_char
[0x3f & c
];
3465 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3467 doc
: /* Base64-decode the region between BEG and END.
3468 Return the length of the decoded text.
3469 If the region can't be decoded, signal an error and don't modify the buffer. */)
3471 Lisp_Object beg
, end
;
3473 int ibeg
, iend
, length
, allength
;
3478 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3481 validate_region (&beg
, &end
);
3483 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3484 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3486 length
= iend
- ibeg
;
3488 /* We need to allocate enough room for decoding the text. If we are
3489 working on a multibyte buffer, each decoded code may occupy at
3491 allength
= multibyte
? length
* 2 : length
;
3492 SAFE_ALLOCA (decoded
, char *, allength
);
3494 move_gap_both (XFASTINT (beg
), ibeg
);
3495 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3496 multibyte
, &inserted_chars
);
3497 if (decoded_length
> allength
)
3500 if (decoded_length
< 0)
3502 /* The decoding wasn't possible. */
3504 error ("Invalid base64 data");
3507 /* Now we have decoded the region, so we insert the new contents
3508 and delete the old. (Insert first in order to preserve markers.) */
3509 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3510 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3513 /* Delete the original text. */
3514 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3515 iend
+ decoded_length
, 1);
3517 /* If point was outside of the region, restore it exactly; else just
3518 move to the beginning of the region. */
3519 if (old_pos
>= XFASTINT (end
))
3520 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3521 else if (old_pos
> XFASTINT (beg
))
3522 old_pos
= XFASTINT (beg
);
3523 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3525 return make_number (inserted_chars
);
3528 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3530 doc
: /* Base64-decode STRING and return the result. */)
3535 int length
, decoded_length
;
3536 Lisp_Object decoded_string
;
3539 CHECK_STRING (string
);
3541 length
= SBYTES (string
);
3542 /* We need to allocate enough room for decoding the text. */
3543 SAFE_ALLOCA (decoded
, char *, length
);
3545 /* The decoded result should be unibyte. */
3546 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3548 if (decoded_length
> length
)
3550 else if (decoded_length
>= 0)
3551 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3553 decoded_string
= Qnil
;
3556 if (!STRINGP (decoded_string
))
3557 error ("Invalid base64 data");
3559 return decoded_string
;
3562 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3563 MULTIBYTE is nonzero, the decoded result should be in multibyte
3564 form. If NCHARS_RETRUN is not NULL, store the number of produced
3565 characters in *NCHARS_RETURN. */
3568 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3578 unsigned long value
;
3583 /* Process first byte of a quadruplet. */
3585 READ_QUADRUPLET_BYTE (e
-to
);
3589 value
= base64_char_to_value
[c
] << 18;
3591 /* Process second byte of a quadruplet. */
3593 READ_QUADRUPLET_BYTE (-1);
3597 value
|= base64_char_to_value
[c
] << 12;
3599 c
= (unsigned char) (value
>> 16);
3600 if (multibyte
&& c
>= 128)
3601 e
+= BYTE8_STRING (c
, e
);
3606 /* Process third byte of a quadruplet. */
3608 READ_QUADRUPLET_BYTE (-1);
3612 READ_QUADRUPLET_BYTE (-1);
3621 value
|= base64_char_to_value
[c
] << 6;
3623 c
= (unsigned char) (0xff & value
>> 8);
3624 if (multibyte
&& c
>= 128)
3625 e
+= BYTE8_STRING (c
, e
);
3630 /* Process fourth byte of a quadruplet. */
3632 READ_QUADRUPLET_BYTE (-1);
3639 value
|= base64_char_to_value
[c
];
3641 c
= (unsigned char) (0xff & value
);
3642 if (multibyte
&& c
>= 128)
3643 e
+= BYTE8_STRING (c
, e
);
3652 /***********************************************************************
3654 ***** Hash Tables *****
3656 ***********************************************************************/
3658 /* Implemented by gerd@gnu.org. This hash table implementation was
3659 inspired by CMUCL hash tables. */
3663 1. For small tables, association lists are probably faster than
3664 hash tables because they have lower overhead.
3666 For uses of hash tables where the O(1) behavior of table
3667 operations is not a requirement, it might therefore be a good idea
3668 not to hash. Instead, we could just do a linear search in the
3669 key_and_value vector of the hash table. This could be done
3670 if a `:linear-search t' argument is given to make-hash-table. */
3673 /* The list of all weak hash tables. Don't staticpro this one. */
3675 struct Lisp_Hash_Table
*weak_hash_tables
;
3677 /* Various symbols. */
3679 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3680 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3681 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3683 /* Function prototypes. */
3685 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3686 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3687 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3688 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3689 Lisp_Object
, unsigned));
3690 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3691 Lisp_Object
, unsigned));
3692 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3693 unsigned, Lisp_Object
, unsigned));
3694 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3695 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3696 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3697 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3699 static unsigned sxhash_string
P_ ((unsigned char *, int));
3700 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3701 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3702 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3703 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3707 /***********************************************************************
3709 ***********************************************************************/
3711 /* If OBJ is a Lisp hash table, return a pointer to its struct
3712 Lisp_Hash_Table. Otherwise, signal an error. */
3714 static struct Lisp_Hash_Table
*
3715 check_hash_table (obj
)
3718 CHECK_HASH_TABLE (obj
);
3719 return XHASH_TABLE (obj
);
3723 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3727 next_almost_prime (n
)
3740 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3741 which USED[I] is non-zero. If found at index I in ARGS, set
3742 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3743 -1. This function is used to extract a keyword/argument pair from
3744 a DEFUN parameter list. */
3747 get_key_arg (key
, nargs
, args
, used
)
3755 for (i
= 0; i
< nargs
- 1; ++i
)
3756 if (!used
[i
] && EQ (args
[i
], key
))
3771 /* Return a Lisp vector which has the same contents as VEC but has
3772 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3773 vector that are not copied from VEC are set to INIT. */
3776 larger_vector (vec
, new_size
, init
)
3781 struct Lisp_Vector
*v
;
3784 xassert (VECTORP (vec
));
3785 old_size
= ASIZE (vec
);
3786 xassert (new_size
>= old_size
);
3788 v
= allocate_vector (new_size
);
3789 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3790 old_size
* sizeof *v
->contents
);
3791 for (i
= old_size
; i
< new_size
; ++i
)
3792 v
->contents
[i
] = init
;
3793 XSETVECTOR (vec
, v
);
3798 /***********************************************************************
3800 ***********************************************************************/
3802 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3803 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3804 KEY2 are the same. */
3807 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3808 struct Lisp_Hash_Table
*h
;
3809 Lisp_Object key1
, key2
;
3810 unsigned hash1
, hash2
;
3812 return (FLOATP (key1
)
3814 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3818 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3819 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3820 KEY2 are the same. */
3823 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3824 struct Lisp_Hash_Table
*h
;
3825 Lisp_Object key1
, key2
;
3826 unsigned hash1
, hash2
;
3828 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3832 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3833 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3834 if KEY1 and KEY2 are the same. */
3837 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3838 struct Lisp_Hash_Table
*h
;
3839 Lisp_Object key1
, key2
;
3840 unsigned hash1
, hash2
;
3844 Lisp_Object args
[3];
3846 args
[0] = h
->user_cmp_function
;
3849 return !NILP (Ffuncall (3, args
));
3856 /* Value is a hash code for KEY for use in hash table H which uses
3857 `eq' to compare keys. The hash code returned is guaranteed to fit
3858 in a Lisp integer. */
3862 struct Lisp_Hash_Table
*h
;
3865 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3866 xassert ((hash
& ~INTMASK
) == 0);
3871 /* Value is a hash code for KEY for use in hash table H which uses
3872 `eql' to compare keys. The hash code returned is guaranteed to fit
3873 in a Lisp integer. */
3877 struct Lisp_Hash_Table
*h
;
3882 hash
= sxhash (key
, 0);
3884 hash
= XUINT (key
) ^ XTYPE (key
);
3885 xassert ((hash
& ~INTMASK
) == 0);
3890 /* Value is a hash code for KEY for use in hash table H which uses
3891 `equal' to compare keys. The hash code returned is guaranteed to fit
3892 in a Lisp integer. */
3895 hashfn_equal (h
, key
)
3896 struct Lisp_Hash_Table
*h
;
3899 unsigned hash
= sxhash (key
, 0);
3900 xassert ((hash
& ~INTMASK
) == 0);
3905 /* Value is a hash code for KEY for use in hash table H which uses as
3906 user-defined function to compare keys. The hash code returned is
3907 guaranteed to fit in a Lisp integer. */
3910 hashfn_user_defined (h
, key
)
3911 struct Lisp_Hash_Table
*h
;
3914 Lisp_Object args
[2], hash
;
3916 args
[0] = h
->user_hash_function
;
3918 hash
= Ffuncall (2, args
);
3919 if (!INTEGERP (hash
))
3920 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3921 return XUINT (hash
);
3925 /* Create and initialize a new hash table.
3927 TEST specifies the test the hash table will use to compare keys.
3928 It must be either one of the predefined tests `eq', `eql' or
3929 `equal' or a symbol denoting a user-defined test named TEST with
3930 test and hash functions USER_TEST and USER_HASH.
3932 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3934 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3935 new size when it becomes full is computed by adding REHASH_SIZE to
3936 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3937 table's new size is computed by multiplying its old size with
3940 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3941 be resized when the ratio of (number of entries in the table) /
3942 (table size) is >= REHASH_THRESHOLD.
3944 WEAK specifies the weakness of the table. If non-nil, it must be
3945 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3948 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3949 user_test
, user_hash
)
3950 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3951 Lisp_Object user_test
, user_hash
;
3953 struct Lisp_Hash_Table
*h
;
3955 int index_size
, i
, sz
;
3957 /* Preconditions. */
3958 xassert (SYMBOLP (test
));
3959 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3960 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3961 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3962 xassert (FLOATP (rehash_threshold
)
3963 && XFLOATINT (rehash_threshold
) > 0
3964 && XFLOATINT (rehash_threshold
) <= 1.0);
3966 if (XFASTINT (size
) == 0)
3967 size
= make_number (1);
3969 /* Allocate a table and initialize it. */
3970 h
= allocate_hash_table ();
3972 /* Initialize hash table slots. */
3973 sz
= XFASTINT (size
);
3976 if (EQ (test
, Qeql
))
3978 h
->cmpfn
= cmpfn_eql
;
3979 h
->hashfn
= hashfn_eql
;
3981 else if (EQ (test
, Qeq
))
3984 h
->hashfn
= hashfn_eq
;
3986 else if (EQ (test
, Qequal
))
3988 h
->cmpfn
= cmpfn_equal
;
3989 h
->hashfn
= hashfn_equal
;
3993 h
->user_cmp_function
= user_test
;
3994 h
->user_hash_function
= user_hash
;
3995 h
->cmpfn
= cmpfn_user_defined
;
3996 h
->hashfn
= hashfn_user_defined
;
4000 h
->rehash_threshold
= rehash_threshold
;
4001 h
->rehash_size
= rehash_size
;
4003 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4004 h
->hash
= Fmake_vector (size
, Qnil
);
4005 h
->next
= Fmake_vector (size
, Qnil
);
4006 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4007 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4008 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4010 /* Set up the free list. */
4011 for (i
= 0; i
< sz
- 1; ++i
)
4012 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4013 h
->next_free
= make_number (0);
4015 XSET_HASH_TABLE (table
, h
);
4016 xassert (HASH_TABLE_P (table
));
4017 xassert (XHASH_TABLE (table
) == h
);
4019 /* Maybe add this hash table to the list of all weak hash tables. */
4021 h
->next_weak
= NULL
;
4024 h
->next_weak
= weak_hash_tables
;
4025 weak_hash_tables
= h
;
4032 /* Return a copy of hash table H1. Keys and values are not copied,
4033 only the table itself is. */
4036 copy_hash_table (h1
)
4037 struct Lisp_Hash_Table
*h1
;
4040 struct Lisp_Hash_Table
*h2
;
4041 struct Lisp_Vector
*next
;
4043 h2
= allocate_hash_table ();
4044 next
= h2
->vec_next
;
4045 bcopy (h1
, h2
, sizeof *h2
);
4046 h2
->vec_next
= next
;
4047 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4048 h2
->hash
= Fcopy_sequence (h1
->hash
);
4049 h2
->next
= Fcopy_sequence (h1
->next
);
4050 h2
->index
= Fcopy_sequence (h1
->index
);
4051 XSET_HASH_TABLE (table
, h2
);
4053 /* Maybe add this hash table to the list of all weak hash tables. */
4054 if (!NILP (h2
->weak
))
4056 h2
->next_weak
= weak_hash_tables
;
4057 weak_hash_tables
= h2
;
4064 /* Resize hash table H if it's too full. If H cannot be resized
4065 because it's already too large, throw an error. */
4068 maybe_resize_hash_table (h
)
4069 struct Lisp_Hash_Table
*h
;
4071 if (NILP (h
->next_free
))
4073 int old_size
= HASH_TABLE_SIZE (h
);
4074 int i
, new_size
, index_size
;
4077 if (INTEGERP (h
->rehash_size
))
4078 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4080 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4081 new_size
= max (old_size
+ 1, new_size
);
4082 index_size
= next_almost_prime ((int)
4084 / XFLOATINT (h
->rehash_threshold
)));
4085 /* Assignment to EMACS_INT stops GCC whining about limited range
4087 nsize
= max (index_size
, 2 * new_size
);
4088 if (nsize
> MOST_POSITIVE_FIXNUM
)
4089 error ("Hash table too large to resize");
4091 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4092 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4093 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4094 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4096 /* Update the free list. Do it so that new entries are added at
4097 the end of the free list. This makes some operations like
4099 for (i
= old_size
; i
< new_size
- 1; ++i
)
4100 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4102 if (!NILP (h
->next_free
))
4104 Lisp_Object last
, next
;
4106 last
= h
->next_free
;
4107 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4111 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4114 XSETFASTINT (h
->next_free
, old_size
);
4117 for (i
= 0; i
< old_size
; ++i
)
4118 if (!NILP (HASH_HASH (h
, i
)))
4120 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4121 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4122 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4123 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4129 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4130 the hash code of KEY. Value is the index of the entry in H
4131 matching KEY, or -1 if not found. */
4134 hash_lookup (h
, key
, hash
)
4135 struct Lisp_Hash_Table
*h
;
4140 int start_of_bucket
;
4143 hash_code
= h
->hashfn (h
, key
);
4147 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4148 idx
= HASH_INDEX (h
, start_of_bucket
);
4150 /* We need not gcpro idx since it's either an integer or nil. */
4153 int i
= XFASTINT (idx
);
4154 if (EQ (key
, HASH_KEY (h
, i
))
4156 && h
->cmpfn (h
, key
, hash_code
,
4157 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4159 idx
= HASH_NEXT (h
, i
);
4162 return NILP (idx
) ? -1 : XFASTINT (idx
);
4166 /* Put an entry into hash table H that associates KEY with VALUE.
4167 HASH is a previously computed hash code of KEY.
4168 Value is the index of the entry in H matching KEY. */
4171 hash_put (h
, key
, value
, hash
)
4172 struct Lisp_Hash_Table
*h
;
4173 Lisp_Object key
, value
;
4176 int start_of_bucket
, i
;
4178 xassert ((hash
& ~INTMASK
) == 0);
4180 /* Increment count after resizing because resizing may fail. */
4181 maybe_resize_hash_table (h
);
4184 /* Store key/value in the key_and_value vector. */
4185 i
= XFASTINT (h
->next_free
);
4186 h
->next_free
= HASH_NEXT (h
, i
);
4187 HASH_KEY (h
, i
) = key
;
4188 HASH_VALUE (h
, i
) = value
;
4190 /* Remember its hash code. */
4191 HASH_HASH (h
, i
) = make_number (hash
);
4193 /* Add new entry to its collision chain. */
4194 start_of_bucket
= hash
% ASIZE (h
->index
);
4195 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4196 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4201 /* Remove the entry matching KEY from hash table H, if there is one. */
4204 hash_remove_from_table (h
, key
)
4205 struct Lisp_Hash_Table
*h
;
4209 int start_of_bucket
;
4210 Lisp_Object idx
, prev
;
4212 hash_code
= h
->hashfn (h
, key
);
4213 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4214 idx
= HASH_INDEX (h
, start_of_bucket
);
4217 /* We need not gcpro idx, prev since they're either integers or nil. */
4220 int i
= XFASTINT (idx
);
4222 if (EQ (key
, HASH_KEY (h
, i
))
4224 && h
->cmpfn (h
, key
, hash_code
,
4225 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4227 /* Take entry out of collision chain. */
4229 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4231 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4233 /* Clear slots in key_and_value and add the slots to
4235 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4236 HASH_NEXT (h
, i
) = h
->next_free
;
4237 h
->next_free
= make_number (i
);
4239 xassert (h
->count
>= 0);
4245 idx
= HASH_NEXT (h
, i
);
4251 /* Clear hash table H. */
4255 struct Lisp_Hash_Table
*h
;
4259 int i
, size
= HASH_TABLE_SIZE (h
);
4261 for (i
= 0; i
< size
; ++i
)
4263 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4264 HASH_KEY (h
, i
) = Qnil
;
4265 HASH_VALUE (h
, i
) = Qnil
;
4266 HASH_HASH (h
, i
) = Qnil
;
4269 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4270 ASET (h
->index
, i
, Qnil
);
4272 h
->next_free
= make_number (0);
4279 /************************************************************************
4281 ************************************************************************/
4284 init_weak_hash_tables ()
4286 weak_hash_tables
= NULL
;
4289 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4290 entries from the table that don't survive the current GC.
4291 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4292 non-zero if anything was marked. */
4295 sweep_weak_table (h
, remove_entries_p
)
4296 struct Lisp_Hash_Table
*h
;
4297 int remove_entries_p
;
4299 int bucket
, n
, marked
;
4301 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4304 for (bucket
= 0; bucket
< n
; ++bucket
)
4306 Lisp_Object idx
, next
, prev
;
4308 /* Follow collision chain, removing entries that
4309 don't survive this garbage collection. */
4311 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4313 int i
= XFASTINT (idx
);
4314 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4315 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4318 if (EQ (h
->weak
, Qkey
))
4319 remove_p
= !key_known_to_survive_p
;
4320 else if (EQ (h
->weak
, Qvalue
))
4321 remove_p
= !value_known_to_survive_p
;
4322 else if (EQ (h
->weak
, Qkey_or_value
))
4323 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4324 else if (EQ (h
->weak
, Qkey_and_value
))
4325 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4329 next
= HASH_NEXT (h
, i
);
4331 if (remove_entries_p
)
4335 /* Take out of collision chain. */
4337 HASH_INDEX (h
, bucket
) = next
;
4339 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4341 /* Add to free list. */
4342 HASH_NEXT (h
, i
) = h
->next_free
;
4345 /* Clear key, value, and hash. */
4346 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4347 HASH_HASH (h
, i
) = Qnil
;
4360 /* Make sure key and value survive. */
4361 if (!key_known_to_survive_p
)
4363 mark_object (HASH_KEY (h
, i
));
4367 if (!value_known_to_survive_p
)
4369 mark_object (HASH_VALUE (h
, i
));
4380 /* Remove elements from weak hash tables that don't survive the
4381 current garbage collection. Remove weak tables that don't survive
4382 from Vweak_hash_tables. Called from gc_sweep. */
4385 sweep_weak_hash_tables ()
4387 struct Lisp_Hash_Table
*h
, *used
, *next
;
4390 /* Mark all keys and values that are in use. Keep on marking until
4391 there is no more change. This is necessary for cases like
4392 value-weak table A containing an entry X -> Y, where Y is used in a
4393 key-weak table B, Z -> Y. If B comes after A in the list of weak
4394 tables, X -> Y might be removed from A, although when looking at B
4395 one finds that it shouldn't. */
4399 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4401 if (h
->size
& ARRAY_MARK_FLAG
)
4402 marked
|= sweep_weak_table (h
, 0);
4407 /* Remove tables and entries that aren't used. */
4408 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4410 next
= h
->next_weak
;
4412 if (h
->size
& ARRAY_MARK_FLAG
)
4414 /* TABLE is marked as used. Sweep its contents. */
4416 sweep_weak_table (h
, 1);
4418 /* Add table to the list of used weak hash tables. */
4419 h
->next_weak
= used
;
4424 weak_hash_tables
= used
;
4429 /***********************************************************************
4430 Hash Code Computation
4431 ***********************************************************************/
4433 /* Maximum depth up to which to dive into Lisp structures. */
4435 #define SXHASH_MAX_DEPTH 3
4437 /* Maximum length up to which to take list and vector elements into
4440 #define SXHASH_MAX_LEN 7
4442 /* Combine two integers X and Y for hashing. */
4444 #define SXHASH_COMBINE(X, Y) \
4445 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4449 /* Return a hash for string PTR which has length LEN. The hash
4450 code returned is guaranteed to fit in a Lisp integer. */
4453 sxhash_string (ptr
, len
)
4457 unsigned char *p
= ptr
;
4458 unsigned char *end
= p
+ len
;
4467 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4470 return hash
& INTMASK
;
4474 /* Return a hash for list LIST. DEPTH is the current depth in the
4475 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4478 sxhash_list (list
, depth
)
4485 if (depth
< SXHASH_MAX_DEPTH
)
4487 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4488 list
= XCDR (list
), ++i
)
4490 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4491 hash
= SXHASH_COMBINE (hash
, hash2
);
4496 unsigned hash2
= sxhash (list
, depth
+ 1);
4497 hash
= SXHASH_COMBINE (hash
, hash2
);
4504 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4505 the Lisp structure. */
4508 sxhash_vector (vec
, depth
)
4512 unsigned hash
= ASIZE (vec
);
4515 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4516 for (i
= 0; i
< n
; ++i
)
4518 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4519 hash
= SXHASH_COMBINE (hash
, hash2
);
4526 /* Return a hash for bool-vector VECTOR. */
4529 sxhash_bool_vector (vec
)
4532 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4535 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4536 for (i
= 0; i
< n
; ++i
)
4537 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4543 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4544 structure. Value is an unsigned integer clipped to INTMASK. */
4553 if (depth
> SXHASH_MAX_DEPTH
)
4556 switch (XTYPE (obj
))
4567 obj
= SYMBOL_NAME (obj
);
4571 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4574 /* This can be everything from a vector to an overlay. */
4575 case Lisp_Vectorlike
:
4577 /* According to the CL HyperSpec, two arrays are equal only if
4578 they are `eq', except for strings and bit-vectors. In
4579 Emacs, this works differently. We have to compare element
4581 hash
= sxhash_vector (obj
, depth
);
4582 else if (BOOL_VECTOR_P (obj
))
4583 hash
= sxhash_bool_vector (obj
);
4585 /* Others are `equal' if they are `eq', so let's take their
4591 hash
= sxhash_list (obj
, depth
);
4596 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4597 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4598 for (hash
= 0; p
< e
; ++p
)
4599 hash
= SXHASH_COMBINE (hash
, *p
);
4607 return hash
& INTMASK
;
4612 /***********************************************************************
4614 ***********************************************************************/
4617 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4618 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4622 unsigned hash
= sxhash (obj
, 0);
4623 return make_number (hash
);
4627 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4628 doc
: /* Create and return a new hash table.
4630 Arguments are specified as keyword/argument pairs. The following
4631 arguments are defined:
4633 :test TEST -- TEST must be a symbol that specifies how to compare
4634 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4635 `equal'. User-supplied test and hash functions can be specified via
4636 `define-hash-table-test'.
4638 :size SIZE -- A hint as to how many elements will be put in the table.
4641 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4642 fills up. If REHASH-SIZE is an integer, add that many space. If it
4643 is a float, it must be > 1.0, and the new size is computed by
4644 multiplying the old size with that factor. Default is 1.5.
4646 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4647 Resize the hash table when ratio of the number of entries in the
4648 table. Default is 0.8.
4650 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4651 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4652 returned is a weak table. Key/value pairs are removed from a weak
4653 hash table when there are no non-weak references pointing to their
4654 key, value, one of key or value, or both key and value, depending on
4655 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4658 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4663 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4664 Lisp_Object user_test
, user_hash
;
4668 /* The vector `used' is used to keep track of arguments that
4669 have been consumed. */
4670 used
= (char *) alloca (nargs
* sizeof *used
);
4671 bzero (used
, nargs
* sizeof *used
);
4673 /* See if there's a `:test TEST' among the arguments. */
4674 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4675 test
= i
< 0 ? Qeql
: args
[i
];
4676 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4678 /* See if it is a user-defined test. */
4681 prop
= Fget (test
, Qhash_table_test
);
4682 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4683 signal_error ("Invalid hash table test", test
);
4684 user_test
= XCAR (prop
);
4685 user_hash
= XCAR (XCDR (prop
));
4688 user_test
= user_hash
= Qnil
;
4690 /* See if there's a `:size SIZE' argument. */
4691 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4692 size
= i
< 0 ? Qnil
: args
[i
];
4694 size
= make_number (DEFAULT_HASH_SIZE
);
4695 else if (!INTEGERP (size
) || XINT (size
) < 0)
4696 signal_error ("Invalid hash table size", size
);
4698 /* Look for `:rehash-size SIZE'. */
4699 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4700 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4701 if (!NUMBERP (rehash_size
)
4702 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4703 || XFLOATINT (rehash_size
) <= 1.0)
4704 signal_error ("Invalid hash table rehash size", rehash_size
);
4706 /* Look for `:rehash-threshold THRESHOLD'. */
4707 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4708 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4709 if (!FLOATP (rehash_threshold
)
4710 || XFLOATINT (rehash_threshold
) <= 0.0
4711 || XFLOATINT (rehash_threshold
) > 1.0)
4712 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4714 /* Look for `:weakness WEAK'. */
4715 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4716 weak
= i
< 0 ? Qnil
: args
[i
];
4718 weak
= Qkey_and_value
;
4721 && !EQ (weak
, Qvalue
)
4722 && !EQ (weak
, Qkey_or_value
)
4723 && !EQ (weak
, Qkey_and_value
))
4724 signal_error ("Invalid hash table weakness", weak
);
4726 /* Now, all args should have been used up, or there's a problem. */
4727 for (i
= 0; i
< nargs
; ++i
)
4729 signal_error ("Invalid argument list", args
[i
]);
4731 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4732 user_test
, user_hash
);
4736 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4737 doc
: /* Return a copy of hash table TABLE. */)
4741 return copy_hash_table (check_hash_table (table
));
4745 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4746 doc
: /* Return the number of elements in TABLE. */)
4750 return make_number (check_hash_table (table
)->count
);
4754 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4755 Shash_table_rehash_size
, 1, 1, 0,
4756 doc
: /* Return the current rehash size of TABLE. */)
4760 return check_hash_table (table
)->rehash_size
;
4764 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4765 Shash_table_rehash_threshold
, 1, 1, 0,
4766 doc
: /* Return the current rehash threshold of TABLE. */)
4770 return check_hash_table (table
)->rehash_threshold
;
4774 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4775 doc
: /* Return the size of TABLE.
4776 The size can be used as an argument to `make-hash-table' to create
4777 a hash table than can hold as many elements of TABLE holds
4778 without need for resizing. */)
4782 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4783 return make_number (HASH_TABLE_SIZE (h
));
4787 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4788 doc
: /* Return the test TABLE uses. */)
4792 return check_hash_table (table
)->test
;
4796 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4798 doc
: /* Return the weakness of TABLE. */)
4802 return check_hash_table (table
)->weak
;
4806 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4807 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4811 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4815 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4816 doc
: /* Clear hash table TABLE and return it. */)
4820 hash_clear (check_hash_table (table
));
4821 /* Be compatible with XEmacs. */
4826 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4827 doc
: /* Look up KEY in TABLE and return its associated value.
4828 If KEY is not found, return DFLT which defaults to nil. */)
4830 Lisp_Object key
, table
, dflt
;
4832 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4833 int i
= hash_lookup (h
, key
, NULL
);
4834 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4838 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4839 doc
: /* Associate KEY with VALUE in hash table TABLE.
4840 If KEY is already present in table, replace its current value with
4843 Lisp_Object key
, value
, table
;
4845 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4849 i
= hash_lookup (h
, key
, &hash
);
4851 HASH_VALUE (h
, i
) = value
;
4853 hash_put (h
, key
, value
, hash
);
4859 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4860 doc
: /* Remove KEY from TABLE. */)
4862 Lisp_Object key
, table
;
4864 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4865 hash_remove_from_table (h
, key
);
4870 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4871 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4872 FUNCTION is called with two arguments, KEY and VALUE. */)
4874 Lisp_Object function
, table
;
4876 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4877 Lisp_Object args
[3];
4880 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4881 if (!NILP (HASH_HASH (h
, i
)))
4884 args
[1] = HASH_KEY (h
, i
);
4885 args
[2] = HASH_VALUE (h
, i
);
4893 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4894 Sdefine_hash_table_test
, 3, 3, 0,
4895 doc
: /* Define a new hash table test with name NAME, a symbol.
4897 In hash tables created with NAME specified as test, use TEST to
4898 compare keys, and HASH for computing hash codes of keys.
4900 TEST must be a function taking two arguments and returning non-nil if
4901 both arguments are the same. HASH must be a function taking one
4902 argument and return an integer that is the hash code of the argument.
4903 Hash code computation should use the whole value range of integers,
4904 including negative integers. */)
4906 Lisp_Object name
, test
, hash
;
4908 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4913 /************************************************************************
4915 ************************************************************************/
4919 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4920 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4922 A message digest is a cryptographic checksum of a document, and the
4923 algorithm to calculate it is defined in RFC 1321.
4925 The two optional arguments START and END are character positions
4926 specifying for which part of OBJECT the message digest should be
4927 computed. If nil or omitted, the digest is computed for the whole
4930 The MD5 message digest is computed from the result of encoding the
4931 text in a coding system, not directly from the internal Emacs form of
4932 the text. The optional fourth argument CODING-SYSTEM specifies which
4933 coding system to encode the text with. It should be the same coding
4934 system that you used or will use when actually writing the text into a
4937 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4938 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4939 system would be chosen by default for writing this text into a file.
4941 If OBJECT is a string, the most preferred coding system (see the
4942 command `prefer-coding-system') is used.
4944 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4945 guesswork fails. Normally, an error is signaled in such case. */)
4946 (object
, start
, end
, coding_system
, noerror
)
4947 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4949 unsigned char digest
[16];
4950 unsigned char value
[33];
4954 int start_char
= 0, end_char
= 0;
4955 int start_byte
= 0, end_byte
= 0;
4957 register struct buffer
*bp
;
4960 if (STRINGP (object
))
4962 if (NILP (coding_system
))
4964 /* Decide the coding-system to encode the data with. */
4966 if (STRING_MULTIBYTE (object
))
4967 /* use default, we can't guess correct value */
4968 coding_system
= preferred_coding_system ();
4970 coding_system
= Qraw_text
;
4973 if (NILP (Fcoding_system_p (coding_system
)))
4975 /* Invalid coding system. */
4977 if (!NILP (noerror
))
4978 coding_system
= Qraw_text
;
4980 xsignal1 (Qcoding_system_error
, coding_system
);
4983 if (STRING_MULTIBYTE (object
))
4984 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4986 size
= SCHARS (object
);
4987 size_byte
= SBYTES (object
);
4991 CHECK_NUMBER (start
);
4993 start_char
= XINT (start
);
4998 start_byte
= string_char_to_byte (object
, start_char
);
5004 end_byte
= size_byte
;
5010 end_char
= XINT (end
);
5015 end_byte
= string_char_to_byte (object
, end_char
);
5018 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5019 args_out_of_range_3 (object
, make_number (start_char
),
5020 make_number (end_char
));
5024 struct buffer
*prev
= current_buffer
;
5026 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5028 CHECK_BUFFER (object
);
5030 bp
= XBUFFER (object
);
5031 if (bp
!= current_buffer
)
5032 set_buffer_internal (bp
);
5038 CHECK_NUMBER_COERCE_MARKER (start
);
5046 CHECK_NUMBER_COERCE_MARKER (end
);
5051 temp
= b
, b
= e
, e
= temp
;
5053 if (!(BEGV
<= b
&& e
<= ZV
))
5054 args_out_of_range (start
, end
);
5056 if (NILP (coding_system
))
5058 /* Decide the coding-system to encode the data with.
5059 See fileio.c:Fwrite-region */
5061 if (!NILP (Vcoding_system_for_write
))
5062 coding_system
= Vcoding_system_for_write
;
5065 int force_raw_text
= 0;
5067 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5068 if (NILP (coding_system
)
5069 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5071 coding_system
= Qnil
;
5072 if (NILP (current_buffer
->enable_multibyte_characters
))
5076 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5078 /* Check file-coding-system-alist. */
5079 Lisp_Object args
[4], val
;
5081 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5082 args
[3] = Fbuffer_file_name(object
);
5083 val
= Ffind_operation_coding_system (4, args
);
5084 if (CONSP (val
) && !NILP (XCDR (val
)))
5085 coding_system
= XCDR (val
);
5088 if (NILP (coding_system
)
5089 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5091 /* If we still have not decided a coding system, use the
5092 default value of buffer-file-coding-system. */
5093 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5097 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5098 /* Confirm that VAL can surely encode the current region. */
5099 coding_system
= call4 (Vselect_safe_coding_system_function
,
5100 make_number (b
), make_number (e
),
5101 coding_system
, Qnil
);
5104 coding_system
= Qraw_text
;
5107 if (NILP (Fcoding_system_p (coding_system
)))
5109 /* Invalid coding system. */
5111 if (!NILP (noerror
))
5112 coding_system
= Qraw_text
;
5114 xsignal1 (Qcoding_system_error
, coding_system
);
5118 object
= make_buffer_string (b
, e
, 0);
5119 if (prev
!= current_buffer
)
5120 set_buffer_internal (prev
);
5121 /* Discard the unwind protect for recovering the current
5125 if (STRING_MULTIBYTE (object
))
5126 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5129 md5_buffer (SDATA (object
) + start_byte
,
5130 SBYTES (object
) - (size_byte
- end_byte
),
5133 for (i
= 0; i
< 16; i
++)
5134 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5137 return make_string (value
, 32);
5144 /* Hash table stuff. */
5145 Qhash_table_p
= intern ("hash-table-p");
5146 staticpro (&Qhash_table_p
);
5147 Qeq
= intern ("eq");
5149 Qeql
= intern ("eql");
5151 Qequal
= intern ("equal");
5152 staticpro (&Qequal
);
5153 QCtest
= intern (":test");
5154 staticpro (&QCtest
);
5155 QCsize
= intern (":size");
5156 staticpro (&QCsize
);
5157 QCrehash_size
= intern (":rehash-size");
5158 staticpro (&QCrehash_size
);
5159 QCrehash_threshold
= intern (":rehash-threshold");
5160 staticpro (&QCrehash_threshold
);
5161 QCweakness
= intern (":weakness");
5162 staticpro (&QCweakness
);
5163 Qkey
= intern ("key");
5165 Qvalue
= intern ("value");
5166 staticpro (&Qvalue
);
5167 Qhash_table_test
= intern ("hash-table-test");
5168 staticpro (&Qhash_table_test
);
5169 Qkey_or_value
= intern ("key-or-value");
5170 staticpro (&Qkey_or_value
);
5171 Qkey_and_value
= intern ("key-and-value");
5172 staticpro (&Qkey_and_value
);
5175 defsubr (&Smake_hash_table
);
5176 defsubr (&Scopy_hash_table
);
5177 defsubr (&Shash_table_count
);
5178 defsubr (&Shash_table_rehash_size
);
5179 defsubr (&Shash_table_rehash_threshold
);
5180 defsubr (&Shash_table_size
);
5181 defsubr (&Shash_table_test
);
5182 defsubr (&Shash_table_weakness
);
5183 defsubr (&Shash_table_p
);
5184 defsubr (&Sclrhash
);
5185 defsubr (&Sgethash
);
5186 defsubr (&Sputhash
);
5187 defsubr (&Sremhash
);
5188 defsubr (&Smaphash
);
5189 defsubr (&Sdefine_hash_table_test
);
5191 Qstring_lessp
= intern ("string-lessp");
5192 staticpro (&Qstring_lessp
);
5193 Qprovide
= intern ("provide");
5194 staticpro (&Qprovide
);
5195 Qrequire
= intern ("require");
5196 staticpro (&Qrequire
);
5197 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5198 staticpro (&Qyes_or_no_p_history
);
5199 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5200 staticpro (&Qcursor_in_echo_area
);
5201 Qwidget_type
= intern ("widget-type");
5202 staticpro (&Qwidget_type
);
5204 staticpro (&string_char_byte_cache_string
);
5205 string_char_byte_cache_string
= Qnil
;
5207 require_nesting_list
= Qnil
;
5208 staticpro (&require_nesting_list
);
5210 Fset (Qyes_or_no_p_history
, Qnil
);
5212 DEFVAR_LISP ("features", &Vfeatures
,
5213 doc
: /* A list of symbols which are the features of the executing Emacs.
5214 Used by `featurep' and `require', and altered by `provide'. */);
5215 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5216 Qsubfeatures
= intern ("subfeatures");
5217 staticpro (&Qsubfeatures
);
5219 #ifdef HAVE_LANGINFO_CODESET
5220 Qcodeset
= intern ("codeset");
5221 staticpro (&Qcodeset
);
5222 Qdays
= intern ("days");
5224 Qmonths
= intern ("months");
5225 staticpro (&Qmonths
);
5226 Qpaper
= intern ("paper");
5227 staticpro (&Qpaper
);
5228 #endif /* HAVE_LANGINFO_CODESET */
5230 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5231 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5232 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5233 invoked by mouse clicks and mouse menu items.
5235 On some platforms, file selection dialogs are also enabled if this is
5239 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5240 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5241 This applies to commands from menus and tool bar buttons even when
5242 they are initiated from the keyboard. The value of `use-dialog-box'
5243 takes precedence over this variable, so a file dialog is only used if
5244 both `use-dialog-box' and this variable are non-nil. */);
5245 use_file_dialog
= 1;
5247 defsubr (&Sidentity
);
5250 defsubr (&Ssafe_length
);
5251 defsubr (&Sstring_bytes
);
5252 defsubr (&Sstring_equal
);
5253 defsubr (&Scompare_strings
);
5254 defsubr (&Sstring_lessp
);
5257 defsubr (&Svconcat
);
5258 defsubr (&Scopy_sequence
);
5259 defsubr (&Sstring_make_multibyte
);
5260 defsubr (&Sstring_make_unibyte
);
5261 defsubr (&Sstring_as_multibyte
);
5262 defsubr (&Sstring_as_unibyte
);
5263 defsubr (&Sstring_to_multibyte
);
5264 defsubr (&Sstring_to_unibyte
);
5265 defsubr (&Scopy_alist
);
5266 defsubr (&Ssubstring
);
5267 defsubr (&Ssubstring_no_properties
);
5280 defsubr (&Snreverse
);
5281 defsubr (&Sreverse
);
5283 defsubr (&Splist_get
);
5285 defsubr (&Splist_put
);
5287 defsubr (&Slax_plist_get
);
5288 defsubr (&Slax_plist_put
);
5291 defsubr (&Sequal_including_properties
);
5292 defsubr (&Sfillarray
);
5293 defsubr (&Sclear_string
);
5297 defsubr (&Smapconcat
);
5298 defsubr (&Sy_or_n_p
);
5299 defsubr (&Syes_or_no_p
);
5300 defsubr (&Sload_average
);
5301 defsubr (&Sfeaturep
);
5302 defsubr (&Srequire
);
5303 defsubr (&Sprovide
);
5304 defsubr (&Splist_member
);
5305 defsubr (&Swidget_put
);
5306 defsubr (&Swidget_get
);
5307 defsubr (&Swidget_apply
);
5308 defsubr (&Sbase64_encode_region
);
5309 defsubr (&Sbase64_decode_region
);
5310 defsubr (&Sbase64_encode_string
);
5311 defsubr (&Sbase64_decode_string
);
5313 defsubr (&Slocale_info
);
5322 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5323 (do not change this comment) */