1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
79 extern long get_random (void);
80 extern void seed_random (long);
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
93 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
94 doc
: /* Return a pseudo-random number.
95 All integers representable in Lisp are equally likely.
96 On most systems, this is 29 bits' worth.
97 With positive integer LIMIT, return random number in interval [0,LIMIT).
98 With argument t, set the random number seed from the current time and pid.
99 Other values of LIMIT are ignored. */)
103 Lisp_Object lispy_val
;
104 unsigned long denominator
;
107 seed_random (getpid () + time (NULL
));
108 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
110 /* Try to take our random number from the higher bits of VAL,
111 not the lower, since (says Gentzel) the low bits of `random'
112 are less random than the higher ones. We do this by using the
113 quotient rather than the remainder. At the high end of the RNG
114 it's possible to get a quotient larger than n; discarding
115 these values eliminates the bias that would otherwise appear
116 when using a large n. */
117 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
119 val
= get_random () / denominator
;
120 while (val
>= XFASTINT (limit
));
124 XSETINT (lispy_val
, val
);
128 /* Random data-structure functions */
130 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
131 doc
: /* Return the length of vector, list or string SEQUENCE.
132 A byte-code function object is also allowed.
133 If the string contains multibyte characters, this is not necessarily
134 the number of bytes in the string; it is the number of characters.
135 To get the number of bytes, use `string-bytes'. */)
136 (register Lisp_Object sequence
)
138 register Lisp_Object val
;
141 if (STRINGP (sequence
))
142 XSETFASTINT (val
, SCHARS (sequence
));
143 else if (VECTORP (sequence
))
144 XSETFASTINT (val
, ASIZE (sequence
));
145 else if (CHAR_TABLE_P (sequence
))
146 XSETFASTINT (val
, MAX_CHAR
);
147 else if (BOOL_VECTOR_P (sequence
))
148 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
149 else if (COMPILEDP (sequence
))
150 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
151 else if (CONSP (sequence
))
154 while (CONSP (sequence
))
156 sequence
= XCDR (sequence
);
159 if (!CONSP (sequence
))
162 sequence
= XCDR (sequence
);
167 CHECK_LIST_END (sequence
, sequence
);
169 val
= make_number (i
);
171 else if (NILP (sequence
))
172 XSETFASTINT (val
, 0);
174 wrong_type_argument (Qsequencep
, sequence
);
179 /* This does not check for quits. That is safe since it must terminate. */
181 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
182 doc
: /* Return the length of a list, but avoid error or infinite loop.
183 This function never gets an error. If LIST is not really a list,
184 it returns 0. If LIST is circular, it returns a finite value
185 which is at least the number of distinct elements. */)
188 Lisp_Object tail
, halftail
, length
;
191 /* halftail is used to detect circular lists. */
193 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
195 if (EQ (tail
, halftail
) && len
!= 0)
199 halftail
= XCDR (halftail
);
202 XSETINT (length
, len
);
206 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
207 doc
: /* Return the number of bytes in STRING.
208 If STRING is multibyte, this may be greater than the length of STRING. */)
211 CHECK_STRING (string
);
212 return make_number (SBYTES (string
));
215 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
216 doc
: /* Return t if two strings have identical contents.
217 Case is significant, but text properties are ignored.
218 Symbols are also allowed; their print names are used instead. */)
219 (register Lisp_Object s1
, Lisp_Object s2
)
222 s1
= SYMBOL_NAME (s1
);
224 s2
= SYMBOL_NAME (s2
);
228 if (SCHARS (s1
) != SCHARS (s2
)
229 || SBYTES (s1
) != SBYTES (s2
)
230 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
235 DEFUN ("compare-strings", Fcompare_strings
,
236 Scompare_strings
, 6, 7, 0,
237 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
238 In string STR1, skip the first START1 characters and stop at END1.
239 In string STR2, skip the first START2 characters and stop at END2.
240 END1 and END2 default to the full lengths of the respective strings.
242 Case is significant in this comparison if IGNORE-CASE is nil.
243 Unibyte strings are converted to multibyte for comparison.
245 The value is t if the strings (or specified portions) match.
246 If string STR1 is less, the value is a negative number N;
247 - 1 - N is the number of characters that match at the beginning.
248 If string STR1 is greater, the value is a positive number N;
249 N - 1 is the number of characters that match at the beginning. */)
250 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
252 register int end1_char
, end2_char
;
253 register int i1
, i1_byte
, i2
, i2_byte
;
258 start1
= make_number (0);
260 start2
= make_number (0);
261 CHECK_NATNUM (start1
);
262 CHECK_NATNUM (start2
);
271 i1_byte
= string_char_to_byte (str1
, i1
);
272 i2_byte
= string_char_to_byte (str2
, i2
);
274 end1_char
= SCHARS (str1
);
275 if (! NILP (end1
) && end1_char
> XINT (end1
))
276 end1_char
= XINT (end1
);
278 end2_char
= SCHARS (str2
);
279 if (! NILP (end2
) && end2_char
> XINT (end2
))
280 end2_char
= XINT (end2
);
282 while (i1
< end1_char
&& i2
< end2_char
)
284 /* When we find a mismatch, we must compare the
285 characters, not just the bytes. */
288 if (STRING_MULTIBYTE (str1
))
289 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
292 c1
= SREF (str1
, i1
++);
293 MAKE_CHAR_MULTIBYTE (c1
);
296 if (STRING_MULTIBYTE (str2
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
300 c2
= SREF (str2
, i2
++);
301 MAKE_CHAR_MULTIBYTE (c2
);
307 if (! NILP (ignore_case
))
311 tem
= Fupcase (make_number (c1
));
313 tem
= Fupcase (make_number (c2
));
320 /* Note that I1 has already been incremented
321 past the character that we are comparing;
322 hence we don't add or subtract 1 here. */
324 return make_number (- i1
+ XINT (start1
));
326 return make_number (i1
- XINT (start1
));
330 return make_number (i1
- XINT (start1
) + 1);
332 return make_number (- i1
+ XINT (start1
) - 1);
337 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
338 doc
: /* Return t if first arg string is less than second in lexicographic order.
340 Symbols are also allowed; their print names are used instead. */)
341 (register Lisp_Object s1
, Lisp_Object s2
)
344 register int i1
, i1_byte
, i2
, i2_byte
;
347 s1
= SYMBOL_NAME (s1
);
349 s2
= SYMBOL_NAME (s2
);
353 i1
= i1_byte
= i2
= i2_byte
= 0;
356 if (end
> SCHARS (s2
))
361 /* When we find a mismatch, we must compare the
362 characters, not just the bytes. */
365 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
366 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
369 return c1
< c2
? Qt
: Qnil
;
371 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
374 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
375 enum Lisp_Type target_type
, int last_special
);
379 concat2 (Lisp_Object s1
, Lisp_Object s2
)
384 return concat (2, args
, Lisp_String
, 0);
389 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
395 return concat (3, args
, Lisp_String
, 0);
398 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
399 doc
: /* Concatenate all the arguments and make the result a list.
400 The result is a list whose elements are the elements of all the arguments.
401 Each argument may be a list, vector or string.
402 The last argument is not copied, just used as the tail of the new list.
403 usage: (append &rest SEQUENCES) */)
404 (int nargs
, Lisp_Object
*args
)
406 return concat (nargs
, args
, Lisp_Cons
, 1);
409 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
410 doc
: /* Concatenate all the arguments and make the result a string.
411 The result is a string whose elements are the elements of all the arguments.
412 Each argument may be a string or a list or vector of characters (integers).
413 usage: (concat &rest SEQUENCES) */)
414 (int nargs
, Lisp_Object
*args
)
416 return concat (nargs
, args
, Lisp_String
, 0);
419 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
420 doc
: /* Concatenate all the arguments and make the result a vector.
421 The result is a vector whose elements are the elements of all the arguments.
422 Each argument may be a list, vector or string.
423 usage: (vconcat &rest SEQUENCES) */)
424 (int nargs
, Lisp_Object
*args
)
426 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
430 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
431 doc
: /* Return a copy of a list, vector, string or char-table.
432 The elements of a list or vector are not copied; they are shared
433 with the original. */)
436 if (NILP (arg
)) return arg
;
438 if (CHAR_TABLE_P (arg
))
440 return copy_char_table (arg
);
443 if (BOOL_VECTOR_P (arg
))
447 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
448 / BOOL_VECTOR_BITS_PER_CHAR
);
450 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
451 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
456 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
457 wrong_type_argument (Qsequencep
, arg
);
459 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
462 /* This structure holds information of an argument of `concat' that is
463 a string and has text properties to be copied. */
466 int argnum
; /* refer to ARGS (arguments of `concat') */
467 int from
; /* refer to ARGS[argnum] (argument string) */
468 int to
; /* refer to VAL (the target string) */
472 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
475 register Lisp_Object tail
;
476 register Lisp_Object
this;
478 int toindex_byte
= 0;
479 register int result_len
;
480 register int result_len_byte
;
482 Lisp_Object last_tail
;
485 /* When we make a multibyte string, we can't copy text properties
486 while concatinating each string because the length of resulting
487 string can't be decided until we finish the whole concatination.
488 So, we record strings that have text properties to be copied
489 here, and copy the text properties after the concatination. */
490 struct textprop_rec
*textprops
= NULL
;
491 /* Number of elements in textprops. */
492 int num_textprops
= 0;
497 /* In append, the last arg isn't treated like the others */
498 if (last_special
&& nargs
> 0)
501 last_tail
= args
[nargs
];
506 /* Check each argument. */
507 for (argnum
= 0; argnum
< nargs
; argnum
++)
510 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
511 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
512 wrong_type_argument (Qsequencep
, this);
515 /* Compute total length in chars of arguments in RESULT_LEN.
516 If desired output is a string, also compute length in bytes
517 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
518 whether the result should be a multibyte string. */
522 for (argnum
= 0; argnum
< nargs
; argnum
++)
526 len
= XFASTINT (Flength (this));
527 if (target_type
== Lisp_String
)
529 /* We must count the number of bytes needed in the string
530 as well as the number of characters. */
536 for (i
= 0; i
< len
; i
++)
539 CHECK_CHARACTER (ch
);
540 this_len_byte
= CHAR_BYTES (XINT (ch
));
541 result_len_byte
+= this_len_byte
;
542 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
545 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
546 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
547 else if (CONSP (this))
548 for (; CONSP (this); this = XCDR (this))
551 CHECK_CHARACTER (ch
);
552 this_len_byte
= CHAR_BYTES (XINT (ch
));
553 result_len_byte
+= this_len_byte
;
554 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
557 else if (STRINGP (this))
559 if (STRING_MULTIBYTE (this))
562 result_len_byte
+= SBYTES (this);
565 result_len_byte
+= count_size_as_multibyte (SDATA (this),
572 error ("String overflow");
575 if (! some_multibyte
)
576 result_len_byte
= result_len
;
578 /* Create the output object. */
579 if (target_type
== Lisp_Cons
)
580 val
= Fmake_list (make_number (result_len
), Qnil
);
581 else if (target_type
== Lisp_Vectorlike
)
582 val
= Fmake_vector (make_number (result_len
), Qnil
);
583 else if (some_multibyte
)
584 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
586 val
= make_uninit_string (result_len
);
588 /* In `append', if all but last arg are nil, return last arg. */
589 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
592 /* Copy the contents of the args into the result. */
594 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
596 toindex
= 0, toindex_byte
= 0;
600 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 register unsigned int thisindex
= 0;
607 register unsigned int thisindex_byte
= 0;
611 thislen
= Flength (this), thisleni
= XINT (thislen
);
613 /* Between strings of the same kind, copy fast. */
614 if (STRINGP (this) && STRINGP (val
)
615 && STRING_MULTIBYTE (this) == some_multibyte
)
617 int thislen_byte
= SBYTES (this);
619 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
620 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
622 textprops
[num_textprops
].argnum
= argnum
;
623 textprops
[num_textprops
].from
= 0;
624 textprops
[num_textprops
++].to
= toindex
;
626 toindex_byte
+= thislen_byte
;
629 /* Copy a single-byte string to a multibyte string. */
630 else if (STRINGP (this) && STRINGP (val
))
632 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
634 textprops
[num_textprops
].argnum
= argnum
;
635 textprops
[num_textprops
].from
= 0;
636 textprops
[num_textprops
++].to
= toindex
;
638 toindex_byte
+= copy_text (SDATA (this),
639 SDATA (val
) + toindex_byte
,
640 SCHARS (this), 0, 1);
644 /* Copy element by element. */
647 register Lisp_Object elt
;
649 /* Fetch next element of `this' arg into `elt', or break if
650 `this' is exhausted. */
651 if (NILP (this)) break;
653 elt
= XCAR (this), this = XCDR (this);
654 else if (thisindex
>= thisleni
)
656 else if (STRINGP (this))
659 if (STRING_MULTIBYTE (this))
661 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
664 XSETFASTINT (elt
, c
);
668 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
670 && !ASCII_CHAR_P (XINT (elt
))
671 && XINT (elt
) < 0400)
673 c
= BYTE8_TO_CHAR (XINT (elt
));
678 else if (BOOL_VECTOR_P (this))
681 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
682 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
690 elt
= AREF (this, thisindex
);
694 /* Store this element into the result. */
701 else if (VECTORP (val
))
703 ASET (val
, toindex
, elt
);
710 toindex_byte
+= CHAR_STRING (XINT (elt
),
711 SDATA (val
) + toindex_byte
);
713 SSET (val
, toindex_byte
++, XINT (elt
));
719 XSETCDR (prev
, last_tail
);
721 if (num_textprops
> 0)
724 int last_to_end
= -1;
726 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
728 this = args
[textprops
[argnum
].argnum
];
729 props
= text_property_list (this,
731 make_number (SCHARS (this)),
733 /* If successive arguments have properites, be sure that the
734 value of `composition' property be the copy. */
735 if (last_to_end
== textprops
[argnum
].to
)
736 make_composition_value_copy (props
);
737 add_text_properties_from_list (val
, props
,
738 make_number (textprops
[argnum
].to
));
739 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
747 static Lisp_Object string_char_byte_cache_string
;
748 static EMACS_INT string_char_byte_cache_charpos
;
749 static EMACS_INT string_char_byte_cache_bytepos
;
752 clear_string_char_byte_cache (void)
754 string_char_byte_cache_string
= Qnil
;
757 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
760 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
763 EMACS_INT best_below
, best_below_byte
;
764 EMACS_INT best_above
, best_above_byte
;
766 best_below
= best_below_byte
= 0;
767 best_above
= SCHARS (string
);
768 best_above_byte
= SBYTES (string
);
769 if (best_above
== best_above_byte
)
772 if (EQ (string
, string_char_byte_cache_string
))
774 if (string_char_byte_cache_charpos
< char_index
)
776 best_below
= string_char_byte_cache_charpos
;
777 best_below_byte
= string_char_byte_cache_bytepos
;
781 best_above
= string_char_byte_cache_charpos
;
782 best_above_byte
= string_char_byte_cache_bytepos
;
786 if (char_index
- best_below
< best_above
- char_index
)
788 unsigned char *p
= SDATA (string
) + best_below_byte
;
790 while (best_below
< char_index
)
792 p
+= BYTES_BY_CHAR_HEAD (*p
);
795 i_byte
= p
- SDATA (string
);
799 unsigned char *p
= SDATA (string
) + best_above_byte
;
801 while (best_above
> char_index
)
804 while (!CHAR_HEAD_P (*p
)) p
--;
807 i_byte
= p
- SDATA (string
);
810 string_char_byte_cache_bytepos
= i_byte
;
811 string_char_byte_cache_charpos
= char_index
;
812 string_char_byte_cache_string
= string
;
817 /* Return the character index corresponding to BYTE_INDEX in STRING. */
820 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
823 EMACS_INT best_below
, best_below_byte
;
824 EMACS_INT best_above
, best_above_byte
;
826 best_below
= best_below_byte
= 0;
827 best_above
= SCHARS (string
);
828 best_above_byte
= SBYTES (string
);
829 if (best_above
== best_above_byte
)
832 if (EQ (string
, string_char_byte_cache_string
))
834 if (string_char_byte_cache_bytepos
< byte_index
)
836 best_below
= string_char_byte_cache_charpos
;
837 best_below_byte
= string_char_byte_cache_bytepos
;
841 best_above
= string_char_byte_cache_charpos
;
842 best_above_byte
= string_char_byte_cache_bytepos
;
846 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
848 unsigned char *p
= SDATA (string
) + best_below_byte
;
849 unsigned char *pend
= SDATA (string
) + byte_index
;
853 p
+= BYTES_BY_CHAR_HEAD (*p
);
857 i_byte
= p
- SDATA (string
);
861 unsigned char *p
= SDATA (string
) + best_above_byte
;
862 unsigned char *pbeg
= SDATA (string
) + byte_index
;
867 while (!CHAR_HEAD_P (*p
)) p
--;
871 i_byte
= p
- SDATA (string
);
874 string_char_byte_cache_bytepos
= i_byte
;
875 string_char_byte_cache_charpos
= i
;
876 string_char_byte_cache_string
= string
;
881 /* Convert STRING to a multibyte string. */
884 string_make_multibyte (Lisp_Object string
)
891 if (STRING_MULTIBYTE (string
))
894 nbytes
= count_size_as_multibyte (SDATA (string
),
896 /* If all the chars are ASCII, they won't need any more bytes
897 once converted. In that case, we can return STRING itself. */
898 if (nbytes
== SBYTES (string
))
901 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
902 copy_text (SDATA (string
), buf
, SBYTES (string
),
905 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
912 /* Convert STRING (if unibyte) to a multibyte string without changing
913 the number of characters. Characters 0200 trough 0237 are
914 converted to eight-bit characters. */
917 string_to_multibyte (Lisp_Object string
)
924 if (STRING_MULTIBYTE (string
))
927 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
928 /* If all the chars are ASCII, they won't need any more bytes once
930 if (nbytes
== SBYTES (string
))
931 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
933 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
934 memcpy (buf
, SDATA (string
), SBYTES (string
));
935 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
937 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
944 /* Convert STRING to a single-byte string. */
947 string_make_unibyte (Lisp_Object string
)
954 if (! STRING_MULTIBYTE (string
))
957 nchars
= SCHARS (string
);
959 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
960 copy_text (SDATA (string
), buf
, SBYTES (string
),
963 ret
= make_unibyte_string (buf
, nchars
);
969 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
971 doc
: /* Return the multibyte equivalent of STRING.
972 If STRING is unibyte and contains non-ASCII characters, the function
973 `unibyte-char-to-multibyte' is used to convert each unibyte character
974 to a multibyte character. In this case, the returned string is a
975 newly created string with no text properties. If STRING is multibyte
976 or entirely ASCII, it is returned unchanged. In particular, when
977 STRING is unibyte and entirely ASCII, the returned string is unibyte.
978 \(When the characters are all ASCII, Emacs primitives will treat the
979 string the same way whether it is unibyte or multibyte.) */)
982 CHECK_STRING (string
);
984 return string_make_multibyte (string
);
987 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
989 doc
: /* Return the unibyte equivalent of STRING.
990 Multibyte character codes are converted to unibyte according to
991 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
992 If the lookup in the translation table fails, this function takes just
993 the low 8 bits of each character. */)
996 CHECK_STRING (string
);
998 return string_make_unibyte (string
);
1001 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1003 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1004 If STRING is unibyte, the result is STRING itself.
1005 Otherwise it is a newly created string, with no text properties.
1006 If STRING is multibyte and contains a character of charset
1007 `eight-bit', it is converted to the corresponding single byte. */)
1008 (Lisp_Object string
)
1010 CHECK_STRING (string
);
1012 if (STRING_MULTIBYTE (string
))
1014 int bytes
= SBYTES (string
);
1015 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1017 memcpy (str
, SDATA (string
), bytes
);
1018 bytes
= str_as_unibyte (str
, bytes
);
1019 string
= make_unibyte_string (str
, bytes
);
1025 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1027 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1028 If STRING is multibyte, the result is STRING itself.
1029 Otherwise it is a newly created string, with no text properties.
1031 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1032 part of a correct utf-8 sequence), it is converted to the corresponding
1033 multibyte character of charset `eight-bit'.
1034 See also `string-to-multibyte'.
1036 Beware, this often doesn't really do what you think it does.
1037 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1038 If you're not sure, whether to use `string-as-multibyte' or
1039 `string-to-multibyte', use `string-to-multibyte'. */)
1040 (Lisp_Object string
)
1042 CHECK_STRING (string
);
1044 if (! STRING_MULTIBYTE (string
))
1046 Lisp_Object new_string
;
1049 parse_str_as_multibyte (SDATA (string
),
1052 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1053 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1054 if (nbytes
!= SBYTES (string
))
1055 str_as_multibyte (SDATA (new_string
), nbytes
,
1056 SBYTES (string
), NULL
);
1057 string
= new_string
;
1058 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1063 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1065 doc
: /* Return a multibyte string with the same individual chars as STRING.
1066 If STRING is multibyte, the result is STRING itself.
1067 Otherwise it is a newly created string, with no text properties.
1069 If STRING is unibyte and contains an 8-bit byte, it is converted to
1070 the corresponding multibyte character of charset `eight-bit'.
1072 This differs from `string-as-multibyte' by converting each byte of a correct
1073 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1074 correct sequence. */)
1075 (Lisp_Object string
)
1077 CHECK_STRING (string
);
1079 return string_to_multibyte (string
);
1082 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1084 doc
: /* Return a unibyte string with the same individual chars as STRING.
1085 If STRING is unibyte, the result is STRING itself.
1086 Otherwise it is a newly created string, with no text properties,
1087 where each `eight-bit' character is converted to the corresponding byte.
1088 If STRING contains a non-ASCII, non-`eight-bit' character,
1089 an error is signaled. */)
1090 (Lisp_Object string
)
1092 CHECK_STRING (string
);
1094 if (STRING_MULTIBYTE (string
))
1096 EMACS_INT chars
= SCHARS (string
);
1097 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1098 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1100 if (converted
< chars
)
1101 error ("Can't convert the %dth character to unibyte", converted
);
1102 string
= make_unibyte_string (str
, chars
);
1109 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1110 doc
: /* Return a copy of ALIST.
1111 This is an alist which represents the same mapping from objects to objects,
1112 but does not share the alist structure with ALIST.
1113 The objects mapped (cars and cdrs of elements of the alist)
1114 are shared, however.
1115 Elements of ALIST that are not conses are also shared. */)
1118 register Lisp_Object tem
;
1123 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1124 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1126 register Lisp_Object car
;
1130 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1135 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1136 doc
: /* Return a new string whose contents are a substring of STRING.
1137 The returned string consists of the characters between index FROM
1138 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1139 zero-indexed: 0 means the first character of STRING. Negative values
1140 are counted from the end of STRING. If TO is nil, the substring runs
1141 to the end of STRING.
1143 The STRING argument may also be a vector. In that case, the return
1144 value is a new vector that contains the elements between index FROM
1145 \(inclusive) and index TO (exclusive) of that vector argument. */)
1146 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1151 int from_char
, to_char
;
1152 int from_byte
= 0, to_byte
= 0;
1154 CHECK_VECTOR_OR_STRING (string
);
1155 CHECK_NUMBER (from
);
1157 if (STRINGP (string
))
1159 size
= SCHARS (string
);
1160 size_byte
= SBYTES (string
);
1163 size
= ASIZE (string
);
1168 to_byte
= size_byte
;
1174 to_char
= XINT (to
);
1178 if (STRINGP (string
))
1179 to_byte
= string_char_to_byte (string
, to_char
);
1182 from_char
= XINT (from
);
1185 if (STRINGP (string
))
1186 from_byte
= string_char_to_byte (string
, from_char
);
1188 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1189 args_out_of_range_3 (string
, make_number (from_char
),
1190 make_number (to_char
));
1192 if (STRINGP (string
))
1194 res
= make_specified_string (SDATA (string
) + from_byte
,
1195 to_char
- from_char
, to_byte
- from_byte
,
1196 STRING_MULTIBYTE (string
));
1197 copy_text_properties (make_number (from_char
), make_number (to_char
),
1198 string
, make_number (0), res
, Qnil
);
1201 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1207 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1208 doc
: /* Return a substring of STRING, without text properties.
1209 It starts at index FROM and ending before TO.
1210 TO may be nil or omitted; then the substring runs to the end of STRING.
1211 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1212 If FROM or TO is negative, it counts from the end.
1214 With one argument, just copy STRING without its properties. */)
1215 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1217 int size
, size_byte
;
1218 int from_char
, to_char
;
1219 int from_byte
, to_byte
;
1221 CHECK_STRING (string
);
1223 size
= SCHARS (string
);
1224 size_byte
= SBYTES (string
);
1227 from_char
= from_byte
= 0;
1230 CHECK_NUMBER (from
);
1231 from_char
= XINT (from
);
1235 from_byte
= string_char_to_byte (string
, from_char
);
1241 to_byte
= size_byte
;
1247 to_char
= XINT (to
);
1251 to_byte
= string_char_to_byte (string
, to_char
);
1254 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1255 args_out_of_range_3 (string
, make_number (from_char
),
1256 make_number (to_char
));
1258 return make_specified_string (SDATA (string
) + from_byte
,
1259 to_char
- from_char
, to_byte
- from_byte
,
1260 STRING_MULTIBYTE (string
));
1263 /* Extract a substring of STRING, giving start and end positions
1264 both in characters and in bytes. */
1267 substring_both (Lisp_Object string
, int from
, int from_byte
, int to
, int to_byte
)
1273 CHECK_VECTOR_OR_STRING (string
);
1275 if (STRINGP (string
))
1277 size
= SCHARS (string
);
1278 size_byte
= SBYTES (string
);
1281 size
= ASIZE (string
);
1283 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1284 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1286 if (STRINGP (string
))
1288 res
= make_specified_string (SDATA (string
) + from_byte
,
1289 to
- from
, to_byte
- from_byte
,
1290 STRING_MULTIBYTE (string
));
1291 copy_text_properties (make_number (from
), make_number (to
),
1292 string
, make_number (0), res
, Qnil
);
1295 res
= Fvector (to
- from
, &AREF (string
, from
));
1300 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1301 doc
: /* Take cdr N times on LIST, returns the result. */)
1302 (Lisp_Object n
, Lisp_Object list
)
1304 register int i
, num
;
1307 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1310 CHECK_LIST_CONS (list
, list
);
1316 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1317 doc
: /* Return the Nth element of LIST.
1318 N counts from zero. If LIST is not that long, nil is returned. */)
1319 (Lisp_Object n
, Lisp_Object list
)
1321 return Fcar (Fnthcdr (n
, list
));
1324 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1325 doc
: /* Return element of SEQUENCE at index N. */)
1326 (register Lisp_Object sequence
, Lisp_Object n
)
1329 if (CONSP (sequence
) || NILP (sequence
))
1330 return Fcar (Fnthcdr (n
, sequence
));
1332 /* Faref signals a "not array" error, so check here. */
1333 CHECK_ARRAY (sequence
, Qsequencep
);
1334 return Faref (sequence
, n
);
1337 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1338 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1339 The value is actually the tail of LIST whose car is ELT. */)
1340 (register Lisp_Object elt
, Lisp_Object list
)
1342 register Lisp_Object tail
;
1343 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1345 register Lisp_Object tem
;
1346 CHECK_LIST_CONS (tail
, list
);
1348 if (! NILP (Fequal (elt
, tem
)))
1355 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1356 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1357 The value is actually the tail of LIST whose car is ELT. */)
1358 (register Lisp_Object elt
, Lisp_Object list
)
1362 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1366 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1370 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1381 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1382 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1383 The value is actually the tail of LIST whose car is ELT. */)
1384 (register Lisp_Object elt
, Lisp_Object list
)
1386 register Lisp_Object tail
;
1389 return Fmemq (elt
, list
);
1391 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1393 register Lisp_Object tem
;
1394 CHECK_LIST_CONS (tail
, list
);
1396 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1403 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1404 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1405 The value is actually the first element of LIST whose car is KEY.
1406 Elements of LIST that are not conses are ignored. */)
1407 (Lisp_Object key
, Lisp_Object list
)
1412 || (CONSP (XCAR (list
))
1413 && EQ (XCAR (XCAR (list
)), key
)))
1418 || (CONSP (XCAR (list
))
1419 && EQ (XCAR (XCAR (list
)), key
)))
1424 || (CONSP (XCAR (list
))
1425 && EQ (XCAR (XCAR (list
)), key
)))
1435 /* Like Fassq but never report an error and do not allow quits.
1436 Use only on lists known never to be circular. */
1439 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1442 && (!CONSP (XCAR (list
))
1443 || !EQ (XCAR (XCAR (list
)), key
)))
1446 return CAR_SAFE (list
);
1449 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1450 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1451 The value is actually the first element of LIST whose car equals KEY. */)
1452 (Lisp_Object key
, Lisp_Object list
)
1459 || (CONSP (XCAR (list
))
1460 && (car
= XCAR (XCAR (list
)),
1461 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1466 || (CONSP (XCAR (list
))
1467 && (car
= XCAR (XCAR (list
)),
1468 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1473 || (CONSP (XCAR (list
))
1474 && (car
= XCAR (XCAR (list
)),
1475 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1485 /* Like Fassoc but never report an error and do not allow quits.
1486 Use only on lists known never to be circular. */
1489 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1492 && (!CONSP (XCAR (list
))
1493 || (!EQ (XCAR (XCAR (list
)), key
)
1494 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1497 return CONSP (list
) ? XCAR (list
) : Qnil
;
1500 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1501 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1502 The value is actually the first element of LIST whose cdr is KEY. */)
1503 (register Lisp_Object key
, Lisp_Object list
)
1508 || (CONSP (XCAR (list
))
1509 && EQ (XCDR (XCAR (list
)), key
)))
1514 || (CONSP (XCAR (list
))
1515 && EQ (XCDR (XCAR (list
)), key
)))
1520 || (CONSP (XCAR (list
))
1521 && EQ (XCDR (XCAR (list
)), key
)))
1531 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1532 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1533 The value is actually the first element of LIST whose cdr equals KEY. */)
1534 (Lisp_Object key
, Lisp_Object list
)
1541 || (CONSP (XCAR (list
))
1542 && (cdr
= XCDR (XCAR (list
)),
1543 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1548 || (CONSP (XCAR (list
))
1549 && (cdr
= XCDR (XCAR (list
)),
1550 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1555 || (CONSP (XCAR (list
))
1556 && (cdr
= XCDR (XCAR (list
)),
1557 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1567 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1568 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1569 The modified LIST is returned. Comparison is done with `eq'.
1570 If the first member of LIST is ELT, there is no way to remove it by side effect;
1571 therefore, write `(setq foo (delq element foo))'
1572 to be sure of changing the value of `foo'. */)
1573 (register Lisp_Object elt
, Lisp_Object list
)
1575 register Lisp_Object tail
, prev
;
1576 register Lisp_Object tem
;
1580 while (!NILP (tail
))
1582 CHECK_LIST_CONS (tail
, list
);
1589 Fsetcdr (prev
, XCDR (tail
));
1599 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1600 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1601 SEQ must be a list, a vector, or a string.
1602 The modified SEQ is returned. Comparison is done with `equal'.
1603 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1604 is not a side effect; it is simply using a different sequence.
1605 Therefore, write `(setq foo (delete element foo))'
1606 to be sure of changing the value of `foo'. */)
1607 (Lisp_Object elt
, Lisp_Object seq
)
1613 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1614 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1617 if (n
!= ASIZE (seq
))
1619 struct Lisp_Vector
*p
= allocate_vector (n
);
1621 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1622 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1623 p
->contents
[n
++] = AREF (seq
, i
);
1625 XSETVECTOR (seq
, p
);
1628 else if (STRINGP (seq
))
1630 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1633 for (i
= nchars
= nbytes
= ibyte
= 0;
1635 ++i
, ibyte
+= cbytes
)
1637 if (STRING_MULTIBYTE (seq
))
1639 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1640 cbytes
= CHAR_BYTES (c
);
1648 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1655 if (nchars
!= SCHARS (seq
))
1659 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1660 if (!STRING_MULTIBYTE (seq
))
1661 STRING_SET_UNIBYTE (tem
);
1663 for (i
= nchars
= nbytes
= ibyte
= 0;
1665 ++i
, ibyte
+= cbytes
)
1667 if (STRING_MULTIBYTE (seq
))
1669 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1670 cbytes
= CHAR_BYTES (c
);
1678 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1680 unsigned char *from
= SDATA (seq
) + ibyte
;
1681 unsigned char *to
= SDATA (tem
) + nbytes
;
1687 for (n
= cbytes
; n
--; )
1697 Lisp_Object tail
, prev
;
1699 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1701 CHECK_LIST_CONS (tail
, seq
);
1703 if (!NILP (Fequal (elt
, XCAR (tail
))))
1708 Fsetcdr (prev
, XCDR (tail
));
1719 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1720 doc
: /* Reverse LIST by modifying cdr pointers.
1721 Return the reversed list. */)
1724 register Lisp_Object prev
, tail
, next
;
1726 if (NILP (list
)) return list
;
1729 while (!NILP (tail
))
1732 CHECK_LIST_CONS (tail
, list
);
1734 Fsetcdr (tail
, prev
);
1741 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1742 doc
: /* Reverse LIST, copying. Return the reversed list.
1743 See also the function `nreverse', which is used more often. */)
1748 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1751 new = Fcons (XCAR (list
), new);
1753 CHECK_LIST_END (list
, list
);
1757 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1759 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1760 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1761 Returns the sorted list. LIST is modified by side effects.
1762 PREDICATE is called with two elements of LIST, and should return non-nil
1763 if the first element should sort before the second. */)
1764 (Lisp_Object list
, Lisp_Object predicate
)
1766 Lisp_Object front
, back
;
1767 register Lisp_Object len
, tem
;
1768 struct gcpro gcpro1
, gcpro2
;
1769 register int length
;
1772 len
= Flength (list
);
1773 length
= XINT (len
);
1777 XSETINT (len
, (length
/ 2) - 1);
1778 tem
= Fnthcdr (len
, list
);
1780 Fsetcdr (tem
, Qnil
);
1782 GCPRO2 (front
, back
);
1783 front
= Fsort (front
, predicate
);
1784 back
= Fsort (back
, predicate
);
1786 return merge (front
, back
, predicate
);
1790 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1793 register Lisp_Object tail
;
1795 register Lisp_Object l1
, l2
;
1796 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1803 /* It is sufficient to protect org_l1 and org_l2.
1804 When l1 and l2 are updated, we copy the new values
1805 back into the org_ vars. */
1806 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1826 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1842 Fsetcdr (tail
, tem
);
1848 /* This does not check for quits. That is safe since it must terminate. */
1850 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1851 doc
: /* Extract a value from a property list.
1852 PLIST is a property list, which is a list of the form
1853 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1854 corresponding to the given PROP, or nil if PROP is not one of the
1855 properties on the list. This function never signals an error. */)
1856 (Lisp_Object plist
, Lisp_Object prop
)
1858 Lisp_Object tail
, halftail
;
1860 /* halftail is used to detect circular lists. */
1861 tail
= halftail
= plist
;
1862 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1864 if (EQ (prop
, XCAR (tail
)))
1865 return XCAR (XCDR (tail
));
1867 tail
= XCDR (XCDR (tail
));
1868 halftail
= XCDR (halftail
);
1869 if (EQ (tail
, halftail
))
1872 #if 0 /* Unsafe version. */
1873 /* This function can be called asynchronously
1874 (setup_coding_system). Don't QUIT in that case. */
1875 if (!interrupt_input_blocked
)
1883 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1884 doc
: /* Return the value of SYMBOL's PROPNAME property.
1885 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1886 (Lisp_Object symbol
, Lisp_Object propname
)
1888 CHECK_SYMBOL (symbol
);
1889 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1892 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1893 doc
: /* Change value in PLIST of PROP to VAL.
1894 PLIST is a property list, which is a list of the form
1895 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1896 If PROP is already a property on the list, its value is set to VAL,
1897 otherwise the new PROP VAL pair is added. The new plist is returned;
1898 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1899 The PLIST is modified by side effects. */)
1900 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1902 register Lisp_Object tail
, prev
;
1903 Lisp_Object newcell
;
1905 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1906 tail
= XCDR (XCDR (tail
)))
1908 if (EQ (prop
, XCAR (tail
)))
1910 Fsetcar (XCDR (tail
), val
);
1917 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1921 Fsetcdr (XCDR (prev
), newcell
);
1925 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1926 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1927 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1928 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1930 CHECK_SYMBOL (symbol
);
1931 XSYMBOL (symbol
)->plist
1932 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1936 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1937 doc
: /* Extract a value from a property list, comparing with `equal'.
1938 PLIST is a property list, which is a list of the form
1939 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1940 corresponding to the given PROP, or nil if PROP is not
1941 one of the properties on the list. */)
1942 (Lisp_Object plist
, Lisp_Object prop
)
1947 CONSP (tail
) && CONSP (XCDR (tail
));
1948 tail
= XCDR (XCDR (tail
)))
1950 if (! NILP (Fequal (prop
, XCAR (tail
))))
1951 return XCAR (XCDR (tail
));
1956 CHECK_LIST_END (tail
, prop
);
1961 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1962 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1963 PLIST is a property list, which is a list of the form
1964 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1965 If PROP is already a property on the list, its value is set to VAL,
1966 otherwise the new PROP VAL pair is added. The new plist is returned;
1967 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1968 The PLIST is modified by side effects. */)
1969 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1971 register Lisp_Object tail
, prev
;
1972 Lisp_Object newcell
;
1974 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1975 tail
= XCDR (XCDR (tail
)))
1977 if (! NILP (Fequal (prop
, XCAR (tail
))))
1979 Fsetcar (XCDR (tail
), val
);
1986 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1990 Fsetcdr (XCDR (prev
), newcell
);
1994 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1995 doc
: /* Return t if the two args are the same Lisp object.
1996 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1997 (Lisp_Object obj1
, Lisp_Object obj2
)
2000 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2002 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2005 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2006 doc
: /* Return t if two Lisp objects have similar structure and contents.
2007 They must have the same data type.
2008 Conses are compared by comparing the cars and the cdrs.
2009 Vectors and strings are compared element by element.
2010 Numbers are compared by value, but integers cannot equal floats.
2011 (Use `=' if you want integers and floats to be able to be equal.)
2012 Symbols must match exactly. */)
2013 (register Lisp_Object o1
, Lisp_Object o2
)
2015 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2018 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2019 doc
: /* Return t if two Lisp objects have similar structure and contents.
2020 This is like `equal' except that it compares the text properties
2021 of strings. (`equal' ignores text properties.) */)
2022 (register Lisp_Object o1
, Lisp_Object o2
)
2024 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2027 /* DEPTH is current depth of recursion. Signal an error if it
2029 PROPS, if non-nil, means compare string text properties too. */
2032 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2035 error ("Stack overflow in equal");
2041 if (XTYPE (o1
) != XTYPE (o2
))
2050 d1
= extract_float (o1
);
2051 d2
= extract_float (o2
);
2052 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2053 though they are not =. */
2054 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2058 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2065 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2069 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2071 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2074 o1
= XOVERLAY (o1
)->plist
;
2075 o2
= XOVERLAY (o2
)->plist
;
2080 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2081 && (XMARKER (o1
)->buffer
== 0
2082 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2086 case Lisp_Vectorlike
:
2089 EMACS_INT size
= ASIZE (o1
);
2090 /* Pseudovectors have the type encoded in the size field, so this test
2091 actually checks that the objects have the same type as well as the
2093 if (ASIZE (o2
) != size
)
2095 /* Boolvectors are compared much like strings. */
2096 if (BOOL_VECTOR_P (o1
))
2099 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2100 / BOOL_VECTOR_BITS_PER_CHAR
);
2102 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2104 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2109 if (WINDOW_CONFIGURATIONP (o1
))
2110 return compare_window_configurations (o1
, o2
, 0);
2112 /* Aside from them, only true vectors, char-tables, compiled
2113 functions, and fonts (font-spec, font-entity, font-ojbect)
2114 are sensible to compare, so eliminate the others now. */
2115 if (size
& PSEUDOVECTOR_FLAG
)
2117 if (!(size
& (PVEC_COMPILED
2118 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2120 size
&= PSEUDOVECTOR_SIZE_MASK
;
2122 for (i
= 0; i
< size
; i
++)
2127 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2135 if (SCHARS (o1
) != SCHARS (o2
))
2137 if (SBYTES (o1
) != SBYTES (o2
))
2139 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2141 if (props
&& !compare_string_intervals (o1
, o2
))
2153 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2154 doc
: /* Store each element of ARRAY with ITEM.
2155 ARRAY is a vector, string, char-table, or bool-vector. */)
2156 (Lisp_Object array
, Lisp_Object item
)
2158 register int size
, index
, charval
;
2159 if (VECTORP (array
))
2161 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2162 size
= ASIZE (array
);
2163 for (index
= 0; index
< size
; index
++)
2166 else if (CHAR_TABLE_P (array
))
2170 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2171 XCHAR_TABLE (array
)->contents
[i
] = item
;
2172 XCHAR_TABLE (array
)->defalt
= item
;
2174 else if (STRINGP (array
))
2176 register unsigned char *p
= SDATA (array
);
2177 CHECK_NUMBER (item
);
2178 charval
= XINT (item
);
2179 size
= SCHARS (array
);
2180 if (STRING_MULTIBYTE (array
))
2182 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2183 int len
= CHAR_STRING (charval
, str
);
2184 int size_byte
= SBYTES (array
);
2185 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2188 if (size
!= size_byte
)
2191 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2192 if (len
!= this_len
)
2193 error ("Attempt to change byte length of a string");
2196 for (i
= 0; i
< size_byte
; i
++)
2197 *p
++ = str
[i
% len
];
2200 for (index
= 0; index
< size
; index
++)
2203 else if (BOOL_VECTOR_P (array
))
2205 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2207 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2208 / BOOL_VECTOR_BITS_PER_CHAR
);
2210 charval
= (! NILP (item
) ? -1 : 0);
2211 for (index
= 0; index
< size_in_chars
- 1; index
++)
2213 if (index
< size_in_chars
)
2215 /* Mask out bits beyond the vector size. */
2216 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2217 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2222 wrong_type_argument (Qarrayp
, array
);
2226 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2228 doc
: /* Clear the contents of STRING.
2229 This makes STRING unibyte and may change its length. */)
2230 (Lisp_Object string
)
2233 CHECK_STRING (string
);
2234 len
= SBYTES (string
);
2235 memset (SDATA (string
), 0, len
);
2236 STRING_SET_CHARS (string
, len
);
2237 STRING_SET_UNIBYTE (string
);
2243 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2245 Lisp_Object args
[2];
2248 return Fnconc (2, args
);
2251 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2252 doc
: /* Concatenate any number of lists by altering them.
2253 Only the last argument is not altered, and need not be a list.
2254 usage: (nconc &rest LISTS) */)
2255 (int nargs
, Lisp_Object
*args
)
2257 register int argnum
;
2258 register Lisp_Object tail
, tem
, val
;
2262 for (argnum
= 0; argnum
< nargs
; argnum
++)
2265 if (NILP (tem
)) continue;
2270 if (argnum
+ 1 == nargs
) break;
2272 CHECK_LIST_CONS (tem
, tem
);
2281 tem
= args
[argnum
+ 1];
2282 Fsetcdr (tail
, tem
);
2284 args
[argnum
+ 1] = tail
;
2290 /* This is the guts of all mapping functions.
2291 Apply FN to each element of SEQ, one by one,
2292 storing the results into elements of VALS, a C vector of Lisp_Objects.
2293 LENI is the length of VALS, which should also be the length of SEQ. */
2296 mapcar1 (int leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2298 register Lisp_Object tail
;
2301 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2305 /* Don't let vals contain any garbage when GC happens. */
2306 for (i
= 0; i
< leni
; i
++)
2309 GCPRO3 (dummy
, fn
, seq
);
2311 gcpro1
.nvars
= leni
;
2315 /* We need not explicitly protect `tail' because it is used only on lists, and
2316 1) lists are not relocated and 2) the list is marked via `seq' so will not
2321 for (i
= 0; i
< leni
; i
++)
2323 dummy
= call1 (fn
, AREF (seq
, i
));
2328 else if (BOOL_VECTOR_P (seq
))
2330 for (i
= 0; i
< leni
; i
++)
2333 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2334 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2335 dummy
= call1 (fn
, dummy
);
2340 else if (STRINGP (seq
))
2344 for (i
= 0, i_byte
= 0; i
< leni
;)
2349 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2350 XSETFASTINT (dummy
, c
);
2351 dummy
= call1 (fn
, dummy
);
2353 vals
[i_before
] = dummy
;
2356 else /* Must be a list, since Flength did not get an error */
2359 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2361 dummy
= call1 (fn
, XCAR (tail
));
2371 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2372 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2373 In between each pair of results, stick in SEPARATOR. Thus, " " as
2374 SEPARATOR results in spaces between the values returned by FUNCTION.
2375 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2376 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2381 register Lisp_Object
*args
;
2383 struct gcpro gcpro1
;
2387 len
= Flength (sequence
);
2388 if (CHAR_TABLE_P (sequence
))
2389 wrong_type_argument (Qlistp
, sequence
);
2391 nargs
= leni
+ leni
- 1;
2392 if (nargs
< 0) return empty_unibyte_string
;
2394 SAFE_ALLOCA_LISP (args
, nargs
);
2397 mapcar1 (leni
, args
, function
, sequence
);
2400 for (i
= leni
- 1; i
> 0; i
--)
2401 args
[i
+ i
] = args
[i
];
2403 for (i
= 1; i
< nargs
; i
+= 2)
2404 args
[i
] = separator
;
2406 ret
= Fconcat (nargs
, args
);
2412 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2413 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2414 The result is a list just as long as SEQUENCE.
2415 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2416 (Lisp_Object function
, Lisp_Object sequence
)
2418 register Lisp_Object len
;
2420 register Lisp_Object
*args
;
2424 len
= Flength (sequence
);
2425 if (CHAR_TABLE_P (sequence
))
2426 wrong_type_argument (Qlistp
, sequence
);
2427 leni
= XFASTINT (len
);
2429 SAFE_ALLOCA_LISP (args
, leni
);
2431 mapcar1 (leni
, args
, function
, sequence
);
2433 ret
= Flist (leni
, args
);
2439 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2440 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2441 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2442 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2443 (Lisp_Object function
, Lisp_Object sequence
)
2447 leni
= XFASTINT (Flength (sequence
));
2448 if (CHAR_TABLE_P (sequence
))
2449 wrong_type_argument (Qlistp
, sequence
);
2450 mapcar1 (leni
, 0, function
, sequence
);
2455 /* Anything that calls this function must protect from GC! */
2457 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2458 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2459 Takes one argument, which is the string to display to ask the question.
2460 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2461 No confirmation of the answer is requested; a single character is enough.
2462 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2463 the bindings in `query-replace-map'; see the documentation of that variable
2464 for more information. In this case, the useful bindings are `act', `skip',
2465 `recenter', and `quit'.\)
2467 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2468 is nil and `use-dialog-box' is non-nil. */)
2469 (Lisp_Object prompt
)
2471 register Lisp_Object obj
, key
, def
, map
;
2472 register int answer
;
2473 Lisp_Object xprompt
;
2474 Lisp_Object args
[2];
2475 struct gcpro gcpro1
, gcpro2
;
2476 int count
= SPECPDL_INDEX ();
2478 specbind (Qcursor_in_echo_area
, Qt
);
2480 map
= Fsymbol_value (intern ("query-replace-map"));
2482 CHECK_STRING (prompt
);
2484 GCPRO2 (prompt
, xprompt
);
2486 #ifdef HAVE_WINDOW_SYSTEM
2487 if (display_hourglass_p
)
2488 cancel_hourglass ();
2495 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2496 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2500 Lisp_Object pane
, menu
;
2501 redisplay_preserve_echo_area (3);
2502 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2503 Fcons (Fcons (build_string ("No"), Qnil
),
2505 menu
= Fcons (prompt
, pane
);
2506 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2507 answer
= !NILP (obj
);
2510 #endif /* HAVE_MENUS */
2511 cursor_in_echo_area
= 1;
2512 choose_minibuf_frame ();
2515 Lisp_Object pargs
[3];
2517 /* Colorize prompt according to `minibuffer-prompt' face. */
2518 pargs
[0] = build_string ("%s(y or n) ");
2519 pargs
[1] = intern ("face");
2520 pargs
[2] = intern ("minibuffer-prompt");
2521 args
[0] = Fpropertize (3, pargs
);
2526 if (minibuffer_auto_raise
)
2528 Lisp_Object mini_frame
;
2530 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2532 Fraise_frame (mini_frame
);
2535 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2536 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2537 cursor_in_echo_area
= 0;
2538 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2541 key
= Fmake_vector (make_number (1), obj
);
2542 def
= Flookup_key (map
, key
, Qt
);
2544 if (EQ (def
, intern ("skip")))
2549 else if (EQ (def
, intern ("act")))
2554 else if (EQ (def
, intern ("recenter")))
2560 else if (EQ (def
, intern ("quit")))
2562 /* We want to exit this command for exit-prefix,
2563 and this is the only way to do it. */
2564 else if (EQ (def
, intern ("exit-prefix")))
2569 /* If we don't clear this, then the next call to read_char will
2570 return quit_char again, and we'll enter an infinite loop. */
2575 if (EQ (xprompt
, prompt
))
2577 args
[0] = build_string ("Please answer y or n. ");
2579 xprompt
= Fconcat (2, args
);
2584 if (! noninteractive
)
2586 cursor_in_echo_area
= -1;
2587 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2591 unbind_to (count
, Qnil
);
2592 return answer
? Qt
: Qnil
;
2595 /* This is how C code calls `yes-or-no-p' and allows the user
2598 Anything that calls this function must protect from GC! */
2601 do_yes_or_no_p (Lisp_Object prompt
)
2603 return call1 (intern ("yes-or-no-p"), prompt
);
2606 /* Anything that calls this function must protect from GC! */
2608 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2609 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2610 Takes one argument, which is the string to display to ask the question.
2611 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2612 The user must confirm the answer with RET,
2613 and can edit it until it has been confirmed.
2615 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2616 is nil, and `use-dialog-box' is non-nil. */)
2617 (Lisp_Object prompt
)
2619 register Lisp_Object ans
;
2620 Lisp_Object args
[2];
2621 struct gcpro gcpro1
;
2623 CHECK_STRING (prompt
);
2626 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2627 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2631 Lisp_Object pane
, menu
, obj
;
2632 redisplay_preserve_echo_area (4);
2633 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2634 Fcons (Fcons (build_string ("No"), Qnil
),
2637 menu
= Fcons (prompt
, pane
);
2638 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2642 #endif /* HAVE_MENUS */
2645 args
[1] = build_string ("(yes or no) ");
2646 prompt
= Fconcat (2, args
);
2652 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2653 Qyes_or_no_p_history
, Qnil
,
2655 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2660 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2668 message ("Please answer yes or no.");
2669 Fsleep_for (make_number (2), Qnil
);
2673 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2674 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2676 Each of the three load averages is multiplied by 100, then converted
2679 When USE-FLOATS is non-nil, floats will be used instead of integers.
2680 These floats are not multiplied by 100.
2682 If the 5-minute or 15-minute load averages are not available, return a
2683 shortened list, containing only those averages which are available.
2685 An error is thrown if the load average can't be obtained. In some
2686 cases making it work would require Emacs being installed setuid or
2687 setgid so that it can read kernel information, and that usually isn't
2689 (Lisp_Object use_floats
)
2692 int loads
= getloadavg (load_ave
, 3);
2693 Lisp_Object ret
= Qnil
;
2696 error ("load-average not implemented for this operating system");
2700 Lisp_Object load
= (NILP (use_floats
) ?
2701 make_number ((int) (100.0 * load_ave
[loads
]))
2702 : make_float (load_ave
[loads
]));
2703 ret
= Fcons (load
, ret
);
2709 Lisp_Object Vfeatures
, Qsubfeatures
;
2710 extern Lisp_Object Vafter_load_alist
;
2712 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2713 doc
: /* Returns t if FEATURE is present in this Emacs.
2715 Use this to conditionalize execution of lisp code based on the
2716 presence or absence of Emacs or environment extensions.
2717 Use `provide' to declare that a feature is available. This function
2718 looks at the value of the variable `features'. The optional argument
2719 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2720 (Lisp_Object feature
, Lisp_Object subfeature
)
2722 register Lisp_Object tem
;
2723 CHECK_SYMBOL (feature
);
2724 tem
= Fmemq (feature
, Vfeatures
);
2725 if (!NILP (tem
) && !NILP (subfeature
))
2726 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2727 return (NILP (tem
)) ? Qnil
: Qt
;
2730 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2731 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2732 The optional argument SUBFEATURES should be a list of symbols listing
2733 particular subfeatures supported in this version of FEATURE. */)
2734 (Lisp_Object feature
, Lisp_Object subfeatures
)
2736 register Lisp_Object tem
;
2737 CHECK_SYMBOL (feature
);
2738 CHECK_LIST (subfeatures
);
2739 if (!NILP (Vautoload_queue
))
2740 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2742 tem
= Fmemq (feature
, Vfeatures
);
2744 Vfeatures
= Fcons (feature
, Vfeatures
);
2745 if (!NILP (subfeatures
))
2746 Fput (feature
, Qsubfeatures
, subfeatures
);
2747 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2749 /* Run any load-hooks for this file. */
2750 tem
= Fassq (feature
, Vafter_load_alist
);
2752 Fprogn (XCDR (tem
));
2757 /* `require' and its subroutines. */
2759 /* List of features currently being require'd, innermost first. */
2761 Lisp_Object require_nesting_list
;
2764 require_unwind (Lisp_Object old_value
)
2766 return require_nesting_list
= old_value
;
2769 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2770 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2771 If FEATURE is not a member of the list `features', then the feature
2772 is not loaded; so load the file FILENAME.
2773 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2774 and `load' will try to load this name appended with the suffix `.elc' or
2775 `.el', in that order. The name without appended suffix will not be used.
2776 If the optional third argument NOERROR is non-nil,
2777 then return nil if the file is not found instead of signaling an error.
2778 Normally the return value is FEATURE.
2779 The normal messages at start and end of loading FILENAME are suppressed. */)
2780 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2782 register Lisp_Object tem
;
2783 struct gcpro gcpro1
, gcpro2
;
2784 int from_file
= load_in_progress
;
2786 CHECK_SYMBOL (feature
);
2788 /* Record the presence of `require' in this file
2789 even if the feature specified is already loaded.
2790 But not more than once in any file,
2791 and not when we aren't loading or reading from a file. */
2793 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2794 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2799 tem
= Fcons (Qrequire
, feature
);
2800 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2801 LOADHIST_ATTACH (tem
);
2803 tem
= Fmemq (feature
, Vfeatures
);
2807 int count
= SPECPDL_INDEX ();
2810 /* This is to make sure that loadup.el gives a clear picture
2811 of what files are preloaded and when. */
2812 if (! NILP (Vpurify_flag
))
2813 error ("(require %s) while preparing to dump",
2814 SDATA (SYMBOL_NAME (feature
)));
2816 /* A certain amount of recursive `require' is legitimate,
2817 but if we require the same feature recursively 3 times,
2819 tem
= require_nesting_list
;
2820 while (! NILP (tem
))
2822 if (! NILP (Fequal (feature
, XCAR (tem
))))
2827 error ("Recursive `require' for feature `%s'",
2828 SDATA (SYMBOL_NAME (feature
)));
2830 /* Update the list for any nested `require's that occur. */
2831 record_unwind_protect (require_unwind
, require_nesting_list
);
2832 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2834 /* Value saved here is to be restored into Vautoload_queue */
2835 record_unwind_protect (un_autoload
, Vautoload_queue
);
2836 Vautoload_queue
= Qt
;
2838 /* Load the file. */
2839 GCPRO2 (feature
, filename
);
2840 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2841 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2844 /* If load failed entirely, return nil. */
2846 return unbind_to (count
, Qnil
);
2848 tem
= Fmemq (feature
, Vfeatures
);
2850 error ("Required feature `%s' was not provided",
2851 SDATA (SYMBOL_NAME (feature
)));
2853 /* Once loading finishes, don't undo it. */
2854 Vautoload_queue
= Qt
;
2855 feature
= unbind_to (count
, feature
);
2861 /* Primitives for work of the "widget" library.
2862 In an ideal world, this section would not have been necessary.
2863 However, lisp function calls being as slow as they are, it turns
2864 out that some functions in the widget library (wid-edit.el) are the
2865 bottleneck of Widget operation. Here is their translation to C,
2866 for the sole reason of efficiency. */
2868 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2869 doc
: /* Return non-nil if PLIST has the property PROP.
2870 PLIST is a property list, which is a list of the form
2871 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2872 Unlike `plist-get', this allows you to distinguish between a missing
2873 property and a property with the value nil.
2874 The value is actually the tail of PLIST whose car is PROP. */)
2875 (Lisp_Object plist
, Lisp_Object prop
)
2877 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2880 plist
= XCDR (plist
);
2881 plist
= CDR (plist
);
2886 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2887 doc
: /* In WIDGET, set PROPERTY to VALUE.
2888 The value can later be retrieved with `widget-get'. */)
2889 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2891 CHECK_CONS (widget
);
2892 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2896 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2897 doc
: /* In WIDGET, get the value of PROPERTY.
2898 The value could either be specified when the widget was created, or
2899 later with `widget-put'. */)
2900 (Lisp_Object widget
, Lisp_Object property
)
2908 CHECK_CONS (widget
);
2909 tmp
= Fplist_member (XCDR (widget
), property
);
2915 tmp
= XCAR (widget
);
2918 widget
= Fget (tmp
, Qwidget_type
);
2922 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2923 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2924 ARGS are passed as extra arguments to the function.
2925 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2926 (int nargs
, Lisp_Object
*args
)
2928 /* This function can GC. */
2929 Lisp_Object newargs
[3];
2930 struct gcpro gcpro1
, gcpro2
;
2933 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2934 newargs
[1] = args
[0];
2935 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2936 GCPRO2 (newargs
[0], newargs
[2]);
2937 result
= Fapply (3, newargs
);
2942 #ifdef HAVE_LANGINFO_CODESET
2943 #include <langinfo.h>
2946 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2947 doc
: /* Access locale data ITEM for the current C locale, if available.
2948 ITEM should be one of the following:
2950 `codeset', returning the character set as a string (locale item CODESET);
2952 `days', returning a 7-element vector of day names (locale items DAY_n);
2954 `months', returning a 12-element vector of month names (locale items MON_n);
2956 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2957 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2959 If the system can't provide such information through a call to
2960 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2962 See also Info node `(libc)Locales'.
2964 The data read from the system are decoded using `locale-coding-system'. */)
2968 #ifdef HAVE_LANGINFO_CODESET
2970 if (EQ (item
, Qcodeset
))
2972 str
= nl_langinfo (CODESET
);
2973 return build_string (str
);
2976 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2978 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2979 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2981 struct gcpro gcpro1
;
2983 synchronize_system_time_locale ();
2984 for (i
= 0; i
< 7; i
++)
2986 str
= nl_langinfo (days
[i
]);
2987 val
= make_unibyte_string (str
, strlen (str
));
2988 /* Fixme: Is this coding system necessarily right, even if
2989 it is consistent with CODESET? If not, what to do? */
2990 Faset (v
, make_number (i
),
2991 code_convert_string_norecord (val
, Vlocale_coding_system
,
2999 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3001 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3002 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3003 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3005 struct gcpro gcpro1
;
3007 synchronize_system_time_locale ();
3008 for (i
= 0; i
< 12; i
++)
3010 str
= nl_langinfo (months
[i
]);
3011 val
= make_unibyte_string (str
, strlen (str
));
3012 Faset (v
, make_number (i
),
3013 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3019 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3020 but is in the locale files. This could be used by ps-print. */
3022 else if (EQ (item
, Qpaper
))
3024 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3025 make_number (nl_langinfo (PAPER_HEIGHT
)));
3027 #endif /* PAPER_WIDTH */
3028 #endif /* HAVE_LANGINFO_CODESET*/
3032 /* base64 encode/decode functions (RFC 2045).
3033 Based on code from GNU recode. */
3035 #define MIME_LINE_LENGTH 76
3037 #define IS_ASCII(Character) \
3039 #define IS_BASE64(Character) \
3040 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3041 #define IS_BASE64_IGNORABLE(Character) \
3042 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3043 || (Character) == '\f' || (Character) == '\r')
3045 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3046 character or return retval if there are no characters left to
3048 #define READ_QUADRUPLET_BYTE(retval) \
3053 if (nchars_return) \
3054 *nchars_return = nchars; \
3059 while (IS_BASE64_IGNORABLE (c))
3061 /* Table of characters coding the 64 values. */
3062 static const char base64_value_to_char
[64] =
3064 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3065 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3066 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3067 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3068 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3069 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3070 '8', '9', '+', '/' /* 60-63 */
3073 /* Table of base64 values for first 128 characters. */
3074 static const short base64_char_to_value
[128] =
3076 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3077 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3078 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3079 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3080 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3081 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3082 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3083 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3084 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3085 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3086 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3087 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3088 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3091 /* The following diagram shows the logical steps by which three octets
3092 get transformed into four base64 characters.
3094 .--------. .--------. .--------.
3095 |aaaaaabb| |bbbbcccc| |ccdddddd|
3096 `--------' `--------' `--------'
3098 .--------+--------+--------+--------.
3099 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3100 `--------+--------+--------+--------'
3102 .--------+--------+--------+--------.
3103 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3104 `--------+--------+--------+--------'
3106 The octets are divided into 6 bit chunks, which are then encoded into
3107 base64 characters. */
3110 static int base64_encode_1 (const char *, char *, int, int, int);
3111 static int base64_decode_1 (const char *, char *, int, int, int *);
3113 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3115 doc
: /* Base64-encode the region between BEG and END.
3116 Return the length of the encoded text.
3117 Optional third argument NO-LINE-BREAK means do not break long lines
3118 into shorter lines. */)
3119 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3122 int allength
, length
;
3123 int ibeg
, iend
, encoded_length
;
3127 validate_region (&beg
, &end
);
3129 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3130 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3131 move_gap_both (XFASTINT (beg
), ibeg
);
3133 /* We need to allocate enough room for encoding the text.
3134 We need 33 1/3% more space, plus a newline every 76
3135 characters, and then we round up. */
3136 length
= iend
- ibeg
;
3137 allength
= length
+ length
/3 + 1;
3138 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3140 SAFE_ALLOCA (encoded
, char *, allength
);
3141 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3142 NILP (no_line_break
),
3143 !NILP (current_buffer
->enable_multibyte_characters
));
3144 if (encoded_length
> allength
)
3147 if (encoded_length
< 0)
3149 /* The encoding wasn't possible. */
3151 error ("Multibyte character in data for base64 encoding");
3154 /* Now we have encoded the region, so we insert the new contents
3155 and delete the old. (Insert first in order to preserve markers.) */
3156 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3157 insert (encoded
, encoded_length
);
3159 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3161 /* If point was outside of the region, restore it exactly; else just
3162 move to the beginning of the region. */
3163 if (old_pos
>= XFASTINT (end
))
3164 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3165 else if (old_pos
> XFASTINT (beg
))
3166 old_pos
= XFASTINT (beg
);
3169 /* We return the length of the encoded text. */
3170 return make_number (encoded_length
);
3173 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3175 doc
: /* Base64-encode STRING and return the result.
3176 Optional second argument NO-LINE-BREAK means do not break long lines
3177 into shorter lines. */)
3178 (Lisp_Object string
, Lisp_Object no_line_break
)
3180 int allength
, length
, encoded_length
;
3182 Lisp_Object encoded_string
;
3185 CHECK_STRING (string
);
3187 /* We need to allocate enough room for encoding the text.
3188 We need 33 1/3% more space, plus a newline every 76
3189 characters, and then we round up. */
3190 length
= SBYTES (string
);
3191 allength
= length
+ length
/3 + 1;
3192 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3194 /* We need to allocate enough room for decoding the text. */
3195 SAFE_ALLOCA (encoded
, char *, allength
);
3197 encoded_length
= base64_encode_1 (SDATA (string
),
3198 encoded
, length
, NILP (no_line_break
),
3199 STRING_MULTIBYTE (string
));
3200 if (encoded_length
> allength
)
3203 if (encoded_length
< 0)
3205 /* The encoding wasn't possible. */
3207 error ("Multibyte character in data for base64 encoding");
3210 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3213 return encoded_string
;
3217 base64_encode_1 (const char *from
, char *to
, int length
, int line_break
, int multibyte
)
3219 int counter
= 0, i
= 0;
3229 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3230 if (CHAR_BYTE8_P (c
))
3231 c
= CHAR_TO_BYTE8 (c
);
3239 /* Wrap line every 76 characters. */
3243 if (counter
< MIME_LINE_LENGTH
/ 4)
3252 /* Process first byte of a triplet. */
3254 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3255 value
= (0x03 & c
) << 4;
3257 /* Process second byte of a triplet. */
3261 *e
++ = base64_value_to_char
[value
];
3269 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3270 if (CHAR_BYTE8_P (c
))
3271 c
= CHAR_TO_BYTE8 (c
);
3279 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3280 value
= (0x0f & c
) << 2;
3282 /* Process third byte of a triplet. */
3286 *e
++ = base64_value_to_char
[value
];
3293 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3294 if (CHAR_BYTE8_P (c
))
3295 c
= CHAR_TO_BYTE8 (c
);
3303 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3304 *e
++ = base64_value_to_char
[0x3f & c
];
3311 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3313 doc
: /* Base64-decode the region between BEG and END.
3314 Return the length of the decoded text.
3315 If the region can't be decoded, signal an error and don't modify the buffer. */)
3316 (Lisp_Object beg
, Lisp_Object end
)
3318 int ibeg
, iend
, length
, allength
;
3323 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3326 validate_region (&beg
, &end
);
3328 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3329 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3331 length
= iend
- ibeg
;
3333 /* We need to allocate enough room for decoding the text. If we are
3334 working on a multibyte buffer, each decoded code may occupy at
3336 allength
= multibyte
? length
* 2 : length
;
3337 SAFE_ALLOCA (decoded
, char *, allength
);
3339 move_gap_both (XFASTINT (beg
), ibeg
);
3340 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3341 multibyte
, &inserted_chars
);
3342 if (decoded_length
> allength
)
3345 if (decoded_length
< 0)
3347 /* The decoding wasn't possible. */
3349 error ("Invalid base64 data");
3352 /* Now we have decoded the region, so we insert the new contents
3353 and delete the old. (Insert first in order to preserve markers.) */
3354 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3355 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3358 /* Delete the original text. */
3359 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3360 iend
+ decoded_length
, 1);
3362 /* If point was outside of the region, restore it exactly; else just
3363 move to the beginning of the region. */
3364 if (old_pos
>= XFASTINT (end
))
3365 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3366 else if (old_pos
> XFASTINT (beg
))
3367 old_pos
= XFASTINT (beg
);
3368 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3370 return make_number (inserted_chars
);
3373 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3375 doc
: /* Base64-decode STRING and return the result. */)
3376 (Lisp_Object string
)
3379 int length
, decoded_length
;
3380 Lisp_Object decoded_string
;
3383 CHECK_STRING (string
);
3385 length
= SBYTES (string
);
3386 /* We need to allocate enough room for decoding the text. */
3387 SAFE_ALLOCA (decoded
, char *, length
);
3389 /* The decoded result should be unibyte. */
3390 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3392 if (decoded_length
> length
)
3394 else if (decoded_length
>= 0)
3395 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3397 decoded_string
= Qnil
;
3400 if (!STRINGP (decoded_string
))
3401 error ("Invalid base64 data");
3403 return decoded_string
;
3406 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3407 MULTIBYTE is nonzero, the decoded result should be in multibyte
3408 form. If NCHARS_RETRUN is not NULL, store the number of produced
3409 characters in *NCHARS_RETURN. */
3412 base64_decode_1 (const char *from
, char *to
, int length
, int multibyte
, int *nchars_return
)
3417 unsigned long value
;
3422 /* Process first byte of a quadruplet. */
3424 READ_QUADRUPLET_BYTE (e
-to
);
3428 value
= base64_char_to_value
[c
] << 18;
3430 /* Process second byte of a quadruplet. */
3432 READ_QUADRUPLET_BYTE (-1);
3436 value
|= base64_char_to_value
[c
] << 12;
3438 c
= (unsigned char) (value
>> 16);
3439 if (multibyte
&& c
>= 128)
3440 e
+= BYTE8_STRING (c
, e
);
3445 /* Process third byte of a quadruplet. */
3447 READ_QUADRUPLET_BYTE (-1);
3451 READ_QUADRUPLET_BYTE (-1);
3460 value
|= base64_char_to_value
[c
] << 6;
3462 c
= (unsigned char) (0xff & value
>> 8);
3463 if (multibyte
&& c
>= 128)
3464 e
+= BYTE8_STRING (c
, e
);
3469 /* Process fourth byte of a quadruplet. */
3471 READ_QUADRUPLET_BYTE (-1);
3478 value
|= base64_char_to_value
[c
];
3480 c
= (unsigned char) (0xff & value
);
3481 if (multibyte
&& c
>= 128)
3482 e
+= BYTE8_STRING (c
, e
);
3491 /***********************************************************************
3493 ***** Hash Tables *****
3495 ***********************************************************************/
3497 /* Implemented by gerd@gnu.org. This hash table implementation was
3498 inspired by CMUCL hash tables. */
3502 1. For small tables, association lists are probably faster than
3503 hash tables because they have lower overhead.
3505 For uses of hash tables where the O(1) behavior of table
3506 operations is not a requirement, it might therefore be a good idea
3507 not to hash. Instead, we could just do a linear search in the
3508 key_and_value vector of the hash table. This could be done
3509 if a `:linear-search t' argument is given to make-hash-table. */
3512 /* The list of all weak hash tables. Don't staticpro this one. */
3514 struct Lisp_Hash_Table
*weak_hash_tables
;
3516 /* Various symbols. */
3518 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3519 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3520 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3522 /* Function prototypes. */
3524 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3525 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3526 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3527 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3528 Lisp_Object
, unsigned);
3529 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3530 Lisp_Object
, unsigned);
3531 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3532 unsigned, Lisp_Object
, unsigned);
3533 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3534 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3535 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3536 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3538 static unsigned sxhash_string (unsigned char *, int);
3539 static unsigned sxhash_list (Lisp_Object
, int);
3540 static unsigned sxhash_vector (Lisp_Object
, int);
3541 static unsigned sxhash_bool_vector (Lisp_Object
);
3542 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3546 /***********************************************************************
3548 ***********************************************************************/
3550 /* If OBJ is a Lisp hash table, return a pointer to its struct
3551 Lisp_Hash_Table. Otherwise, signal an error. */
3553 static struct Lisp_Hash_Table
*
3554 check_hash_table (Lisp_Object obj
)
3556 CHECK_HASH_TABLE (obj
);
3557 return XHASH_TABLE (obj
);
3561 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3565 next_almost_prime (int n
)
3577 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3578 which USED[I] is non-zero. If found at index I in ARGS, set
3579 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3580 -1. This function is used to extract a keyword/argument pair from
3581 a DEFUN parameter list. */
3584 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3588 for (i
= 0; i
< nargs
- 1; ++i
)
3589 if (!used
[i
] && EQ (args
[i
], key
))
3604 /* Return a Lisp vector which has the same contents as VEC but has
3605 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3606 vector that are not copied from VEC are set to INIT. */
3609 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3611 struct Lisp_Vector
*v
;
3614 xassert (VECTORP (vec
));
3615 old_size
= ASIZE (vec
);
3616 xassert (new_size
>= old_size
);
3618 v
= allocate_vector (new_size
);
3619 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3620 for (i
= old_size
; i
< new_size
; ++i
)
3621 v
->contents
[i
] = init
;
3622 XSETVECTOR (vec
, v
);
3627 /***********************************************************************
3629 ***********************************************************************/
3631 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3632 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3633 KEY2 are the same. */
3636 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3638 return (FLOATP (key1
)
3640 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3644 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3645 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3646 KEY2 are the same. */
3649 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3651 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3655 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3656 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3657 if KEY1 and KEY2 are the same. */
3660 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3664 Lisp_Object args
[3];
3666 args
[0] = h
->user_cmp_function
;
3669 return !NILP (Ffuncall (3, args
));
3676 /* Value is a hash code for KEY for use in hash table H which uses
3677 `eq' to compare keys. The hash code returned is guaranteed to fit
3678 in a Lisp integer. */
3681 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3683 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3684 xassert ((hash
& ~INTMASK
) == 0);
3689 /* Value is a hash code for KEY for use in hash table H which uses
3690 `eql' to compare keys. The hash code returned is guaranteed to fit
3691 in a Lisp integer. */
3694 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3698 hash
= sxhash (key
, 0);
3700 hash
= XUINT (key
) ^ XTYPE (key
);
3701 xassert ((hash
& ~INTMASK
) == 0);
3706 /* Value is a hash code for KEY for use in hash table H which uses
3707 `equal' to compare keys. The hash code returned is guaranteed to fit
3708 in a Lisp integer. */
3711 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3713 unsigned hash
= sxhash (key
, 0);
3714 xassert ((hash
& ~INTMASK
) == 0);
3719 /* Value is a hash code for KEY for use in hash table H which uses as
3720 user-defined function to compare keys. The hash code returned is
3721 guaranteed to fit in a Lisp integer. */
3724 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3726 Lisp_Object args
[2], hash
;
3728 args
[0] = h
->user_hash_function
;
3730 hash
= Ffuncall (2, args
);
3731 if (!INTEGERP (hash
))
3732 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3733 return XUINT (hash
);
3737 /* Create and initialize a new hash table.
3739 TEST specifies the test the hash table will use to compare keys.
3740 It must be either one of the predefined tests `eq', `eql' or
3741 `equal' or a symbol denoting a user-defined test named TEST with
3742 test and hash functions USER_TEST and USER_HASH.
3744 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3746 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3747 new size when it becomes full is computed by adding REHASH_SIZE to
3748 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3749 table's new size is computed by multiplying its old size with
3752 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3753 be resized when the ratio of (number of entries in the table) /
3754 (table size) is >= REHASH_THRESHOLD.
3756 WEAK specifies the weakness of the table. If non-nil, it must be
3757 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3760 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3761 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3762 Lisp_Object user_test
, Lisp_Object user_hash
)
3764 struct Lisp_Hash_Table
*h
;
3766 int index_size
, i
, sz
;
3768 /* Preconditions. */
3769 xassert (SYMBOLP (test
));
3770 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3771 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3772 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3773 xassert (FLOATP (rehash_threshold
)
3774 && XFLOATINT (rehash_threshold
) > 0
3775 && XFLOATINT (rehash_threshold
) <= 1.0);
3777 if (XFASTINT (size
) == 0)
3778 size
= make_number (1);
3780 /* Allocate a table and initialize it. */
3781 h
= allocate_hash_table ();
3783 /* Initialize hash table slots. */
3784 sz
= XFASTINT (size
);
3787 if (EQ (test
, Qeql
))
3789 h
->cmpfn
= cmpfn_eql
;
3790 h
->hashfn
= hashfn_eql
;
3792 else if (EQ (test
, Qeq
))
3795 h
->hashfn
= hashfn_eq
;
3797 else if (EQ (test
, Qequal
))
3799 h
->cmpfn
= cmpfn_equal
;
3800 h
->hashfn
= hashfn_equal
;
3804 h
->user_cmp_function
= user_test
;
3805 h
->user_hash_function
= user_hash
;
3806 h
->cmpfn
= cmpfn_user_defined
;
3807 h
->hashfn
= hashfn_user_defined
;
3811 h
->rehash_threshold
= rehash_threshold
;
3812 h
->rehash_size
= rehash_size
;
3814 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3815 h
->hash
= Fmake_vector (size
, Qnil
);
3816 h
->next
= Fmake_vector (size
, Qnil
);
3817 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3818 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3819 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3821 /* Set up the free list. */
3822 for (i
= 0; i
< sz
- 1; ++i
)
3823 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3824 h
->next_free
= make_number (0);
3826 XSET_HASH_TABLE (table
, h
);
3827 xassert (HASH_TABLE_P (table
));
3828 xassert (XHASH_TABLE (table
) == h
);
3830 /* Maybe add this hash table to the list of all weak hash tables. */
3832 h
->next_weak
= NULL
;
3835 h
->next_weak
= weak_hash_tables
;
3836 weak_hash_tables
= h
;
3843 /* Return a copy of hash table H1. Keys and values are not copied,
3844 only the table itself is. */
3847 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3850 struct Lisp_Hash_Table
*h2
;
3851 struct Lisp_Vector
*next
;
3853 h2
= allocate_hash_table ();
3854 next
= h2
->vec_next
;
3855 memcpy (h2
, h1
, sizeof *h2
);
3856 h2
->vec_next
= next
;
3857 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3858 h2
->hash
= Fcopy_sequence (h1
->hash
);
3859 h2
->next
= Fcopy_sequence (h1
->next
);
3860 h2
->index
= Fcopy_sequence (h1
->index
);
3861 XSET_HASH_TABLE (table
, h2
);
3863 /* Maybe add this hash table to the list of all weak hash tables. */
3864 if (!NILP (h2
->weak
))
3866 h2
->next_weak
= weak_hash_tables
;
3867 weak_hash_tables
= h2
;
3874 /* Resize hash table H if it's too full. If H cannot be resized
3875 because it's already too large, throw an error. */
3878 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3880 if (NILP (h
->next_free
))
3882 int old_size
= HASH_TABLE_SIZE (h
);
3883 int i
, new_size
, index_size
;
3886 if (INTEGERP (h
->rehash_size
))
3887 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3889 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3890 new_size
= max (old_size
+ 1, new_size
);
3891 index_size
= next_almost_prime ((int)
3893 / XFLOATINT (h
->rehash_threshold
)));
3894 /* Assignment to EMACS_INT stops GCC whining about limited range
3896 nsize
= max (index_size
, 2 * new_size
);
3897 if (nsize
> MOST_POSITIVE_FIXNUM
)
3898 error ("Hash table too large to resize");
3900 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3901 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3902 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3903 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3905 /* Update the free list. Do it so that new entries are added at
3906 the end of the free list. This makes some operations like
3908 for (i
= old_size
; i
< new_size
- 1; ++i
)
3909 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3911 if (!NILP (h
->next_free
))
3913 Lisp_Object last
, next
;
3915 last
= h
->next_free
;
3916 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3920 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3923 XSETFASTINT (h
->next_free
, old_size
);
3926 for (i
= 0; i
< old_size
; ++i
)
3927 if (!NILP (HASH_HASH (h
, i
)))
3929 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3930 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3931 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3932 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3938 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3939 the hash code of KEY. Value is the index of the entry in H
3940 matching KEY, or -1 if not found. */
3943 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3946 int start_of_bucket
;
3949 hash_code
= h
->hashfn (h
, key
);
3953 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3954 idx
= HASH_INDEX (h
, start_of_bucket
);
3956 /* We need not gcpro idx since it's either an integer or nil. */
3959 int i
= XFASTINT (idx
);
3960 if (EQ (key
, HASH_KEY (h
, i
))
3962 && h
->cmpfn (h
, key
, hash_code
,
3963 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3965 idx
= HASH_NEXT (h
, i
);
3968 return NILP (idx
) ? -1 : XFASTINT (idx
);
3972 /* Put an entry into hash table H that associates KEY with VALUE.
3973 HASH is a previously computed hash code of KEY.
3974 Value is the index of the entry in H matching KEY. */
3977 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3979 int start_of_bucket
, i
;
3981 xassert ((hash
& ~INTMASK
) == 0);
3983 /* Increment count after resizing because resizing may fail. */
3984 maybe_resize_hash_table (h
);
3987 /* Store key/value in the key_and_value vector. */
3988 i
= XFASTINT (h
->next_free
);
3989 h
->next_free
= HASH_NEXT (h
, i
);
3990 HASH_KEY (h
, i
) = key
;
3991 HASH_VALUE (h
, i
) = value
;
3993 /* Remember its hash code. */
3994 HASH_HASH (h
, i
) = make_number (hash
);
3996 /* Add new entry to its collision chain. */
3997 start_of_bucket
= hash
% ASIZE (h
->index
);
3998 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3999 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4004 /* Remove the entry matching KEY from hash table H, if there is one. */
4007 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4010 int start_of_bucket
;
4011 Lisp_Object idx
, prev
;
4013 hash_code
= h
->hashfn (h
, key
);
4014 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4015 idx
= HASH_INDEX (h
, start_of_bucket
);
4018 /* We need not gcpro idx, prev since they're either integers or nil. */
4021 int i
= XFASTINT (idx
);
4023 if (EQ (key
, HASH_KEY (h
, i
))
4025 && h
->cmpfn (h
, key
, hash_code
,
4026 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4028 /* Take entry out of collision chain. */
4030 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4032 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4034 /* Clear slots in key_and_value and add the slots to
4036 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4037 HASH_NEXT (h
, i
) = h
->next_free
;
4038 h
->next_free
= make_number (i
);
4040 xassert (h
->count
>= 0);
4046 idx
= HASH_NEXT (h
, i
);
4052 /* Clear hash table H. */
4055 hash_clear (struct Lisp_Hash_Table
*h
)
4059 int i
, size
= HASH_TABLE_SIZE (h
);
4061 for (i
= 0; i
< size
; ++i
)
4063 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4064 HASH_KEY (h
, i
) = Qnil
;
4065 HASH_VALUE (h
, i
) = Qnil
;
4066 HASH_HASH (h
, i
) = Qnil
;
4069 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4070 ASET (h
->index
, i
, Qnil
);
4072 h
->next_free
= make_number (0);
4079 /************************************************************************
4081 ************************************************************************/
4084 init_weak_hash_tables (void)
4086 weak_hash_tables
= NULL
;
4089 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4090 entries from the table that don't survive the current GC.
4091 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4092 non-zero if anything was marked. */
4095 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
4097 int bucket
, n
, marked
;
4099 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4102 for (bucket
= 0; bucket
< n
; ++bucket
)
4104 Lisp_Object idx
, next
, prev
;
4106 /* Follow collision chain, removing entries that
4107 don't survive this garbage collection. */
4109 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4111 int i
= XFASTINT (idx
);
4112 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4113 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4116 if (EQ (h
->weak
, Qkey
))
4117 remove_p
= !key_known_to_survive_p
;
4118 else if (EQ (h
->weak
, Qvalue
))
4119 remove_p
= !value_known_to_survive_p
;
4120 else if (EQ (h
->weak
, Qkey_or_value
))
4121 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4122 else if (EQ (h
->weak
, Qkey_and_value
))
4123 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4127 next
= HASH_NEXT (h
, i
);
4129 if (remove_entries_p
)
4133 /* Take out of collision chain. */
4135 HASH_INDEX (h
, bucket
) = next
;
4137 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4139 /* Add to free list. */
4140 HASH_NEXT (h
, i
) = h
->next_free
;
4143 /* Clear key, value, and hash. */
4144 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4145 HASH_HASH (h
, i
) = Qnil
;
4158 /* Make sure key and value survive. */
4159 if (!key_known_to_survive_p
)
4161 mark_object (HASH_KEY (h
, i
));
4165 if (!value_known_to_survive_p
)
4167 mark_object (HASH_VALUE (h
, i
));
4178 /* Remove elements from weak hash tables that don't survive the
4179 current garbage collection. Remove weak tables that don't survive
4180 from Vweak_hash_tables. Called from gc_sweep. */
4183 sweep_weak_hash_tables (void)
4185 struct Lisp_Hash_Table
*h
, *used
, *next
;
4188 /* Mark all keys and values that are in use. Keep on marking until
4189 there is no more change. This is necessary for cases like
4190 value-weak table A containing an entry X -> Y, where Y is used in a
4191 key-weak table B, Z -> Y. If B comes after A in the list of weak
4192 tables, X -> Y might be removed from A, although when looking at B
4193 one finds that it shouldn't. */
4197 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4199 if (h
->size
& ARRAY_MARK_FLAG
)
4200 marked
|= sweep_weak_table (h
, 0);
4205 /* Remove tables and entries that aren't used. */
4206 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4208 next
= h
->next_weak
;
4210 if (h
->size
& ARRAY_MARK_FLAG
)
4212 /* TABLE is marked as used. Sweep its contents. */
4214 sweep_weak_table (h
, 1);
4216 /* Add table to the list of used weak hash tables. */
4217 h
->next_weak
= used
;
4222 weak_hash_tables
= used
;
4227 /***********************************************************************
4228 Hash Code Computation
4229 ***********************************************************************/
4231 /* Maximum depth up to which to dive into Lisp structures. */
4233 #define SXHASH_MAX_DEPTH 3
4235 /* Maximum length up to which to take list and vector elements into
4238 #define SXHASH_MAX_LEN 7
4240 /* Combine two integers X and Y for hashing. */
4242 #define SXHASH_COMBINE(X, Y) \
4243 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4247 /* Return a hash for string PTR which has length LEN. The hash
4248 code returned is guaranteed to fit in a Lisp integer. */
4251 sxhash_string (unsigned char *ptr
, int len
)
4253 unsigned char *p
= ptr
;
4254 unsigned char *end
= p
+ len
;
4263 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4266 return hash
& INTMASK
;
4270 /* Return a hash for list LIST. DEPTH is the current depth in the
4271 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4274 sxhash_list (Lisp_Object list
, int depth
)
4279 if (depth
< SXHASH_MAX_DEPTH
)
4281 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4282 list
= XCDR (list
), ++i
)
4284 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4285 hash
= SXHASH_COMBINE (hash
, hash2
);
4290 unsigned hash2
= sxhash (list
, depth
+ 1);
4291 hash
= SXHASH_COMBINE (hash
, hash2
);
4298 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4299 the Lisp structure. */
4302 sxhash_vector (Lisp_Object vec
, int depth
)
4304 unsigned hash
= ASIZE (vec
);
4307 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4308 for (i
= 0; i
< n
; ++i
)
4310 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4311 hash
= SXHASH_COMBINE (hash
, hash2
);
4318 /* Return a hash for bool-vector VECTOR. */
4321 sxhash_bool_vector (Lisp_Object vec
)
4323 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4326 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4327 for (i
= 0; i
< n
; ++i
)
4328 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4334 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4335 structure. Value is an unsigned integer clipped to INTMASK. */
4338 sxhash (Lisp_Object obj
, int depth
)
4342 if (depth
> SXHASH_MAX_DEPTH
)
4345 switch (XTYPE (obj
))
4356 obj
= SYMBOL_NAME (obj
);
4360 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4363 /* This can be everything from a vector to an overlay. */
4364 case Lisp_Vectorlike
:
4366 /* According to the CL HyperSpec, two arrays are equal only if
4367 they are `eq', except for strings and bit-vectors. In
4368 Emacs, this works differently. We have to compare element
4370 hash
= sxhash_vector (obj
, depth
);
4371 else if (BOOL_VECTOR_P (obj
))
4372 hash
= sxhash_bool_vector (obj
);
4374 /* Others are `equal' if they are `eq', so let's take their
4380 hash
= sxhash_list (obj
, depth
);
4385 double val
= XFLOAT_DATA (obj
);
4386 unsigned char *p
= (unsigned char *) &val
;
4387 unsigned char *e
= p
+ sizeof val
;
4388 for (hash
= 0; p
< e
; ++p
)
4389 hash
= SXHASH_COMBINE (hash
, *p
);
4397 return hash
& INTMASK
;
4402 /***********************************************************************
4404 ***********************************************************************/
4407 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4408 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4411 unsigned hash
= sxhash (obj
, 0);
4412 return make_number (hash
);
4416 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4417 doc
: /* Create and return a new hash table.
4419 Arguments are specified as keyword/argument pairs. The following
4420 arguments are defined:
4422 :test TEST -- TEST must be a symbol that specifies how to compare
4423 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4424 `equal'. User-supplied test and hash functions can be specified via
4425 `define-hash-table-test'.
4427 :size SIZE -- A hint as to how many elements will be put in the table.
4430 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4431 fills up. If REHASH-SIZE is an integer, add that many space. If it
4432 is a float, it must be > 1.0, and the new size is computed by
4433 multiplying the old size with that factor. Default is 1.5.
4435 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4436 Resize the hash table when ratio of the number of entries in the
4437 table. Default is 0.8.
4439 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4440 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4441 returned is a weak table. Key/value pairs are removed from a weak
4442 hash table when there are no non-weak references pointing to their
4443 key, value, one of key or value, or both key and value, depending on
4444 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4447 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4448 (int nargs
, Lisp_Object
*args
)
4450 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4451 Lisp_Object user_test
, user_hash
;
4455 /* The vector `used' is used to keep track of arguments that
4456 have been consumed. */
4457 used
= (char *) alloca (nargs
* sizeof *used
);
4458 memset (used
, 0, nargs
* sizeof *used
);
4460 /* See if there's a `:test TEST' among the arguments. */
4461 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4462 test
= i
< 0 ? Qeql
: args
[i
];
4463 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4465 /* See if it is a user-defined test. */
4468 prop
= Fget (test
, Qhash_table_test
);
4469 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4470 signal_error ("Invalid hash table test", test
);
4471 user_test
= XCAR (prop
);
4472 user_hash
= XCAR (XCDR (prop
));
4475 user_test
= user_hash
= Qnil
;
4477 /* See if there's a `:size SIZE' argument. */
4478 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4479 size
= i
< 0 ? Qnil
: args
[i
];
4481 size
= make_number (DEFAULT_HASH_SIZE
);
4482 else if (!INTEGERP (size
) || XINT (size
) < 0)
4483 signal_error ("Invalid hash table size", size
);
4485 /* Look for `:rehash-size SIZE'. */
4486 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4487 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4488 if (!NUMBERP (rehash_size
)
4489 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4490 || XFLOATINT (rehash_size
) <= 1.0)
4491 signal_error ("Invalid hash table rehash size", rehash_size
);
4493 /* Look for `:rehash-threshold THRESHOLD'. */
4494 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4495 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4496 if (!FLOATP (rehash_threshold
)
4497 || XFLOATINT (rehash_threshold
) <= 0.0
4498 || XFLOATINT (rehash_threshold
) > 1.0)
4499 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4501 /* Look for `:weakness WEAK'. */
4502 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4503 weak
= i
< 0 ? Qnil
: args
[i
];
4505 weak
= Qkey_and_value
;
4508 && !EQ (weak
, Qvalue
)
4509 && !EQ (weak
, Qkey_or_value
)
4510 && !EQ (weak
, Qkey_and_value
))
4511 signal_error ("Invalid hash table weakness", weak
);
4513 /* Now, all args should have been used up, or there's a problem. */
4514 for (i
= 0; i
< nargs
; ++i
)
4516 signal_error ("Invalid argument list", args
[i
]);
4518 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4519 user_test
, user_hash
);
4523 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4524 doc
: /* Return a copy of hash table TABLE. */)
4527 return copy_hash_table (check_hash_table (table
));
4531 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4532 doc
: /* Return the number of elements in TABLE. */)
4535 return make_number (check_hash_table (table
)->count
);
4539 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4540 Shash_table_rehash_size
, 1, 1, 0,
4541 doc
: /* Return the current rehash size of TABLE. */)
4544 return check_hash_table (table
)->rehash_size
;
4548 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4549 Shash_table_rehash_threshold
, 1, 1, 0,
4550 doc
: /* Return the current rehash threshold of TABLE. */)
4553 return check_hash_table (table
)->rehash_threshold
;
4557 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4558 doc
: /* Return the size of TABLE.
4559 The size can be used as an argument to `make-hash-table' to create
4560 a hash table than can hold as many elements of TABLE holds
4561 without need for resizing. */)
4564 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4565 return make_number (HASH_TABLE_SIZE (h
));
4569 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4570 doc
: /* Return the test TABLE uses. */)
4573 return check_hash_table (table
)->test
;
4577 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4579 doc
: /* Return the weakness of TABLE. */)
4582 return check_hash_table (table
)->weak
;
4586 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4587 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4590 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4594 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4595 doc
: /* Clear hash table TABLE and return it. */)
4598 hash_clear (check_hash_table (table
));
4599 /* Be compatible with XEmacs. */
4604 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4605 doc
: /* Look up KEY in TABLE and return its associated value.
4606 If KEY is not found, return DFLT which defaults to nil. */)
4607 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4609 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4610 int i
= hash_lookup (h
, key
, NULL
);
4611 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4615 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4616 doc
: /* Associate KEY with VALUE in hash table TABLE.
4617 If KEY is already present in table, replace its current value with
4619 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4621 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4625 i
= hash_lookup (h
, key
, &hash
);
4627 HASH_VALUE (h
, i
) = value
;
4629 hash_put (h
, key
, value
, hash
);
4635 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4636 doc
: /* Remove KEY from TABLE. */)
4637 (Lisp_Object key
, Lisp_Object table
)
4639 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4640 hash_remove_from_table (h
, key
);
4645 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4646 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4647 FUNCTION is called with two arguments, KEY and VALUE. */)
4648 (Lisp_Object function
, Lisp_Object table
)
4650 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4651 Lisp_Object args
[3];
4654 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4655 if (!NILP (HASH_HASH (h
, i
)))
4658 args
[1] = HASH_KEY (h
, i
);
4659 args
[2] = HASH_VALUE (h
, i
);
4667 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4668 Sdefine_hash_table_test
, 3, 3, 0,
4669 doc
: /* Define a new hash table test with name NAME, a symbol.
4671 In hash tables created with NAME specified as test, use TEST to
4672 compare keys, and HASH for computing hash codes of keys.
4674 TEST must be a function taking two arguments and returning non-nil if
4675 both arguments are the same. HASH must be a function taking one
4676 argument and return an integer that is the hash code of the argument.
4677 Hash code computation should use the whole value range of integers,
4678 including negative integers. */)
4679 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4681 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4686 /************************************************************************
4688 ************************************************************************/
4692 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4693 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4695 A message digest is a cryptographic checksum of a document, and the
4696 algorithm to calculate it is defined in RFC 1321.
4698 The two optional arguments START and END are character positions
4699 specifying for which part of OBJECT the message digest should be
4700 computed. If nil or omitted, the digest is computed for the whole
4703 The MD5 message digest is computed from the result of encoding the
4704 text in a coding system, not directly from the internal Emacs form of
4705 the text. The optional fourth argument CODING-SYSTEM specifies which
4706 coding system to encode the text with. It should be the same coding
4707 system that you used or will use when actually writing the text into a
4710 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4711 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4712 system would be chosen by default for writing this text into a file.
4714 If OBJECT is a string, the most preferred coding system (see the
4715 command `prefer-coding-system') is used.
4717 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4718 guesswork fails. Normally, an error is signaled in such case. */)
4719 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4721 unsigned char digest
[16];
4722 unsigned char value
[33];
4726 int start_char
= 0, end_char
= 0;
4727 int start_byte
= 0, end_byte
= 0;
4729 register struct buffer
*bp
;
4732 if (STRINGP (object
))
4734 if (NILP (coding_system
))
4736 /* Decide the coding-system to encode the data with. */
4738 if (STRING_MULTIBYTE (object
))
4739 /* use default, we can't guess correct value */
4740 coding_system
= preferred_coding_system ();
4742 coding_system
= Qraw_text
;
4745 if (NILP (Fcoding_system_p (coding_system
)))
4747 /* Invalid coding system. */
4749 if (!NILP (noerror
))
4750 coding_system
= Qraw_text
;
4752 xsignal1 (Qcoding_system_error
, coding_system
);
4755 if (STRING_MULTIBYTE (object
))
4756 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4758 size
= SCHARS (object
);
4759 size_byte
= SBYTES (object
);
4763 CHECK_NUMBER (start
);
4765 start_char
= XINT (start
);
4770 start_byte
= string_char_to_byte (object
, start_char
);
4776 end_byte
= size_byte
;
4782 end_char
= XINT (end
);
4787 end_byte
= string_char_to_byte (object
, end_char
);
4790 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4791 args_out_of_range_3 (object
, make_number (start_char
),
4792 make_number (end_char
));
4796 struct buffer
*prev
= current_buffer
;
4798 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4800 CHECK_BUFFER (object
);
4802 bp
= XBUFFER (object
);
4803 if (bp
!= current_buffer
)
4804 set_buffer_internal (bp
);
4810 CHECK_NUMBER_COERCE_MARKER (start
);
4818 CHECK_NUMBER_COERCE_MARKER (end
);
4823 temp
= b
, b
= e
, e
= temp
;
4825 if (!(BEGV
<= b
&& e
<= ZV
))
4826 args_out_of_range (start
, end
);
4828 if (NILP (coding_system
))
4830 /* Decide the coding-system to encode the data with.
4831 See fileio.c:Fwrite-region */
4833 if (!NILP (Vcoding_system_for_write
))
4834 coding_system
= Vcoding_system_for_write
;
4837 int force_raw_text
= 0;
4839 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4840 if (NILP (coding_system
)
4841 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4843 coding_system
= Qnil
;
4844 if (NILP (current_buffer
->enable_multibyte_characters
))
4848 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4850 /* Check file-coding-system-alist. */
4851 Lisp_Object args
[4], val
;
4853 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4854 args
[3] = Fbuffer_file_name(object
);
4855 val
= Ffind_operation_coding_system (4, args
);
4856 if (CONSP (val
) && !NILP (XCDR (val
)))
4857 coding_system
= XCDR (val
);
4860 if (NILP (coding_system
)
4861 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4863 /* If we still have not decided a coding system, use the
4864 default value of buffer-file-coding-system. */
4865 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4869 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4870 /* Confirm that VAL can surely encode the current region. */
4871 coding_system
= call4 (Vselect_safe_coding_system_function
,
4872 make_number (b
), make_number (e
),
4873 coding_system
, Qnil
);
4876 coding_system
= Qraw_text
;
4879 if (NILP (Fcoding_system_p (coding_system
)))
4881 /* Invalid coding system. */
4883 if (!NILP (noerror
))
4884 coding_system
= Qraw_text
;
4886 xsignal1 (Qcoding_system_error
, coding_system
);
4890 object
= make_buffer_string (b
, e
, 0);
4891 if (prev
!= current_buffer
)
4892 set_buffer_internal (prev
);
4893 /* Discard the unwind protect for recovering the current
4897 if (STRING_MULTIBYTE (object
))
4898 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4901 md5_buffer (SDATA (object
) + start_byte
,
4902 SBYTES (object
) - (size_byte
- end_byte
),
4905 for (i
= 0; i
< 16; i
++)
4906 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4909 return make_string (value
, 32);
4916 /* Hash table stuff. */
4917 Qhash_table_p
= intern_c_string ("hash-table-p");
4918 staticpro (&Qhash_table_p
);
4919 Qeq
= intern_c_string ("eq");
4921 Qeql
= intern_c_string ("eql");
4923 Qequal
= intern_c_string ("equal");
4924 staticpro (&Qequal
);
4925 QCtest
= intern_c_string (":test");
4926 staticpro (&QCtest
);
4927 QCsize
= intern_c_string (":size");
4928 staticpro (&QCsize
);
4929 QCrehash_size
= intern_c_string (":rehash-size");
4930 staticpro (&QCrehash_size
);
4931 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4932 staticpro (&QCrehash_threshold
);
4933 QCweakness
= intern_c_string (":weakness");
4934 staticpro (&QCweakness
);
4935 Qkey
= intern_c_string ("key");
4937 Qvalue
= intern_c_string ("value");
4938 staticpro (&Qvalue
);
4939 Qhash_table_test
= intern_c_string ("hash-table-test");
4940 staticpro (&Qhash_table_test
);
4941 Qkey_or_value
= intern_c_string ("key-or-value");
4942 staticpro (&Qkey_or_value
);
4943 Qkey_and_value
= intern_c_string ("key-and-value");
4944 staticpro (&Qkey_and_value
);
4947 defsubr (&Smake_hash_table
);
4948 defsubr (&Scopy_hash_table
);
4949 defsubr (&Shash_table_count
);
4950 defsubr (&Shash_table_rehash_size
);
4951 defsubr (&Shash_table_rehash_threshold
);
4952 defsubr (&Shash_table_size
);
4953 defsubr (&Shash_table_test
);
4954 defsubr (&Shash_table_weakness
);
4955 defsubr (&Shash_table_p
);
4956 defsubr (&Sclrhash
);
4957 defsubr (&Sgethash
);
4958 defsubr (&Sputhash
);
4959 defsubr (&Sremhash
);
4960 defsubr (&Smaphash
);
4961 defsubr (&Sdefine_hash_table_test
);
4963 Qstring_lessp
= intern_c_string ("string-lessp");
4964 staticpro (&Qstring_lessp
);
4965 Qprovide
= intern_c_string ("provide");
4966 staticpro (&Qprovide
);
4967 Qrequire
= intern_c_string ("require");
4968 staticpro (&Qrequire
);
4969 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4970 staticpro (&Qyes_or_no_p_history
);
4971 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4972 staticpro (&Qcursor_in_echo_area
);
4973 Qwidget_type
= intern_c_string ("widget-type");
4974 staticpro (&Qwidget_type
);
4976 staticpro (&string_char_byte_cache_string
);
4977 string_char_byte_cache_string
= Qnil
;
4979 require_nesting_list
= Qnil
;
4980 staticpro (&require_nesting_list
);
4982 Fset (Qyes_or_no_p_history
, Qnil
);
4984 DEFVAR_LISP ("features", &Vfeatures
,
4985 doc
: /* A list of symbols which are the features of the executing Emacs.
4986 Used by `featurep' and `require', and altered by `provide'. */);
4987 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4988 Qsubfeatures
= intern_c_string ("subfeatures");
4989 staticpro (&Qsubfeatures
);
4991 #ifdef HAVE_LANGINFO_CODESET
4992 Qcodeset
= intern_c_string ("codeset");
4993 staticpro (&Qcodeset
);
4994 Qdays
= intern_c_string ("days");
4996 Qmonths
= intern_c_string ("months");
4997 staticpro (&Qmonths
);
4998 Qpaper
= intern_c_string ("paper");
4999 staticpro (&Qpaper
);
5000 #endif /* HAVE_LANGINFO_CODESET */
5002 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5003 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5004 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5005 invoked by mouse clicks and mouse menu items.
5007 On some platforms, file selection dialogs are also enabled if this is
5011 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5012 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5013 This applies to commands from menus and tool bar buttons even when
5014 they are initiated from the keyboard. If `use-dialog-box' is nil,
5015 that disables the use of a file dialog, regardless of the value of
5017 use_file_dialog
= 1;
5019 defsubr (&Sidentity
);
5022 defsubr (&Ssafe_length
);
5023 defsubr (&Sstring_bytes
);
5024 defsubr (&Sstring_equal
);
5025 defsubr (&Scompare_strings
);
5026 defsubr (&Sstring_lessp
);
5029 defsubr (&Svconcat
);
5030 defsubr (&Scopy_sequence
);
5031 defsubr (&Sstring_make_multibyte
);
5032 defsubr (&Sstring_make_unibyte
);
5033 defsubr (&Sstring_as_multibyte
);
5034 defsubr (&Sstring_as_unibyte
);
5035 defsubr (&Sstring_to_multibyte
);
5036 defsubr (&Sstring_to_unibyte
);
5037 defsubr (&Scopy_alist
);
5038 defsubr (&Ssubstring
);
5039 defsubr (&Ssubstring_no_properties
);
5052 defsubr (&Snreverse
);
5053 defsubr (&Sreverse
);
5055 defsubr (&Splist_get
);
5057 defsubr (&Splist_put
);
5059 defsubr (&Slax_plist_get
);
5060 defsubr (&Slax_plist_put
);
5063 defsubr (&Sequal_including_properties
);
5064 defsubr (&Sfillarray
);
5065 defsubr (&Sclear_string
);
5069 defsubr (&Smapconcat
);
5070 defsubr (&Sy_or_n_p
);
5071 defsubr (&Syes_or_no_p
);
5072 defsubr (&Sload_average
);
5073 defsubr (&Sfeaturep
);
5074 defsubr (&Srequire
);
5075 defsubr (&Sprovide
);
5076 defsubr (&Splist_member
);
5077 defsubr (&Swidget_put
);
5078 defsubr (&Swidget_get
);
5079 defsubr (&Swidget_apply
);
5080 defsubr (&Sbase64_encode_region
);
5081 defsubr (&Sbase64_decode_region
);
5082 defsubr (&Sbase64_encode_string
);
5083 defsubr (&Sbase64_decode_string
);
5085 defsubr (&Slocale_info
);
5094 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5095 (do not change this comment) */