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 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
68 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
70 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
72 extern long get_random (void);
73 extern void seed_random (long);
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 doc
: /* Return the argument unchanged. */)
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 doc
: /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 29 bits' worth.
90 With positive integer LIMIT, return random number in interval [0,LIMIT).
91 With argument t, set the random number seed from the current time and pid.
92 Other values of LIMIT are ignored. */)
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (limit
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 doc
: /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */)
129 (register Lisp_Object sequence
)
131 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, SCHARS (sequence
));
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, ASIZE (sequence
));
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 CHECK_LIST_END (sequence
, sequence
);
162 val
= make_number (i
);
164 else if (NILP (sequence
))
165 XSETFASTINT (val
, 0);
167 wrong_type_argument (Qsequencep
, sequence
);
172 /* This does not check for quits. That is safe since it must terminate. */
174 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
175 doc
: /* Return the length of a list, but avoid error or infinite loop.
176 This function never gets an error. If LIST is not really a list,
177 it returns 0. If LIST is circular, it returns a finite value
178 which is at least the number of distinct elements. */)
181 Lisp_Object tail
, halftail
, length
;
184 /* halftail is used to detect circular lists. */
186 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
188 if (EQ (tail
, halftail
) && len
!= 0)
192 halftail
= XCDR (halftail
);
195 XSETINT (length
, len
);
199 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
200 doc
: /* Return the number of bytes in STRING.
201 If STRING is multibyte, this may be greater than the length of STRING. */)
204 CHECK_STRING (string
);
205 return make_number (SBYTES (string
));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 doc
: /* Return t if two strings have identical contents.
210 Case is significant, but text properties are ignored.
211 Symbols are also allowed; their print names are used instead. */)
212 (register Lisp_Object s1
, Lisp_Object s2
)
215 s1
= SYMBOL_NAME (s1
);
217 s2
= SYMBOL_NAME (s2
);
221 if (SCHARS (s1
) != SCHARS (s2
)
222 || SBYTES (s1
) != SBYTES (s2
)
223 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
228 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
229 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
230 In string STR1, skip the first START1 characters and stop at END1.
231 In string STR2, skip the first START2 characters and stop at END2.
232 END1 and END2 default to the full lengths of the respective strings.
234 Case is significant in this comparison if IGNORE-CASE is nil.
235 Unibyte strings are converted to multibyte for comparison.
237 The value is t if the strings (or specified portions) match.
238 If string STR1 is less, the value is a negative number N;
239 - 1 - N is the number of characters that match at the beginning.
240 If string STR1 is greater, the value is a positive number N;
241 N - 1 is the number of characters that match at the beginning. */)
242 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
244 register int end1_char
, end2_char
;
245 register int i1
, i1_byte
, i2
, i2_byte
;
250 start1
= make_number (0);
252 start2
= make_number (0);
253 CHECK_NATNUM (start1
);
254 CHECK_NATNUM (start2
);
263 i1_byte
= string_char_to_byte (str1
, i1
);
264 i2_byte
= string_char_to_byte (str2
, i2
);
266 end1_char
= SCHARS (str1
);
267 if (! NILP (end1
) && end1_char
> XINT (end1
))
268 end1_char
= XINT (end1
);
270 end2_char
= SCHARS (str2
);
271 if (! NILP (end2
) && end2_char
> XINT (end2
))
272 end2_char
= XINT (end2
);
274 while (i1
< end1_char
&& i2
< end2_char
)
276 /* When we find a mismatch, we must compare the
277 characters, not just the bytes. */
280 if (STRING_MULTIBYTE (str1
))
281 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
284 c1
= SREF (str1
, i1
++);
285 MAKE_CHAR_MULTIBYTE (c1
);
288 if (STRING_MULTIBYTE (str2
))
289 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
292 c2
= SREF (str2
, i2
++);
293 MAKE_CHAR_MULTIBYTE (c2
);
299 if (! NILP (ignore_case
))
303 tem
= Fupcase (make_number (c1
));
305 tem
= Fupcase (make_number (c2
));
312 /* Note that I1 has already been incremented
313 past the character that we are comparing;
314 hence we don't add or subtract 1 here. */
316 return make_number (- i1
+ XINT (start1
));
318 return make_number (i1
- XINT (start1
));
322 return make_number (i1
- XINT (start1
) + 1);
324 return make_number (- i1
+ XINT (start1
) - 1);
329 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
330 doc
: /* Return t if first arg string is less than second in lexicographic order.
332 Symbols are also allowed; their print names are used instead. */)
333 (register Lisp_Object s1
, Lisp_Object s2
)
336 register int i1
, i1_byte
, i2
, i2_byte
;
339 s1
= SYMBOL_NAME (s1
);
341 s2
= SYMBOL_NAME (s2
);
345 i1
= i1_byte
= i2
= i2_byte
= 0;
348 if (end
> SCHARS (s2
))
353 /* When we find a mismatch, we must compare the
354 characters, not just the bytes. */
357 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
358 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
361 return c1
< c2
? Qt
: Qnil
;
363 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
366 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
367 enum Lisp_Type target_type
, int last_special
);
371 concat2 (Lisp_Object s1
, Lisp_Object s2
)
376 return concat (2, args
, Lisp_String
, 0);
381 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
387 return concat (3, args
, Lisp_String
, 0);
390 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
391 doc
: /* Concatenate all the arguments and make the result a list.
392 The result is a list whose elements are the elements of all the arguments.
393 Each argument may be a list, vector or string.
394 The last argument is not copied, just used as the tail of the new list.
395 usage: (append &rest SEQUENCES) */)
396 (int nargs
, Lisp_Object
*args
)
398 return concat (nargs
, args
, Lisp_Cons
, 1);
401 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
402 doc
: /* Concatenate all the arguments and make the result a string.
403 The result is a string whose elements are the elements of all the arguments.
404 Each argument may be a string or a list or vector of characters (integers).
405 usage: (concat &rest SEQUENCES) */)
406 (int nargs
, Lisp_Object
*args
)
408 return concat (nargs
, args
, Lisp_String
, 0);
411 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
412 doc
: /* Concatenate all the arguments and make the result a vector.
413 The result is a vector whose elements are the elements of all the arguments.
414 Each argument may be a list, vector or string.
415 usage: (vconcat &rest SEQUENCES) */)
416 (int nargs
, Lisp_Object
*args
)
418 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
422 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
423 doc
: /* Return a copy of a list, vector, string or char-table.
424 The elements of a list or vector are not copied; they are shared
425 with the original. */)
428 if (NILP (arg
)) return arg
;
430 if (CHAR_TABLE_P (arg
))
432 return copy_char_table (arg
);
435 if (BOOL_VECTOR_P (arg
))
439 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
440 / BOOL_VECTOR_BITS_PER_CHAR
);
442 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
443 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
448 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
449 wrong_type_argument (Qsequencep
, arg
);
451 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
454 /* This structure holds information of an argument of `concat' that is
455 a string and has text properties to be copied. */
458 int argnum
; /* refer to ARGS (arguments of `concat') */
459 int from
; /* refer to ARGS[argnum] (argument string) */
460 int to
; /* refer to VAL (the target string) */
464 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
467 register Lisp_Object tail
;
468 register Lisp_Object
this;
470 int toindex_byte
= 0;
471 register int result_len
;
472 register int result_len_byte
;
474 Lisp_Object last_tail
;
477 /* When we make a multibyte string, we can't copy text properties
478 while concatinating each string because the length of resulting
479 string can't be decided until we finish the whole concatination.
480 So, we record strings that have text properties to be copied
481 here, and copy the text properties after the concatination. */
482 struct textprop_rec
*textprops
= NULL
;
483 /* Number of elements in textprops. */
484 int num_textprops
= 0;
489 /* In append, the last arg isn't treated like the others */
490 if (last_special
&& nargs
> 0)
493 last_tail
= args
[nargs
];
498 /* Check each argument. */
499 for (argnum
= 0; argnum
< nargs
; argnum
++)
502 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
503 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
504 wrong_type_argument (Qsequencep
, this);
507 /* Compute total length in chars of arguments in RESULT_LEN.
508 If desired output is a string, also compute length in bytes
509 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
510 whether the result should be a multibyte string. */
514 for (argnum
= 0; argnum
< nargs
; argnum
++)
518 len
= XFASTINT (Flength (this));
519 if (target_type
== Lisp_String
)
521 /* We must count the number of bytes needed in the string
522 as well as the number of characters. */
528 for (i
= 0; i
< len
; i
++)
531 CHECK_CHARACTER (ch
);
532 this_len_byte
= CHAR_BYTES (XINT (ch
));
533 result_len_byte
+= this_len_byte
;
534 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
537 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
538 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
539 else if (CONSP (this))
540 for (; CONSP (this); this = XCDR (this))
543 CHECK_CHARACTER (ch
);
544 this_len_byte
= CHAR_BYTES (XINT (ch
));
545 result_len_byte
+= this_len_byte
;
546 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
549 else if (STRINGP (this))
551 if (STRING_MULTIBYTE (this))
554 result_len_byte
+= SBYTES (this);
557 result_len_byte
+= count_size_as_multibyte (SDATA (this),
564 error ("String overflow");
567 if (! some_multibyte
)
568 result_len_byte
= result_len
;
570 /* Create the output object. */
571 if (target_type
== Lisp_Cons
)
572 val
= Fmake_list (make_number (result_len
), Qnil
);
573 else if (target_type
== Lisp_Vectorlike
)
574 val
= Fmake_vector (make_number (result_len
), Qnil
);
575 else if (some_multibyte
)
576 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
578 val
= make_uninit_string (result_len
);
580 /* In `append', if all but last arg are nil, return last arg. */
581 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
584 /* Copy the contents of the args into the result. */
586 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
588 toindex
= 0, toindex_byte
= 0;
592 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
594 for (argnum
= 0; argnum
< nargs
; argnum
++)
598 register unsigned int thisindex
= 0;
599 register unsigned int thisindex_byte
= 0;
603 thislen
= Flength (this), thisleni
= XINT (thislen
);
605 /* Between strings of the same kind, copy fast. */
606 if (STRINGP (this) && STRINGP (val
)
607 && STRING_MULTIBYTE (this) == some_multibyte
)
609 int thislen_byte
= SBYTES (this);
611 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
612 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
614 textprops
[num_textprops
].argnum
= argnum
;
615 textprops
[num_textprops
].from
= 0;
616 textprops
[num_textprops
++].to
= toindex
;
618 toindex_byte
+= thislen_byte
;
621 /* Copy a single-byte string to a multibyte string. */
622 else if (STRINGP (this) && STRINGP (val
))
624 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
626 textprops
[num_textprops
].argnum
= argnum
;
627 textprops
[num_textprops
].from
= 0;
628 textprops
[num_textprops
++].to
= toindex
;
630 toindex_byte
+= copy_text (SDATA (this),
631 SDATA (val
) + toindex_byte
,
632 SCHARS (this), 0, 1);
636 /* Copy element by element. */
639 register Lisp_Object elt
;
641 /* Fetch next element of `this' arg into `elt', or break if
642 `this' is exhausted. */
643 if (NILP (this)) break;
645 elt
= XCAR (this), this = XCDR (this);
646 else if (thisindex
>= thisleni
)
648 else if (STRINGP (this))
651 if (STRING_MULTIBYTE (this))
653 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
656 XSETFASTINT (elt
, c
);
660 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
662 && !ASCII_CHAR_P (XINT (elt
))
663 && XINT (elt
) < 0400)
665 c
= BYTE8_TO_CHAR (XINT (elt
));
670 else if (BOOL_VECTOR_P (this))
673 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
674 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
682 elt
= AREF (this, thisindex
);
686 /* Store this element into the result. */
693 else if (VECTORP (val
))
695 ASET (val
, toindex
, elt
);
702 toindex_byte
+= CHAR_STRING (XINT (elt
),
703 SDATA (val
) + toindex_byte
);
705 SSET (val
, toindex_byte
++, XINT (elt
));
711 XSETCDR (prev
, last_tail
);
713 if (num_textprops
> 0)
716 int last_to_end
= -1;
718 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
720 this = args
[textprops
[argnum
].argnum
];
721 props
= text_property_list (this,
723 make_number (SCHARS (this)),
725 /* If successive arguments have properites, be sure that the
726 value of `composition' property be the copy. */
727 if (last_to_end
== textprops
[argnum
].to
)
728 make_composition_value_copy (props
);
729 add_text_properties_from_list (val
, props
,
730 make_number (textprops
[argnum
].to
));
731 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
739 static Lisp_Object string_char_byte_cache_string
;
740 static EMACS_INT string_char_byte_cache_charpos
;
741 static EMACS_INT string_char_byte_cache_bytepos
;
744 clear_string_char_byte_cache (void)
746 string_char_byte_cache_string
= Qnil
;
749 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
752 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
755 EMACS_INT best_below
, best_below_byte
;
756 EMACS_INT best_above
, best_above_byte
;
758 best_below
= best_below_byte
= 0;
759 best_above
= SCHARS (string
);
760 best_above_byte
= SBYTES (string
);
761 if (best_above
== best_above_byte
)
764 if (EQ (string
, string_char_byte_cache_string
))
766 if (string_char_byte_cache_charpos
< char_index
)
768 best_below
= string_char_byte_cache_charpos
;
769 best_below_byte
= string_char_byte_cache_bytepos
;
773 best_above
= string_char_byte_cache_charpos
;
774 best_above_byte
= string_char_byte_cache_bytepos
;
778 if (char_index
- best_below
< best_above
- char_index
)
780 unsigned char *p
= SDATA (string
) + best_below_byte
;
782 while (best_below
< char_index
)
784 p
+= BYTES_BY_CHAR_HEAD (*p
);
787 i_byte
= p
- SDATA (string
);
791 unsigned char *p
= SDATA (string
) + best_above_byte
;
793 while (best_above
> char_index
)
796 while (!CHAR_HEAD_P (*p
)) p
--;
799 i_byte
= p
- SDATA (string
);
802 string_char_byte_cache_bytepos
= i_byte
;
803 string_char_byte_cache_charpos
= char_index
;
804 string_char_byte_cache_string
= string
;
809 /* Return the character index corresponding to BYTE_INDEX in STRING. */
812 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
815 EMACS_INT best_below
, best_below_byte
;
816 EMACS_INT best_above
, best_above_byte
;
818 best_below
= best_below_byte
= 0;
819 best_above
= SCHARS (string
);
820 best_above_byte
= SBYTES (string
);
821 if (best_above
== best_above_byte
)
824 if (EQ (string
, string_char_byte_cache_string
))
826 if (string_char_byte_cache_bytepos
< byte_index
)
828 best_below
= string_char_byte_cache_charpos
;
829 best_below_byte
= string_char_byte_cache_bytepos
;
833 best_above
= string_char_byte_cache_charpos
;
834 best_above_byte
= string_char_byte_cache_bytepos
;
838 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
840 unsigned char *p
= SDATA (string
) + best_below_byte
;
841 unsigned char *pend
= SDATA (string
) + byte_index
;
845 p
+= BYTES_BY_CHAR_HEAD (*p
);
849 i_byte
= p
- SDATA (string
);
853 unsigned char *p
= SDATA (string
) + best_above_byte
;
854 unsigned char *pbeg
= SDATA (string
) + byte_index
;
859 while (!CHAR_HEAD_P (*p
)) p
--;
863 i_byte
= p
- SDATA (string
);
866 string_char_byte_cache_bytepos
= i_byte
;
867 string_char_byte_cache_charpos
= i
;
868 string_char_byte_cache_string
= string
;
873 /* Convert STRING to a multibyte string. */
876 string_make_multibyte (Lisp_Object string
)
883 if (STRING_MULTIBYTE (string
))
886 nbytes
= count_size_as_multibyte (SDATA (string
),
888 /* If all the chars are ASCII, they won't need any more bytes
889 once converted. In that case, we can return STRING itself. */
890 if (nbytes
== SBYTES (string
))
893 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
894 copy_text (SDATA (string
), buf
, SBYTES (string
),
897 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
904 /* Convert STRING (if unibyte) to a multibyte string without changing
905 the number of characters. Characters 0200 trough 0237 are
906 converted to eight-bit characters. */
909 string_to_multibyte (Lisp_Object string
)
916 if (STRING_MULTIBYTE (string
))
919 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
920 /* If all the chars are ASCII, they won't need any more bytes once
922 if (nbytes
== SBYTES (string
))
923 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
925 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
926 memcpy (buf
, SDATA (string
), SBYTES (string
));
927 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
929 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
936 /* Convert STRING to a single-byte string. */
939 string_make_unibyte (Lisp_Object string
)
946 if (! STRING_MULTIBYTE (string
))
949 nchars
= SCHARS (string
);
951 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
952 copy_text (SDATA (string
), buf
, SBYTES (string
),
955 ret
= make_unibyte_string (buf
, nchars
);
961 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
963 doc
: /* Return the multibyte equivalent of STRING.
964 If STRING is unibyte and contains non-ASCII characters, the function
965 `unibyte-char-to-multibyte' is used to convert each unibyte character
966 to a multibyte character. In this case, the returned string is a
967 newly created string with no text properties. If STRING is multibyte
968 or entirely ASCII, it is returned unchanged. In particular, when
969 STRING is unibyte and entirely ASCII, the returned string is unibyte.
970 \(When the characters are all ASCII, Emacs primitives will treat the
971 string the same way whether it is unibyte or multibyte.) */)
974 CHECK_STRING (string
);
976 return string_make_multibyte (string
);
979 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
981 doc
: /* Return the unibyte equivalent of STRING.
982 Multibyte character codes are converted to unibyte according to
983 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
984 If the lookup in the translation table fails, this function takes just
985 the low 8 bits of each character. */)
988 CHECK_STRING (string
);
990 return string_make_unibyte (string
);
993 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
995 doc
: /* Return a unibyte string with the same individual bytes as STRING.
996 If STRING is unibyte, the result is STRING itself.
997 Otherwise it is a newly created string, with no text properties.
998 If STRING is multibyte and contains a character of charset
999 `eight-bit', it is converted to the corresponding single byte. */)
1000 (Lisp_Object string
)
1002 CHECK_STRING (string
);
1004 if (STRING_MULTIBYTE (string
))
1006 int bytes
= SBYTES (string
);
1007 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1009 memcpy (str
, SDATA (string
), bytes
);
1010 bytes
= str_as_unibyte (str
, bytes
);
1011 string
= make_unibyte_string (str
, bytes
);
1017 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1019 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1020 If STRING is multibyte, the result is STRING itself.
1021 Otherwise it is a newly created string, with no text properties.
1023 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1024 part of a correct utf-8 sequence), it is converted to the corresponding
1025 multibyte character of charset `eight-bit'.
1026 See also `string-to-multibyte'.
1028 Beware, this often doesn't really do what you think it does.
1029 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1030 If you're not sure, whether to use `string-as-multibyte' or
1031 `string-to-multibyte', use `string-to-multibyte'. */)
1032 (Lisp_Object string
)
1034 CHECK_STRING (string
);
1036 if (! STRING_MULTIBYTE (string
))
1038 Lisp_Object new_string
;
1041 parse_str_as_multibyte (SDATA (string
),
1044 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1045 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1046 if (nbytes
!= SBYTES (string
))
1047 str_as_multibyte (SDATA (new_string
), nbytes
,
1048 SBYTES (string
), NULL
);
1049 string
= new_string
;
1050 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1055 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1057 doc
: /* Return a multibyte string with the same individual chars as STRING.
1058 If STRING is multibyte, the result is STRING itself.
1059 Otherwise it is a newly created string, with no text properties.
1061 If STRING is unibyte and contains an 8-bit byte, it is converted to
1062 the corresponding multibyte character of charset `eight-bit'.
1064 This differs from `string-as-multibyte' by converting each byte of a correct
1065 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1066 correct sequence. */)
1067 (Lisp_Object string
)
1069 CHECK_STRING (string
);
1071 return string_to_multibyte (string
);
1074 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1076 doc
: /* Return a unibyte string with the same individual chars as STRING.
1077 If STRING is unibyte, the result is STRING itself.
1078 Otherwise it is a newly created string, with no text properties,
1079 where each `eight-bit' character is converted to the corresponding byte.
1080 If STRING contains a non-ASCII, non-`eight-bit' character,
1081 an error is signaled. */)
1082 (Lisp_Object string
)
1084 CHECK_STRING (string
);
1086 if (STRING_MULTIBYTE (string
))
1088 EMACS_INT chars
= SCHARS (string
);
1089 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1090 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1092 if (converted
< chars
)
1093 error ("Can't convert the %dth character to unibyte", converted
);
1094 string
= make_unibyte_string (str
, chars
);
1101 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1102 doc
: /* Return a copy of ALIST.
1103 This is an alist which represents the same mapping from objects to objects,
1104 but does not share the alist structure with ALIST.
1105 The objects mapped (cars and cdrs of elements of the alist)
1106 are shared, however.
1107 Elements of ALIST that are not conses are also shared. */)
1110 register Lisp_Object tem
;
1115 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1116 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1118 register Lisp_Object car
;
1122 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1127 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1128 doc
: /* Return a new string whose contents are a substring of STRING.
1129 The returned string consists of the characters between index FROM
1130 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1131 zero-indexed: 0 means the first character of STRING. Negative values
1132 are counted from the end of STRING. If TO is nil, the substring runs
1133 to the end of STRING.
1135 The STRING argument may also be a vector. In that case, the return
1136 value is a new vector that contains the elements between index FROM
1137 \(inclusive) and index TO (exclusive) of that vector argument. */)
1138 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1143 int from_char
, to_char
;
1144 int from_byte
= 0, to_byte
= 0;
1146 CHECK_VECTOR_OR_STRING (string
);
1147 CHECK_NUMBER (from
);
1149 if (STRINGP (string
))
1151 size
= SCHARS (string
);
1152 size_byte
= SBYTES (string
);
1155 size
= ASIZE (string
);
1160 to_byte
= size_byte
;
1166 to_char
= XINT (to
);
1170 if (STRINGP (string
))
1171 to_byte
= string_char_to_byte (string
, to_char
);
1174 from_char
= XINT (from
);
1177 if (STRINGP (string
))
1178 from_byte
= string_char_to_byte (string
, from_char
);
1180 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1181 args_out_of_range_3 (string
, make_number (from_char
),
1182 make_number (to_char
));
1184 if (STRINGP (string
))
1186 res
= make_specified_string (SDATA (string
) + from_byte
,
1187 to_char
- from_char
, to_byte
- from_byte
,
1188 STRING_MULTIBYTE (string
));
1189 copy_text_properties (make_number (from_char
), make_number (to_char
),
1190 string
, make_number (0), res
, Qnil
);
1193 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1199 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1200 doc
: /* Return a substring of STRING, without text properties.
1201 It starts at index FROM and ends before TO.
1202 TO may be nil or omitted; then the substring runs to the end of STRING.
1203 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1204 If FROM or TO is negative, it counts from the end.
1206 With one argument, just copy STRING without its properties. */)
1207 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1209 int size
, size_byte
;
1210 int from_char
, to_char
;
1211 int from_byte
, to_byte
;
1213 CHECK_STRING (string
);
1215 size
= SCHARS (string
);
1216 size_byte
= SBYTES (string
);
1219 from_char
= from_byte
= 0;
1222 CHECK_NUMBER (from
);
1223 from_char
= XINT (from
);
1227 from_byte
= string_char_to_byte (string
, from_char
);
1233 to_byte
= size_byte
;
1239 to_char
= XINT (to
);
1243 to_byte
= string_char_to_byte (string
, to_char
);
1246 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1247 args_out_of_range_3 (string
, make_number (from_char
),
1248 make_number (to_char
));
1250 return make_specified_string (SDATA (string
) + from_byte
,
1251 to_char
- from_char
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1255 /* Extract a substring of STRING, giving start and end positions
1256 both in characters and in bytes. */
1259 substring_both (Lisp_Object string
, int from
, int from_byte
, int to
, int to_byte
)
1265 CHECK_VECTOR_OR_STRING (string
);
1267 if (STRINGP (string
))
1269 size
= SCHARS (string
);
1270 size_byte
= SBYTES (string
);
1273 size
= ASIZE (string
);
1275 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1276 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1278 if (STRINGP (string
))
1280 res
= make_specified_string (SDATA (string
) + from_byte
,
1281 to
- from
, to_byte
- from_byte
,
1282 STRING_MULTIBYTE (string
));
1283 copy_text_properties (make_number (from
), make_number (to
),
1284 string
, make_number (0), res
, Qnil
);
1287 res
= Fvector (to
- from
, &AREF (string
, from
));
1292 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1293 doc
: /* Take cdr N times on LIST, return the result. */)
1294 (Lisp_Object n
, Lisp_Object list
)
1296 register int i
, num
;
1299 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1302 CHECK_LIST_CONS (list
, list
);
1308 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1309 doc
: /* Return the Nth element of LIST.
1310 N counts from zero. If LIST is not that long, nil is returned. */)
1311 (Lisp_Object n
, Lisp_Object list
)
1313 return Fcar (Fnthcdr (n
, list
));
1316 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1317 doc
: /* Return element of SEQUENCE at index N. */)
1318 (register Lisp_Object sequence
, Lisp_Object n
)
1321 if (CONSP (sequence
) || NILP (sequence
))
1322 return Fcar (Fnthcdr (n
, sequence
));
1324 /* Faref signals a "not array" error, so check here. */
1325 CHECK_ARRAY (sequence
, Qsequencep
);
1326 return Faref (sequence
, n
);
1329 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1330 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1331 The value is actually the tail of LIST whose car is ELT. */)
1332 (register Lisp_Object elt
, Lisp_Object list
)
1334 register Lisp_Object tail
;
1335 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1337 register Lisp_Object tem
;
1338 CHECK_LIST_CONS (tail
, list
);
1340 if (! NILP (Fequal (elt
, tem
)))
1347 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1348 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1349 The value is actually the tail of LIST whose car is ELT. */)
1350 (register Lisp_Object elt
, Lisp_Object list
)
1354 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1358 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1362 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1373 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1374 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1375 The value is actually the tail of LIST whose car is ELT. */)
1376 (register Lisp_Object elt
, Lisp_Object list
)
1378 register Lisp_Object tail
;
1381 return Fmemq (elt
, list
);
1383 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1385 register Lisp_Object tem
;
1386 CHECK_LIST_CONS (tail
, list
);
1388 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1395 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1396 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1397 The value is actually the first element of LIST whose car is KEY.
1398 Elements of LIST that are not conses are ignored. */)
1399 (Lisp_Object key
, Lisp_Object list
)
1404 || (CONSP (XCAR (list
))
1405 && EQ (XCAR (XCAR (list
)), key
)))
1410 || (CONSP (XCAR (list
))
1411 && EQ (XCAR (XCAR (list
)), key
)))
1416 || (CONSP (XCAR (list
))
1417 && EQ (XCAR (XCAR (list
)), key
)))
1427 /* Like Fassq but never report an error and do not allow quits.
1428 Use only on lists known never to be circular. */
1431 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1434 && (!CONSP (XCAR (list
))
1435 || !EQ (XCAR (XCAR (list
)), key
)))
1438 return CAR_SAFE (list
);
1441 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1442 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1443 The value is actually the first element of LIST whose car equals KEY. */)
1444 (Lisp_Object key
, Lisp_Object list
)
1451 || (CONSP (XCAR (list
))
1452 && (car
= XCAR (XCAR (list
)),
1453 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1458 || (CONSP (XCAR (list
))
1459 && (car
= XCAR (XCAR (list
)),
1460 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1465 || (CONSP (XCAR (list
))
1466 && (car
= XCAR (XCAR (list
)),
1467 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1477 /* Like Fassoc but never report an error and do not allow quits.
1478 Use only on lists known never to be circular. */
1481 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1484 && (!CONSP (XCAR (list
))
1485 || (!EQ (XCAR (XCAR (list
)), key
)
1486 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1489 return CONSP (list
) ? XCAR (list
) : Qnil
;
1492 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1493 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1494 The value is actually the first element of LIST whose cdr is KEY. */)
1495 (register Lisp_Object key
, Lisp_Object list
)
1500 || (CONSP (XCAR (list
))
1501 && EQ (XCDR (XCAR (list
)), key
)))
1506 || (CONSP (XCAR (list
))
1507 && EQ (XCDR (XCAR (list
)), key
)))
1512 || (CONSP (XCAR (list
))
1513 && EQ (XCDR (XCAR (list
)), key
)))
1523 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1524 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1525 The value is actually the first element of LIST whose cdr equals KEY. */)
1526 (Lisp_Object key
, Lisp_Object list
)
1533 || (CONSP (XCAR (list
))
1534 && (cdr
= XCDR (XCAR (list
)),
1535 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1540 || (CONSP (XCAR (list
))
1541 && (cdr
= XCDR (XCAR (list
)),
1542 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1547 || (CONSP (XCAR (list
))
1548 && (cdr
= XCDR (XCAR (list
)),
1549 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1559 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1560 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1561 The modified LIST is returned. Comparison is done with `eq'.
1562 If the first member of LIST is ELT, there is no way to remove it by side effect;
1563 therefore, write `(setq foo (delq element foo))'
1564 to be sure of changing the value of `foo'. */)
1565 (register Lisp_Object elt
, Lisp_Object list
)
1567 register Lisp_Object tail
, prev
;
1568 register Lisp_Object tem
;
1572 while (!NILP (tail
))
1574 CHECK_LIST_CONS (tail
, list
);
1581 Fsetcdr (prev
, XCDR (tail
));
1591 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1592 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1593 SEQ must be a list, a vector, or a string.
1594 The modified SEQ is returned. Comparison is done with `equal'.
1595 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1596 is not a side effect; it is simply using a different sequence.
1597 Therefore, write `(setq foo (delete element foo))'
1598 to be sure of changing the value of `foo'. */)
1599 (Lisp_Object elt
, Lisp_Object seq
)
1605 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1606 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1609 if (n
!= ASIZE (seq
))
1611 struct Lisp_Vector
*p
= allocate_vector (n
);
1613 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1614 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1615 p
->contents
[n
++] = AREF (seq
, i
);
1617 XSETVECTOR (seq
, p
);
1620 else if (STRINGP (seq
))
1622 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1625 for (i
= nchars
= nbytes
= ibyte
= 0;
1627 ++i
, ibyte
+= cbytes
)
1629 if (STRING_MULTIBYTE (seq
))
1631 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1632 cbytes
= CHAR_BYTES (c
);
1640 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1647 if (nchars
!= SCHARS (seq
))
1651 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1652 if (!STRING_MULTIBYTE (seq
))
1653 STRING_SET_UNIBYTE (tem
);
1655 for (i
= nchars
= nbytes
= ibyte
= 0;
1657 ++i
, ibyte
+= cbytes
)
1659 if (STRING_MULTIBYTE (seq
))
1661 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1662 cbytes
= CHAR_BYTES (c
);
1670 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1672 unsigned char *from
= SDATA (seq
) + ibyte
;
1673 unsigned char *to
= SDATA (tem
) + nbytes
;
1679 for (n
= cbytes
; n
--; )
1689 Lisp_Object tail
, prev
;
1691 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1693 CHECK_LIST_CONS (tail
, seq
);
1695 if (!NILP (Fequal (elt
, XCAR (tail
))))
1700 Fsetcdr (prev
, XCDR (tail
));
1711 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1712 doc
: /* Reverse LIST by modifying cdr pointers.
1713 Return the reversed list. */)
1716 register Lisp_Object prev
, tail
, next
;
1718 if (NILP (list
)) return list
;
1721 while (!NILP (tail
))
1724 CHECK_LIST_CONS (tail
, list
);
1726 Fsetcdr (tail
, prev
);
1733 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1734 doc
: /* Reverse LIST, copying. Return the reversed list.
1735 See also the function `nreverse', which is used more often. */)
1740 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1743 new = Fcons (XCAR (list
), new);
1745 CHECK_LIST_END (list
, list
);
1749 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1751 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1752 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1753 Returns the sorted list. LIST is modified by side effects.
1754 PREDICATE is called with two elements of LIST, and should return non-nil
1755 if the first element should sort before the second. */)
1756 (Lisp_Object list
, Lisp_Object predicate
)
1758 Lisp_Object front
, back
;
1759 register Lisp_Object len
, tem
;
1760 struct gcpro gcpro1
, gcpro2
;
1761 register int length
;
1764 len
= Flength (list
);
1765 length
= XINT (len
);
1769 XSETINT (len
, (length
/ 2) - 1);
1770 tem
= Fnthcdr (len
, list
);
1772 Fsetcdr (tem
, Qnil
);
1774 GCPRO2 (front
, back
);
1775 front
= Fsort (front
, predicate
);
1776 back
= Fsort (back
, predicate
);
1778 return merge (front
, back
, predicate
);
1782 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1785 register Lisp_Object tail
;
1787 register Lisp_Object l1
, l2
;
1788 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1795 /* It is sufficient to protect org_l1 and org_l2.
1796 When l1 and l2 are updated, we copy the new values
1797 back into the org_ vars. */
1798 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1818 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1834 Fsetcdr (tail
, tem
);
1840 /* This does not check for quits. That is safe since it must terminate. */
1842 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1843 doc
: /* Extract a value from a property list.
1844 PLIST is a property list, which is a list of the form
1845 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1846 corresponding to the given PROP, or nil if PROP is not one of the
1847 properties on the list. This function never signals an error. */)
1848 (Lisp_Object plist
, Lisp_Object prop
)
1850 Lisp_Object tail
, halftail
;
1852 /* halftail is used to detect circular lists. */
1853 tail
= halftail
= plist
;
1854 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1856 if (EQ (prop
, XCAR (tail
)))
1857 return XCAR (XCDR (tail
));
1859 tail
= XCDR (XCDR (tail
));
1860 halftail
= XCDR (halftail
);
1861 if (EQ (tail
, halftail
))
1864 #if 0 /* Unsafe version. */
1865 /* This function can be called asynchronously
1866 (setup_coding_system). Don't QUIT in that case. */
1867 if (!interrupt_input_blocked
)
1875 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1876 doc
: /* Return the value of SYMBOL's PROPNAME property.
1877 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1878 (Lisp_Object symbol
, Lisp_Object propname
)
1880 CHECK_SYMBOL (symbol
);
1881 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1884 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1885 doc
: /* Change value in PLIST of PROP to VAL.
1886 PLIST is a property list, which is a list of the form
1887 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1888 If PROP is already a property on the list, its value is set to VAL,
1889 otherwise the new PROP VAL pair is added. The new plist is returned;
1890 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1891 The PLIST is modified by side effects. */)
1892 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1894 register Lisp_Object tail
, prev
;
1895 Lisp_Object newcell
;
1897 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1898 tail
= XCDR (XCDR (tail
)))
1900 if (EQ (prop
, XCAR (tail
)))
1902 Fsetcar (XCDR (tail
), val
);
1909 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1913 Fsetcdr (XCDR (prev
), newcell
);
1917 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1918 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1919 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1920 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1922 CHECK_SYMBOL (symbol
);
1923 XSYMBOL (symbol
)->plist
1924 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1928 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1929 doc
: /* Extract a value from a property list, comparing with `equal'.
1930 PLIST is a property list, which is a list of the form
1931 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1932 corresponding to the given PROP, or nil if PROP is not
1933 one of the properties on the list. */)
1934 (Lisp_Object plist
, Lisp_Object prop
)
1939 CONSP (tail
) && CONSP (XCDR (tail
));
1940 tail
= XCDR (XCDR (tail
)))
1942 if (! NILP (Fequal (prop
, XCAR (tail
))))
1943 return XCAR (XCDR (tail
));
1948 CHECK_LIST_END (tail
, prop
);
1953 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1954 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1955 PLIST is a property list, which is a list of the form
1956 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1957 If PROP is already a property on the list, its value is set to VAL,
1958 otherwise the new PROP VAL pair is added. The new plist is returned;
1959 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1960 The PLIST is modified by side effects. */)
1961 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1963 register Lisp_Object tail
, prev
;
1964 Lisp_Object newcell
;
1966 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1967 tail
= XCDR (XCDR (tail
)))
1969 if (! NILP (Fequal (prop
, XCAR (tail
))))
1971 Fsetcar (XCDR (tail
), val
);
1978 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1982 Fsetcdr (XCDR (prev
), newcell
);
1986 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1987 doc
: /* Return t if the two args are the same Lisp object.
1988 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1989 (Lisp_Object obj1
, Lisp_Object obj2
)
1992 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1994 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1997 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1998 doc
: /* Return t if two Lisp objects have similar structure and contents.
1999 They must have the same data type.
2000 Conses are compared by comparing the cars and the cdrs.
2001 Vectors and strings are compared element by element.
2002 Numbers are compared by value, but integers cannot equal floats.
2003 (Use `=' if you want integers and floats to be able to be equal.)
2004 Symbols must match exactly. */)
2005 (register Lisp_Object o1
, Lisp_Object o2
)
2007 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2010 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2011 doc
: /* Return t if two Lisp objects have similar structure and contents.
2012 This is like `equal' except that it compares the text properties
2013 of strings. (`equal' ignores text properties.) */)
2014 (register Lisp_Object o1
, Lisp_Object o2
)
2016 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2019 /* DEPTH is current depth of recursion. Signal an error if it
2021 PROPS, if non-nil, means compare string text properties too. */
2024 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2027 error ("Stack overflow in equal");
2033 if (XTYPE (o1
) != XTYPE (o2
))
2042 d1
= extract_float (o1
);
2043 d2
= extract_float (o2
);
2044 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2045 though they are not =. */
2046 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2050 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2057 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2061 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2063 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2066 o1
= XOVERLAY (o1
)->plist
;
2067 o2
= XOVERLAY (o2
)->plist
;
2072 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2073 && (XMARKER (o1
)->buffer
== 0
2074 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2078 case Lisp_Vectorlike
:
2081 EMACS_INT size
= ASIZE (o1
);
2082 /* Pseudovectors have the type encoded in the size field, so this test
2083 actually checks that the objects have the same type as well as the
2085 if (ASIZE (o2
) != size
)
2087 /* Boolvectors are compared much like strings. */
2088 if (BOOL_VECTOR_P (o1
))
2091 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2092 / BOOL_VECTOR_BITS_PER_CHAR
);
2094 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2096 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2101 if (WINDOW_CONFIGURATIONP (o1
))
2102 return compare_window_configurations (o1
, o2
, 0);
2104 /* Aside from them, only true vectors, char-tables, compiled
2105 functions, and fonts (font-spec, font-entity, font-ojbect)
2106 are sensible to compare, so eliminate the others now. */
2107 if (size
& PSEUDOVECTOR_FLAG
)
2109 if (!(size
& (PVEC_COMPILED
2110 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2112 size
&= PSEUDOVECTOR_SIZE_MASK
;
2114 for (i
= 0; i
< size
; i
++)
2119 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2127 if (SCHARS (o1
) != SCHARS (o2
))
2129 if (SBYTES (o1
) != SBYTES (o2
))
2131 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2133 if (props
&& !compare_string_intervals (o1
, o2
))
2145 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2146 doc
: /* Store each element of ARRAY with ITEM.
2147 ARRAY is a vector, string, char-table, or bool-vector. */)
2148 (Lisp_Object array
, Lisp_Object item
)
2150 register int size
, index
, charval
;
2151 if (VECTORP (array
))
2153 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2154 size
= ASIZE (array
);
2155 for (index
= 0; index
< size
; index
++)
2158 else if (CHAR_TABLE_P (array
))
2162 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2163 XCHAR_TABLE (array
)->contents
[i
] = item
;
2164 XCHAR_TABLE (array
)->defalt
= item
;
2166 else if (STRINGP (array
))
2168 register unsigned char *p
= SDATA (array
);
2169 CHECK_NUMBER (item
);
2170 charval
= XINT (item
);
2171 size
= SCHARS (array
);
2172 if (STRING_MULTIBYTE (array
))
2174 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2175 int len
= CHAR_STRING (charval
, str
);
2176 int size_byte
= SBYTES (array
);
2177 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2180 if (size
!= size_byte
)
2183 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2184 if (len
!= this_len
)
2185 error ("Attempt to change byte length of a string");
2188 for (i
= 0; i
< size_byte
; i
++)
2189 *p
++ = str
[i
% len
];
2192 for (index
= 0; index
< size
; index
++)
2195 else if (BOOL_VECTOR_P (array
))
2197 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2199 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2200 / BOOL_VECTOR_BITS_PER_CHAR
);
2202 charval
= (! NILP (item
) ? -1 : 0);
2203 for (index
= 0; index
< size_in_chars
- 1; index
++)
2205 if (index
< size_in_chars
)
2207 /* Mask out bits beyond the vector size. */
2208 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2209 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2214 wrong_type_argument (Qarrayp
, array
);
2218 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2220 doc
: /* Clear the contents of STRING.
2221 This makes STRING unibyte and may change its length. */)
2222 (Lisp_Object string
)
2225 CHECK_STRING (string
);
2226 len
= SBYTES (string
);
2227 memset (SDATA (string
), 0, len
);
2228 STRING_SET_CHARS (string
, len
);
2229 STRING_SET_UNIBYTE (string
);
2235 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2237 Lisp_Object args
[2];
2240 return Fnconc (2, args
);
2243 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2244 doc
: /* Concatenate any number of lists by altering them.
2245 Only the last argument is not altered, and need not be a list.
2246 usage: (nconc &rest LISTS) */)
2247 (int nargs
, Lisp_Object
*args
)
2249 register int argnum
;
2250 register Lisp_Object tail
, tem
, val
;
2254 for (argnum
= 0; argnum
< nargs
; argnum
++)
2257 if (NILP (tem
)) continue;
2262 if (argnum
+ 1 == nargs
) break;
2264 CHECK_LIST_CONS (tem
, tem
);
2273 tem
= args
[argnum
+ 1];
2274 Fsetcdr (tail
, tem
);
2276 args
[argnum
+ 1] = tail
;
2282 /* This is the guts of all mapping functions.
2283 Apply FN to each element of SEQ, one by one,
2284 storing the results into elements of VALS, a C vector of Lisp_Objects.
2285 LENI is the length of VALS, which should also be the length of SEQ. */
2288 mapcar1 (int leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2290 register Lisp_Object tail
;
2293 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2297 /* Don't let vals contain any garbage when GC happens. */
2298 for (i
= 0; i
< leni
; i
++)
2301 GCPRO3 (dummy
, fn
, seq
);
2303 gcpro1
.nvars
= leni
;
2307 /* We need not explicitly protect `tail' because it is used only on lists, and
2308 1) lists are not relocated and 2) the list is marked via `seq' so will not
2313 for (i
= 0; i
< leni
; i
++)
2315 dummy
= call1 (fn
, AREF (seq
, i
));
2320 else if (BOOL_VECTOR_P (seq
))
2322 for (i
= 0; i
< leni
; i
++)
2325 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2326 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2327 dummy
= call1 (fn
, dummy
);
2332 else if (STRINGP (seq
))
2336 for (i
= 0, i_byte
= 0; i
< leni
;)
2341 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2342 XSETFASTINT (dummy
, c
);
2343 dummy
= call1 (fn
, dummy
);
2345 vals
[i_before
] = dummy
;
2348 else /* Must be a list, since Flength did not get an error */
2351 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2353 dummy
= call1 (fn
, XCAR (tail
));
2363 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2364 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2365 In between each pair of results, stick in SEPARATOR. Thus, " " as
2366 SEPARATOR results in spaces between the values returned by FUNCTION.
2367 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2368 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2373 register Lisp_Object
*args
;
2375 struct gcpro gcpro1
;
2379 len
= Flength (sequence
);
2380 if (CHAR_TABLE_P (sequence
))
2381 wrong_type_argument (Qlistp
, sequence
);
2383 nargs
= leni
+ leni
- 1;
2384 if (nargs
< 0) return empty_unibyte_string
;
2386 SAFE_ALLOCA_LISP (args
, nargs
);
2389 mapcar1 (leni
, args
, function
, sequence
);
2392 for (i
= leni
- 1; i
> 0; i
--)
2393 args
[i
+ i
] = args
[i
];
2395 for (i
= 1; i
< nargs
; i
+= 2)
2396 args
[i
] = separator
;
2398 ret
= Fconcat (nargs
, args
);
2404 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2405 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2406 The result is a list just as long as SEQUENCE.
2407 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2408 (Lisp_Object function
, Lisp_Object sequence
)
2410 register Lisp_Object len
;
2412 register Lisp_Object
*args
;
2416 len
= Flength (sequence
);
2417 if (CHAR_TABLE_P (sequence
))
2418 wrong_type_argument (Qlistp
, sequence
);
2419 leni
= XFASTINT (len
);
2421 SAFE_ALLOCA_LISP (args
, leni
);
2423 mapcar1 (leni
, args
, function
, sequence
);
2425 ret
= Flist (leni
, args
);
2431 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2432 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2433 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2434 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2435 (Lisp_Object function
, Lisp_Object sequence
)
2439 leni
= XFASTINT (Flength (sequence
));
2440 if (CHAR_TABLE_P (sequence
))
2441 wrong_type_argument (Qlistp
, sequence
);
2442 mapcar1 (leni
, 0, function
, sequence
);
2447 /* Anything that calls this function must protect from GC! */
2449 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2450 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2451 Takes one argument, which is the string to display to ask the question.
2452 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2453 No confirmation of the answer is requested; a single character is enough.
2454 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2455 the bindings in `query-replace-map'; see the documentation of that variable
2456 for more information. In this case, the useful bindings are `act', `skip',
2457 `recenter', and `quit'.\)
2459 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2460 is nil and `use-dialog-box' is non-nil. */)
2461 (Lisp_Object prompt
)
2463 register Lisp_Object obj
, key
, def
, map
;
2464 register int answer
;
2465 Lisp_Object xprompt
;
2466 Lisp_Object args
[2];
2467 struct gcpro gcpro1
, gcpro2
;
2468 int count
= SPECPDL_INDEX ();
2470 specbind (Qcursor_in_echo_area
, Qt
);
2472 map
= Fsymbol_value (intern ("query-replace-map"));
2474 CHECK_STRING (prompt
);
2476 GCPRO2 (prompt
, xprompt
);
2478 #ifdef HAVE_WINDOW_SYSTEM
2479 if (display_hourglass_p
)
2480 cancel_hourglass ();
2487 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2488 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2492 Lisp_Object pane
, menu
;
2493 redisplay_preserve_echo_area (3);
2494 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2495 Fcons (Fcons (build_string ("No"), Qnil
),
2497 menu
= Fcons (prompt
, pane
);
2498 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2499 answer
= !NILP (obj
);
2502 #endif /* HAVE_MENUS */
2503 cursor_in_echo_area
= 1;
2504 choose_minibuf_frame ();
2507 Lisp_Object pargs
[3];
2509 /* Colorize prompt according to `minibuffer-prompt' face. */
2510 pargs
[0] = build_string ("%s(y or n) ");
2511 pargs
[1] = intern ("face");
2512 pargs
[2] = intern ("minibuffer-prompt");
2513 args
[0] = Fpropertize (3, pargs
);
2518 if (minibuffer_auto_raise
)
2520 Lisp_Object mini_frame
;
2522 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2524 Fraise_frame (mini_frame
);
2527 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2528 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2529 cursor_in_echo_area
= 0;
2530 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2533 key
= Fmake_vector (make_number (1), obj
);
2534 def
= Flookup_key (map
, key
, Qt
);
2536 if (EQ (def
, intern ("skip")))
2541 else if (EQ (def
, intern ("act")))
2546 else if (EQ (def
, intern ("recenter")))
2552 else if (EQ (def
, intern ("quit")))
2554 /* We want to exit this command for exit-prefix,
2555 and this is the only way to do it. */
2556 else if (EQ (def
, intern ("exit-prefix")))
2561 /* If we don't clear this, then the next call to read_char will
2562 return quit_char again, and we'll enter an infinite loop. */
2567 if (EQ (xprompt
, prompt
))
2569 args
[0] = build_string ("Please answer y or n. ");
2571 xprompt
= Fconcat (2, args
);
2576 if (! noninteractive
)
2578 cursor_in_echo_area
= -1;
2579 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2583 unbind_to (count
, Qnil
);
2584 return answer
? Qt
: Qnil
;
2587 /* This is how C code calls `yes-or-no-p' and allows the user
2590 Anything that calls this function must protect from GC! */
2593 do_yes_or_no_p (Lisp_Object prompt
)
2595 return call1 (intern ("yes-or-no-p"), prompt
);
2598 /* Anything that calls this function must protect from GC! */
2600 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2601 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2602 Takes one argument, which is the string to display to ask the question.
2603 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2604 The user must confirm the answer with RET,
2605 and can edit it until it has been confirmed.
2607 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2608 is nil, and `use-dialog-box' is non-nil. */)
2609 (Lisp_Object prompt
)
2611 register Lisp_Object ans
;
2612 Lisp_Object args
[2];
2613 struct gcpro gcpro1
;
2615 CHECK_STRING (prompt
);
2618 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2619 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2623 Lisp_Object pane
, menu
, obj
;
2624 redisplay_preserve_echo_area (4);
2625 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2626 Fcons (Fcons (build_string ("No"), Qnil
),
2629 menu
= Fcons (prompt
, pane
);
2630 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2634 #endif /* HAVE_MENUS */
2637 args
[1] = build_string ("(yes or no) ");
2638 prompt
= Fconcat (2, args
);
2644 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2645 Qyes_or_no_p_history
, Qnil
,
2647 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2652 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2660 message ("Please answer yes or no.");
2661 Fsleep_for (make_number (2), Qnil
);
2665 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2666 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2668 Each of the three load averages is multiplied by 100, then converted
2671 When USE-FLOATS is non-nil, floats will be used instead of integers.
2672 These floats are not multiplied by 100.
2674 If the 5-minute or 15-minute load averages are not available, return a
2675 shortened list, containing only those averages which are available.
2677 An error is thrown if the load average can't be obtained. In some
2678 cases making it work would require Emacs being installed setuid or
2679 setgid so that it can read kernel information, and that usually isn't
2681 (Lisp_Object use_floats
)
2684 int loads
= getloadavg (load_ave
, 3);
2685 Lisp_Object ret
= Qnil
;
2688 error ("load-average not implemented for this operating system");
2692 Lisp_Object load
= (NILP (use_floats
) ?
2693 make_number ((int) (100.0 * load_ave
[loads
]))
2694 : make_float (load_ave
[loads
]));
2695 ret
= Fcons (load
, ret
);
2701 Lisp_Object Vfeatures
, Qsubfeatures
;
2703 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2704 doc
: /* Return t if FEATURE is present in this Emacs.
2706 Use this to conditionalize execution of lisp code based on the
2707 presence or absence of Emacs or environment extensions.
2708 Use `provide' to declare that a feature is available. This function
2709 looks at the value of the variable `features'. The optional argument
2710 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2711 (Lisp_Object feature
, Lisp_Object subfeature
)
2713 register Lisp_Object tem
;
2714 CHECK_SYMBOL (feature
);
2715 tem
= Fmemq (feature
, Vfeatures
);
2716 if (!NILP (tem
) && !NILP (subfeature
))
2717 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2718 return (NILP (tem
)) ? Qnil
: Qt
;
2721 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2722 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2723 The optional argument SUBFEATURES should be a list of symbols listing
2724 particular subfeatures supported in this version of FEATURE. */)
2725 (Lisp_Object feature
, Lisp_Object subfeatures
)
2727 register Lisp_Object tem
;
2728 CHECK_SYMBOL (feature
);
2729 CHECK_LIST (subfeatures
);
2730 if (!NILP (Vautoload_queue
))
2731 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2733 tem
= Fmemq (feature
, Vfeatures
);
2735 Vfeatures
= Fcons (feature
, Vfeatures
);
2736 if (!NILP (subfeatures
))
2737 Fput (feature
, Qsubfeatures
, subfeatures
);
2738 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2740 /* Run any load-hooks for this file. */
2741 tem
= Fassq (feature
, Vafter_load_alist
);
2743 Fprogn (XCDR (tem
));
2748 /* `require' and its subroutines. */
2750 /* List of features currently being require'd, innermost first. */
2752 Lisp_Object require_nesting_list
;
2755 require_unwind (Lisp_Object old_value
)
2757 return require_nesting_list
= old_value
;
2760 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2761 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2762 If FEATURE is not a member of the list `features', then the feature
2763 is not loaded; so load the file FILENAME.
2764 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2765 and `load' will try to load this name appended with the suffix `.elc' or
2766 `.el', in that order. The name without appended suffix will not be used.
2767 If the optional third argument NOERROR is non-nil,
2768 then return nil if the file is not found instead of signaling an error.
2769 Normally the return value is FEATURE.
2770 The normal messages at start and end of loading FILENAME are suppressed. */)
2771 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2773 register Lisp_Object tem
;
2774 struct gcpro gcpro1
, gcpro2
;
2775 int from_file
= load_in_progress
;
2777 CHECK_SYMBOL (feature
);
2779 /* Record the presence of `require' in this file
2780 even if the feature specified is already loaded.
2781 But not more than once in any file,
2782 and not when we aren't loading or reading from a file. */
2784 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2785 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2790 tem
= Fcons (Qrequire
, feature
);
2791 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2792 LOADHIST_ATTACH (tem
);
2794 tem
= Fmemq (feature
, Vfeatures
);
2798 int count
= SPECPDL_INDEX ();
2801 /* This is to make sure that loadup.el gives a clear picture
2802 of what files are preloaded and when. */
2803 if (! NILP (Vpurify_flag
))
2804 error ("(require %s) while preparing to dump",
2805 SDATA (SYMBOL_NAME (feature
)));
2807 /* A certain amount of recursive `require' is legitimate,
2808 but if we require the same feature recursively 3 times,
2810 tem
= require_nesting_list
;
2811 while (! NILP (tem
))
2813 if (! NILP (Fequal (feature
, XCAR (tem
))))
2818 error ("Recursive `require' for feature `%s'",
2819 SDATA (SYMBOL_NAME (feature
)));
2821 /* Update the list for any nested `require's that occur. */
2822 record_unwind_protect (require_unwind
, require_nesting_list
);
2823 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2825 /* Value saved here is to be restored into Vautoload_queue */
2826 record_unwind_protect (un_autoload
, Vautoload_queue
);
2827 Vautoload_queue
= Qt
;
2829 /* Load the file. */
2830 GCPRO2 (feature
, filename
);
2831 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2832 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2835 /* If load failed entirely, return nil. */
2837 return unbind_to (count
, Qnil
);
2839 tem
= Fmemq (feature
, Vfeatures
);
2841 error ("Required feature `%s' was not provided",
2842 SDATA (SYMBOL_NAME (feature
)));
2844 /* Once loading finishes, don't undo it. */
2845 Vautoload_queue
= Qt
;
2846 feature
= unbind_to (count
, feature
);
2852 /* Primitives for work of the "widget" library.
2853 In an ideal world, this section would not have been necessary.
2854 However, lisp function calls being as slow as they are, it turns
2855 out that some functions in the widget library (wid-edit.el) are the
2856 bottleneck of Widget operation. Here is their translation to C,
2857 for the sole reason of efficiency. */
2859 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2860 doc
: /* Return non-nil if PLIST has the property PROP.
2861 PLIST is a property list, which is a list of the form
2862 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2863 Unlike `plist-get', this allows you to distinguish between a missing
2864 property and a property with the value nil.
2865 The value is actually the tail of PLIST whose car is PROP. */)
2866 (Lisp_Object plist
, Lisp_Object prop
)
2868 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2871 plist
= XCDR (plist
);
2872 plist
= CDR (plist
);
2877 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2878 doc
: /* In WIDGET, set PROPERTY to VALUE.
2879 The value can later be retrieved with `widget-get'. */)
2880 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2882 CHECK_CONS (widget
);
2883 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2887 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2888 doc
: /* In WIDGET, get the value of PROPERTY.
2889 The value could either be specified when the widget was created, or
2890 later with `widget-put'. */)
2891 (Lisp_Object widget
, Lisp_Object property
)
2899 CHECK_CONS (widget
);
2900 tmp
= Fplist_member (XCDR (widget
), property
);
2906 tmp
= XCAR (widget
);
2909 widget
= Fget (tmp
, Qwidget_type
);
2913 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2914 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2915 ARGS are passed as extra arguments to the function.
2916 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2917 (int nargs
, Lisp_Object
*args
)
2919 /* This function can GC. */
2920 Lisp_Object newargs
[3];
2921 struct gcpro gcpro1
, gcpro2
;
2924 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2925 newargs
[1] = args
[0];
2926 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2927 GCPRO2 (newargs
[0], newargs
[2]);
2928 result
= Fapply (3, newargs
);
2933 #ifdef HAVE_LANGINFO_CODESET
2934 #include <langinfo.h>
2937 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2938 doc
: /* Access locale data ITEM for the current C locale, if available.
2939 ITEM should be one of the following:
2941 `codeset', returning the character set as a string (locale item CODESET);
2943 `days', returning a 7-element vector of day names (locale items DAY_n);
2945 `months', returning a 12-element vector of month names (locale items MON_n);
2947 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2948 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2950 If the system can't provide such information through a call to
2951 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2953 See also Info node `(libc)Locales'.
2955 The data read from the system are decoded using `locale-coding-system'. */)
2959 #ifdef HAVE_LANGINFO_CODESET
2961 if (EQ (item
, Qcodeset
))
2963 str
= nl_langinfo (CODESET
);
2964 return build_string (str
);
2967 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2969 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2970 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2972 struct gcpro gcpro1
;
2974 synchronize_system_time_locale ();
2975 for (i
= 0; i
< 7; i
++)
2977 str
= nl_langinfo (days
[i
]);
2978 val
= make_unibyte_string (str
, strlen (str
));
2979 /* Fixme: Is this coding system necessarily right, even if
2980 it is consistent with CODESET? If not, what to do? */
2981 Faset (v
, make_number (i
),
2982 code_convert_string_norecord (val
, Vlocale_coding_system
,
2990 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2992 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2993 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2994 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2996 struct gcpro gcpro1
;
2998 synchronize_system_time_locale ();
2999 for (i
= 0; i
< 12; i
++)
3001 str
= nl_langinfo (months
[i
]);
3002 val
= make_unibyte_string (str
, strlen (str
));
3003 Faset (v
, make_number (i
),
3004 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3010 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3011 but is in the locale files. This could be used by ps-print. */
3013 else if (EQ (item
, Qpaper
))
3015 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3016 make_number (nl_langinfo (PAPER_HEIGHT
)));
3018 #endif /* PAPER_WIDTH */
3019 #endif /* HAVE_LANGINFO_CODESET*/
3023 /* base64 encode/decode functions (RFC 2045).
3024 Based on code from GNU recode. */
3026 #define MIME_LINE_LENGTH 76
3028 #define IS_ASCII(Character) \
3030 #define IS_BASE64(Character) \
3031 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3032 #define IS_BASE64_IGNORABLE(Character) \
3033 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3034 || (Character) == '\f' || (Character) == '\r')
3036 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3037 character or return retval if there are no characters left to
3039 #define READ_QUADRUPLET_BYTE(retval) \
3044 if (nchars_return) \
3045 *nchars_return = nchars; \
3050 while (IS_BASE64_IGNORABLE (c))
3052 /* Table of characters coding the 64 values. */
3053 static const char base64_value_to_char
[64] =
3055 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3056 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3057 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3058 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3059 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3060 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3061 '8', '9', '+', '/' /* 60-63 */
3064 /* Table of base64 values for first 128 characters. */
3065 static const short base64_char_to_value
[128] =
3067 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3068 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3069 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3070 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3071 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3072 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3073 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3074 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3075 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3076 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3077 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3078 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3079 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3082 /* The following diagram shows the logical steps by which three octets
3083 get transformed into four base64 characters.
3085 .--------. .--------. .--------.
3086 |aaaaaabb| |bbbbcccc| |ccdddddd|
3087 `--------' `--------' `--------'
3089 .--------+--------+--------+--------.
3090 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3091 `--------+--------+--------+--------'
3093 .--------+--------+--------+--------.
3094 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3095 `--------+--------+--------+--------'
3097 The octets are divided into 6 bit chunks, which are then encoded into
3098 base64 characters. */
3101 static int base64_encode_1 (const char *, char *, int, int, int);
3102 static int base64_decode_1 (const char *, char *, int, int, int *);
3104 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3106 doc
: /* Base64-encode the region between BEG and END.
3107 Return the length of the encoded text.
3108 Optional third argument NO-LINE-BREAK means do not break long lines
3109 into shorter lines. */)
3110 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3113 int allength
, length
;
3114 int ibeg
, iend
, encoded_length
;
3118 validate_region (&beg
, &end
);
3120 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3121 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3122 move_gap_both (XFASTINT (beg
), ibeg
);
3124 /* We need to allocate enough room for encoding the text.
3125 We need 33 1/3% more space, plus a newline every 76
3126 characters, and then we round up. */
3127 length
= iend
- ibeg
;
3128 allength
= length
+ length
/3 + 1;
3129 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3131 SAFE_ALLOCA (encoded
, char *, allength
);
3132 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3133 NILP (no_line_break
),
3134 !NILP (current_buffer
->enable_multibyte_characters
));
3135 if (encoded_length
> allength
)
3138 if (encoded_length
< 0)
3140 /* The encoding wasn't possible. */
3142 error ("Multibyte character in data for base64 encoding");
3145 /* Now we have encoded the region, so we insert the new contents
3146 and delete the old. (Insert first in order to preserve markers.) */
3147 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3148 insert (encoded
, encoded_length
);
3150 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3152 /* If point was outside of the region, restore it exactly; else just
3153 move to the beginning of the region. */
3154 if (old_pos
>= XFASTINT (end
))
3155 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3156 else if (old_pos
> XFASTINT (beg
))
3157 old_pos
= XFASTINT (beg
);
3160 /* We return the length of the encoded text. */
3161 return make_number (encoded_length
);
3164 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3166 doc
: /* Base64-encode STRING and return the result.
3167 Optional second argument NO-LINE-BREAK means do not break long lines
3168 into shorter lines. */)
3169 (Lisp_Object string
, Lisp_Object no_line_break
)
3171 int allength
, length
, encoded_length
;
3173 Lisp_Object encoded_string
;
3176 CHECK_STRING (string
);
3178 /* We need to allocate enough room for encoding the text.
3179 We need 33 1/3% more space, plus a newline every 76
3180 characters, and then we round up. */
3181 length
= SBYTES (string
);
3182 allength
= length
+ length
/3 + 1;
3183 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3185 /* We need to allocate enough room for decoding the text. */
3186 SAFE_ALLOCA (encoded
, char *, allength
);
3188 encoded_length
= base64_encode_1 (SDATA (string
),
3189 encoded
, length
, NILP (no_line_break
),
3190 STRING_MULTIBYTE (string
));
3191 if (encoded_length
> allength
)
3194 if (encoded_length
< 0)
3196 /* The encoding wasn't possible. */
3198 error ("Multibyte character in data for base64 encoding");
3201 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3204 return encoded_string
;
3208 base64_encode_1 (const char *from
, char *to
, int length
, int line_break
, int multibyte
)
3210 int counter
= 0, i
= 0;
3220 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3221 if (CHAR_BYTE8_P (c
))
3222 c
= CHAR_TO_BYTE8 (c
);
3230 /* Wrap line every 76 characters. */
3234 if (counter
< MIME_LINE_LENGTH
/ 4)
3243 /* Process first byte of a triplet. */
3245 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3246 value
= (0x03 & c
) << 4;
3248 /* Process second byte of a triplet. */
3252 *e
++ = base64_value_to_char
[value
];
3260 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3261 if (CHAR_BYTE8_P (c
))
3262 c
= CHAR_TO_BYTE8 (c
);
3270 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3271 value
= (0x0f & c
) << 2;
3273 /* Process third byte of a triplet. */
3277 *e
++ = base64_value_to_char
[value
];
3284 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3285 if (CHAR_BYTE8_P (c
))
3286 c
= CHAR_TO_BYTE8 (c
);
3294 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3295 *e
++ = base64_value_to_char
[0x3f & c
];
3302 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3304 doc
: /* Base64-decode the region between BEG and END.
3305 Return the length of the decoded text.
3306 If the region can't be decoded, signal an error and don't modify the buffer. */)
3307 (Lisp_Object beg
, Lisp_Object end
)
3309 int ibeg
, iend
, length
, allength
;
3314 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3317 validate_region (&beg
, &end
);
3319 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3320 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3322 length
= iend
- ibeg
;
3324 /* We need to allocate enough room for decoding the text. If we are
3325 working on a multibyte buffer, each decoded code may occupy at
3327 allength
= multibyte
? length
* 2 : length
;
3328 SAFE_ALLOCA (decoded
, char *, allength
);
3330 move_gap_both (XFASTINT (beg
), ibeg
);
3331 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3332 multibyte
, &inserted_chars
);
3333 if (decoded_length
> allength
)
3336 if (decoded_length
< 0)
3338 /* The decoding wasn't possible. */
3340 error ("Invalid base64 data");
3343 /* Now we have decoded the region, so we insert the new contents
3344 and delete the old. (Insert first in order to preserve markers.) */
3345 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3346 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3349 /* Delete the original text. */
3350 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3351 iend
+ decoded_length
, 1);
3353 /* If point was outside of the region, restore it exactly; else just
3354 move to the beginning of the region. */
3355 if (old_pos
>= XFASTINT (end
))
3356 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3357 else if (old_pos
> XFASTINT (beg
))
3358 old_pos
= XFASTINT (beg
);
3359 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3361 return make_number (inserted_chars
);
3364 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3366 doc
: /* Base64-decode STRING and return the result. */)
3367 (Lisp_Object string
)
3370 int length
, decoded_length
;
3371 Lisp_Object decoded_string
;
3374 CHECK_STRING (string
);
3376 length
= SBYTES (string
);
3377 /* We need to allocate enough room for decoding the text. */
3378 SAFE_ALLOCA (decoded
, char *, length
);
3380 /* The decoded result should be unibyte. */
3381 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3383 if (decoded_length
> length
)
3385 else if (decoded_length
>= 0)
3386 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3388 decoded_string
= Qnil
;
3391 if (!STRINGP (decoded_string
))
3392 error ("Invalid base64 data");
3394 return decoded_string
;
3397 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3398 MULTIBYTE is nonzero, the decoded result should be in multibyte
3399 form. If NCHARS_RETRUN is not NULL, store the number of produced
3400 characters in *NCHARS_RETURN. */
3403 base64_decode_1 (const char *from
, char *to
, int length
, int multibyte
, int *nchars_return
)
3408 unsigned long value
;
3413 /* Process first byte of a quadruplet. */
3415 READ_QUADRUPLET_BYTE (e
-to
);
3419 value
= base64_char_to_value
[c
] << 18;
3421 /* Process second byte of a quadruplet. */
3423 READ_QUADRUPLET_BYTE (-1);
3427 value
|= base64_char_to_value
[c
] << 12;
3429 c
= (unsigned char) (value
>> 16);
3430 if (multibyte
&& c
>= 128)
3431 e
+= BYTE8_STRING (c
, e
);
3436 /* Process third byte of a quadruplet. */
3438 READ_QUADRUPLET_BYTE (-1);
3442 READ_QUADRUPLET_BYTE (-1);
3451 value
|= base64_char_to_value
[c
] << 6;
3453 c
= (unsigned char) (0xff & value
>> 8);
3454 if (multibyte
&& c
>= 128)
3455 e
+= BYTE8_STRING (c
, e
);
3460 /* Process fourth byte of a quadruplet. */
3462 READ_QUADRUPLET_BYTE (-1);
3469 value
|= base64_char_to_value
[c
];
3471 c
= (unsigned char) (0xff & value
);
3472 if (multibyte
&& c
>= 128)
3473 e
+= BYTE8_STRING (c
, e
);
3482 /***********************************************************************
3484 ***** Hash Tables *****
3486 ***********************************************************************/
3488 /* Implemented by gerd@gnu.org. This hash table implementation was
3489 inspired by CMUCL hash tables. */
3493 1. For small tables, association lists are probably faster than
3494 hash tables because they have lower overhead.
3496 For uses of hash tables where the O(1) behavior of table
3497 operations is not a requirement, it might therefore be a good idea
3498 not to hash. Instead, we could just do a linear search in the
3499 key_and_value vector of the hash table. This could be done
3500 if a `:linear-search t' argument is given to make-hash-table. */
3503 /* The list of all weak hash tables. Don't staticpro this one. */
3505 struct Lisp_Hash_Table
*weak_hash_tables
;
3507 /* Various symbols. */
3509 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3510 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3511 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3513 /* Function prototypes. */
3515 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3516 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3517 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3518 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3519 Lisp_Object
, unsigned);
3520 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3521 Lisp_Object
, unsigned);
3522 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3523 unsigned, Lisp_Object
, unsigned);
3524 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3525 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3526 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3527 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3529 static unsigned sxhash_string (unsigned char *, int);
3530 static unsigned sxhash_list (Lisp_Object
, int);
3531 static unsigned sxhash_vector (Lisp_Object
, int);
3532 static unsigned sxhash_bool_vector (Lisp_Object
);
3533 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3537 /***********************************************************************
3539 ***********************************************************************/
3541 /* If OBJ is a Lisp hash table, return a pointer to its struct
3542 Lisp_Hash_Table. Otherwise, signal an error. */
3544 static struct Lisp_Hash_Table
*
3545 check_hash_table (Lisp_Object obj
)
3547 CHECK_HASH_TABLE (obj
);
3548 return XHASH_TABLE (obj
);
3552 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3556 next_almost_prime (int n
)
3568 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3569 which USED[I] is non-zero. If found at index I in ARGS, set
3570 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3571 -1. This function is used to extract a keyword/argument pair from
3572 a DEFUN parameter list. */
3575 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3579 for (i
= 0; i
< nargs
- 1; ++i
)
3580 if (!used
[i
] && EQ (args
[i
], key
))
3595 /* Return a Lisp vector which has the same contents as VEC but has
3596 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3597 vector that are not copied from VEC are set to INIT. */
3600 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3602 struct Lisp_Vector
*v
;
3605 xassert (VECTORP (vec
));
3606 old_size
= ASIZE (vec
);
3607 xassert (new_size
>= old_size
);
3609 v
= allocate_vector (new_size
);
3610 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3611 for (i
= old_size
; i
< new_size
; ++i
)
3612 v
->contents
[i
] = init
;
3613 XSETVECTOR (vec
, v
);
3618 /***********************************************************************
3620 ***********************************************************************/
3622 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3623 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3624 KEY2 are the same. */
3627 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3629 return (FLOATP (key1
)
3631 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3635 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3636 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3637 KEY2 are the same. */
3640 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3642 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3646 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3647 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3648 if KEY1 and KEY2 are the same. */
3651 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3655 Lisp_Object args
[3];
3657 args
[0] = h
->user_cmp_function
;
3660 return !NILP (Ffuncall (3, args
));
3667 /* Value is a hash code for KEY for use in hash table H which uses
3668 `eq' to compare keys. The hash code returned is guaranteed to fit
3669 in a Lisp integer. */
3672 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3674 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3675 xassert ((hash
& ~INTMASK
) == 0);
3680 /* Value is a hash code for KEY for use in hash table H which uses
3681 `eql' to compare keys. The hash code returned is guaranteed to fit
3682 in a Lisp integer. */
3685 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3689 hash
= sxhash (key
, 0);
3691 hash
= XUINT (key
) ^ XTYPE (key
);
3692 xassert ((hash
& ~INTMASK
) == 0);
3697 /* Value is a hash code for KEY for use in hash table H which uses
3698 `equal' to compare keys. The hash code returned is guaranteed to fit
3699 in a Lisp integer. */
3702 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3704 unsigned hash
= sxhash (key
, 0);
3705 xassert ((hash
& ~INTMASK
) == 0);
3710 /* Value is a hash code for KEY for use in hash table H which uses as
3711 user-defined function to compare keys. The hash code returned is
3712 guaranteed to fit in a Lisp integer. */
3715 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3717 Lisp_Object args
[2], hash
;
3719 args
[0] = h
->user_hash_function
;
3721 hash
= Ffuncall (2, args
);
3722 if (!INTEGERP (hash
))
3723 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3724 return XUINT (hash
);
3728 /* Create and initialize a new hash table.
3730 TEST specifies the test the hash table will use to compare keys.
3731 It must be either one of the predefined tests `eq', `eql' or
3732 `equal' or a symbol denoting a user-defined test named TEST with
3733 test and hash functions USER_TEST and USER_HASH.
3735 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3737 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3738 new size when it becomes full is computed by adding REHASH_SIZE to
3739 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3740 table's new size is computed by multiplying its old size with
3743 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3744 be resized when the ratio of (number of entries in the table) /
3745 (table size) is >= REHASH_THRESHOLD.
3747 WEAK specifies the weakness of the table. If non-nil, it must be
3748 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3751 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3752 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3753 Lisp_Object user_test
, Lisp_Object user_hash
)
3755 struct Lisp_Hash_Table
*h
;
3757 int index_size
, i
, sz
;
3759 /* Preconditions. */
3760 xassert (SYMBOLP (test
));
3761 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3762 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3763 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3764 xassert (FLOATP (rehash_threshold
)
3765 && XFLOATINT (rehash_threshold
) > 0
3766 && XFLOATINT (rehash_threshold
) <= 1.0);
3768 if (XFASTINT (size
) == 0)
3769 size
= make_number (1);
3771 /* Allocate a table and initialize it. */
3772 h
= allocate_hash_table ();
3774 /* Initialize hash table slots. */
3775 sz
= XFASTINT (size
);
3778 if (EQ (test
, Qeql
))
3780 h
->cmpfn
= cmpfn_eql
;
3781 h
->hashfn
= hashfn_eql
;
3783 else if (EQ (test
, Qeq
))
3786 h
->hashfn
= hashfn_eq
;
3788 else if (EQ (test
, Qequal
))
3790 h
->cmpfn
= cmpfn_equal
;
3791 h
->hashfn
= hashfn_equal
;
3795 h
->user_cmp_function
= user_test
;
3796 h
->user_hash_function
= user_hash
;
3797 h
->cmpfn
= cmpfn_user_defined
;
3798 h
->hashfn
= hashfn_user_defined
;
3802 h
->rehash_threshold
= rehash_threshold
;
3803 h
->rehash_size
= rehash_size
;
3805 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3806 h
->hash
= Fmake_vector (size
, Qnil
);
3807 h
->next
= Fmake_vector (size
, Qnil
);
3808 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3809 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3810 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3812 /* Set up the free list. */
3813 for (i
= 0; i
< sz
- 1; ++i
)
3814 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3815 h
->next_free
= make_number (0);
3817 XSET_HASH_TABLE (table
, h
);
3818 xassert (HASH_TABLE_P (table
));
3819 xassert (XHASH_TABLE (table
) == h
);
3821 /* Maybe add this hash table to the list of all weak hash tables. */
3823 h
->next_weak
= NULL
;
3826 h
->next_weak
= weak_hash_tables
;
3827 weak_hash_tables
= h
;
3834 /* Return a copy of hash table H1. Keys and values are not copied,
3835 only the table itself is. */
3838 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3841 struct Lisp_Hash_Table
*h2
;
3842 struct Lisp_Vector
*next
;
3844 h2
= allocate_hash_table ();
3845 next
= h2
->vec_next
;
3846 memcpy (h2
, h1
, sizeof *h2
);
3847 h2
->vec_next
= next
;
3848 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3849 h2
->hash
= Fcopy_sequence (h1
->hash
);
3850 h2
->next
= Fcopy_sequence (h1
->next
);
3851 h2
->index
= Fcopy_sequence (h1
->index
);
3852 XSET_HASH_TABLE (table
, h2
);
3854 /* Maybe add this hash table to the list of all weak hash tables. */
3855 if (!NILP (h2
->weak
))
3857 h2
->next_weak
= weak_hash_tables
;
3858 weak_hash_tables
= h2
;
3865 /* Resize hash table H if it's too full. If H cannot be resized
3866 because it's already too large, throw an error. */
3869 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3871 if (NILP (h
->next_free
))
3873 int old_size
= HASH_TABLE_SIZE (h
);
3874 int i
, new_size
, index_size
;
3877 if (INTEGERP (h
->rehash_size
))
3878 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3880 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3881 new_size
= max (old_size
+ 1, new_size
);
3882 index_size
= next_almost_prime ((int)
3884 / XFLOATINT (h
->rehash_threshold
)));
3885 /* Assignment to EMACS_INT stops GCC whining about limited range
3887 nsize
= max (index_size
, 2 * new_size
);
3888 if (nsize
> MOST_POSITIVE_FIXNUM
)
3889 error ("Hash table too large to resize");
3891 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3892 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3893 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3894 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3896 /* Update the free list. Do it so that new entries are added at
3897 the end of the free list. This makes some operations like
3899 for (i
= old_size
; i
< new_size
- 1; ++i
)
3900 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3902 if (!NILP (h
->next_free
))
3904 Lisp_Object last
, next
;
3906 last
= h
->next_free
;
3907 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3911 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3914 XSETFASTINT (h
->next_free
, old_size
);
3917 for (i
= 0; i
< old_size
; ++i
)
3918 if (!NILP (HASH_HASH (h
, i
)))
3920 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3921 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3922 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3923 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3929 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3930 the hash code of KEY. Value is the index of the entry in H
3931 matching KEY, or -1 if not found. */
3934 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3937 int start_of_bucket
;
3940 hash_code
= h
->hashfn (h
, key
);
3944 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3945 idx
= HASH_INDEX (h
, start_of_bucket
);
3947 /* We need not gcpro idx since it's either an integer or nil. */
3950 int i
= XFASTINT (idx
);
3951 if (EQ (key
, HASH_KEY (h
, i
))
3953 && h
->cmpfn (h
, key
, hash_code
,
3954 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3956 idx
= HASH_NEXT (h
, i
);
3959 return NILP (idx
) ? -1 : XFASTINT (idx
);
3963 /* Put an entry into hash table H that associates KEY with VALUE.
3964 HASH is a previously computed hash code of KEY.
3965 Value is the index of the entry in H matching KEY. */
3968 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3970 int start_of_bucket
, i
;
3972 xassert ((hash
& ~INTMASK
) == 0);
3974 /* Increment count after resizing because resizing may fail. */
3975 maybe_resize_hash_table (h
);
3978 /* Store key/value in the key_and_value vector. */
3979 i
= XFASTINT (h
->next_free
);
3980 h
->next_free
= HASH_NEXT (h
, i
);
3981 HASH_KEY (h
, i
) = key
;
3982 HASH_VALUE (h
, i
) = value
;
3984 /* Remember its hash code. */
3985 HASH_HASH (h
, i
) = make_number (hash
);
3987 /* Add new entry to its collision chain. */
3988 start_of_bucket
= hash
% ASIZE (h
->index
);
3989 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3990 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3995 /* Remove the entry matching KEY from hash table H, if there is one. */
3998 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4001 int start_of_bucket
;
4002 Lisp_Object idx
, prev
;
4004 hash_code
= h
->hashfn (h
, key
);
4005 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4006 idx
= HASH_INDEX (h
, start_of_bucket
);
4009 /* We need not gcpro idx, prev since they're either integers or nil. */
4012 int i
= XFASTINT (idx
);
4014 if (EQ (key
, HASH_KEY (h
, i
))
4016 && h
->cmpfn (h
, key
, hash_code
,
4017 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4019 /* Take entry out of collision chain. */
4021 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4023 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4025 /* Clear slots in key_and_value and add the slots to
4027 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4028 HASH_NEXT (h
, i
) = h
->next_free
;
4029 h
->next_free
= make_number (i
);
4031 xassert (h
->count
>= 0);
4037 idx
= HASH_NEXT (h
, i
);
4043 /* Clear hash table H. */
4046 hash_clear (struct Lisp_Hash_Table
*h
)
4050 int i
, size
= HASH_TABLE_SIZE (h
);
4052 for (i
= 0; i
< size
; ++i
)
4054 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4055 HASH_KEY (h
, i
) = Qnil
;
4056 HASH_VALUE (h
, i
) = Qnil
;
4057 HASH_HASH (h
, i
) = Qnil
;
4060 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4061 ASET (h
->index
, i
, Qnil
);
4063 h
->next_free
= make_number (0);
4070 /************************************************************************
4072 ************************************************************************/
4075 init_weak_hash_tables (void)
4077 weak_hash_tables
= NULL
;
4080 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4081 entries from the table that don't survive the current GC.
4082 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4083 non-zero if anything was marked. */
4086 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
4088 int bucket
, n
, marked
;
4090 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4093 for (bucket
= 0; bucket
< n
; ++bucket
)
4095 Lisp_Object idx
, next
, prev
;
4097 /* Follow collision chain, removing entries that
4098 don't survive this garbage collection. */
4100 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4102 int i
= XFASTINT (idx
);
4103 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4104 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4107 if (EQ (h
->weak
, Qkey
))
4108 remove_p
= !key_known_to_survive_p
;
4109 else if (EQ (h
->weak
, Qvalue
))
4110 remove_p
= !value_known_to_survive_p
;
4111 else if (EQ (h
->weak
, Qkey_or_value
))
4112 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4113 else if (EQ (h
->weak
, Qkey_and_value
))
4114 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4118 next
= HASH_NEXT (h
, i
);
4120 if (remove_entries_p
)
4124 /* Take out of collision chain. */
4126 HASH_INDEX (h
, bucket
) = next
;
4128 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4130 /* Add to free list. */
4131 HASH_NEXT (h
, i
) = h
->next_free
;
4134 /* Clear key, value, and hash. */
4135 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4136 HASH_HASH (h
, i
) = Qnil
;
4149 /* Make sure key and value survive. */
4150 if (!key_known_to_survive_p
)
4152 mark_object (HASH_KEY (h
, i
));
4156 if (!value_known_to_survive_p
)
4158 mark_object (HASH_VALUE (h
, i
));
4169 /* Remove elements from weak hash tables that don't survive the
4170 current garbage collection. Remove weak tables that don't survive
4171 from Vweak_hash_tables. Called from gc_sweep. */
4174 sweep_weak_hash_tables (void)
4176 struct Lisp_Hash_Table
*h
, *used
, *next
;
4179 /* Mark all keys and values that are in use. Keep on marking until
4180 there is no more change. This is necessary for cases like
4181 value-weak table A containing an entry X -> Y, where Y is used in a
4182 key-weak table B, Z -> Y. If B comes after A in the list of weak
4183 tables, X -> Y might be removed from A, although when looking at B
4184 one finds that it shouldn't. */
4188 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4190 if (h
->size
& ARRAY_MARK_FLAG
)
4191 marked
|= sweep_weak_table (h
, 0);
4196 /* Remove tables and entries that aren't used. */
4197 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4199 next
= h
->next_weak
;
4201 if (h
->size
& ARRAY_MARK_FLAG
)
4203 /* TABLE is marked as used. Sweep its contents. */
4205 sweep_weak_table (h
, 1);
4207 /* Add table to the list of used weak hash tables. */
4208 h
->next_weak
= used
;
4213 weak_hash_tables
= used
;
4218 /***********************************************************************
4219 Hash Code Computation
4220 ***********************************************************************/
4222 /* Maximum depth up to which to dive into Lisp structures. */
4224 #define SXHASH_MAX_DEPTH 3
4226 /* Maximum length up to which to take list and vector elements into
4229 #define SXHASH_MAX_LEN 7
4231 /* Combine two integers X and Y for hashing. */
4233 #define SXHASH_COMBINE(X, Y) \
4234 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4238 /* Return a hash for string PTR which has length LEN. The hash
4239 code returned is guaranteed to fit in a Lisp integer. */
4242 sxhash_string (unsigned char *ptr
, int len
)
4244 unsigned char *p
= ptr
;
4245 unsigned char *end
= p
+ len
;
4254 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4257 return hash
& INTMASK
;
4261 /* Return a hash for list LIST. DEPTH is the current depth in the
4262 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4265 sxhash_list (Lisp_Object list
, int depth
)
4270 if (depth
< SXHASH_MAX_DEPTH
)
4272 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4273 list
= XCDR (list
), ++i
)
4275 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4276 hash
= SXHASH_COMBINE (hash
, hash2
);
4281 unsigned hash2
= sxhash (list
, depth
+ 1);
4282 hash
= SXHASH_COMBINE (hash
, hash2
);
4289 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4290 the Lisp structure. */
4293 sxhash_vector (Lisp_Object vec
, int depth
)
4295 unsigned hash
= ASIZE (vec
);
4298 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4299 for (i
= 0; i
< n
; ++i
)
4301 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4302 hash
= SXHASH_COMBINE (hash
, hash2
);
4309 /* Return a hash for bool-vector VECTOR. */
4312 sxhash_bool_vector (Lisp_Object vec
)
4314 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4317 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4318 for (i
= 0; i
< n
; ++i
)
4319 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4325 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4326 structure. Value is an unsigned integer clipped to INTMASK. */
4329 sxhash (Lisp_Object obj
, int depth
)
4333 if (depth
> SXHASH_MAX_DEPTH
)
4336 switch (XTYPE (obj
))
4347 obj
= SYMBOL_NAME (obj
);
4351 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4354 /* This can be everything from a vector to an overlay. */
4355 case Lisp_Vectorlike
:
4357 /* According to the CL HyperSpec, two arrays are equal only if
4358 they are `eq', except for strings and bit-vectors. In
4359 Emacs, this works differently. We have to compare element
4361 hash
= sxhash_vector (obj
, depth
);
4362 else if (BOOL_VECTOR_P (obj
))
4363 hash
= sxhash_bool_vector (obj
);
4365 /* Others are `equal' if they are `eq', so let's take their
4371 hash
= sxhash_list (obj
, depth
);
4376 double val
= XFLOAT_DATA (obj
);
4377 unsigned char *p
= (unsigned char *) &val
;
4378 unsigned char *e
= p
+ sizeof val
;
4379 for (hash
= 0; p
< e
; ++p
)
4380 hash
= SXHASH_COMBINE (hash
, *p
);
4388 return hash
& INTMASK
;
4393 /***********************************************************************
4395 ***********************************************************************/
4398 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4399 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4402 unsigned hash
= sxhash (obj
, 0);
4403 return make_number (hash
);
4407 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4408 doc
: /* Create and return a new hash table.
4410 Arguments are specified as keyword/argument pairs. The following
4411 arguments are defined:
4413 :test TEST -- TEST must be a symbol that specifies how to compare
4414 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4415 `equal'. User-supplied test and hash functions can be specified via
4416 `define-hash-table-test'.
4418 :size SIZE -- A hint as to how many elements will be put in the table.
4421 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4422 fills up. If REHASH-SIZE is an integer, increase the size by that
4423 amount. If it is a float, it must be > 1.0, and the new size is the
4424 old size multiplied by that factor. Default is 1.5.
4426 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4427 Resize the hash table when the ratio (number of entries / table size)
4428 is greater than or equal to THRESHOLD. Default is 0.8.
4430 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4431 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4432 returned is a weak table. Key/value pairs are removed from a weak
4433 hash table when there are no non-weak references pointing to their
4434 key, value, one of key or value, or both key and value, depending on
4435 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4438 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4439 (int nargs
, Lisp_Object
*args
)
4441 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4442 Lisp_Object user_test
, user_hash
;
4446 /* The vector `used' is used to keep track of arguments that
4447 have been consumed. */
4448 used
= (char *) alloca (nargs
* sizeof *used
);
4449 memset (used
, 0, nargs
* sizeof *used
);
4451 /* See if there's a `:test TEST' among the arguments. */
4452 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4453 test
= i
< 0 ? Qeql
: args
[i
];
4454 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4456 /* See if it is a user-defined test. */
4459 prop
= Fget (test
, Qhash_table_test
);
4460 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4461 signal_error ("Invalid hash table test", test
);
4462 user_test
= XCAR (prop
);
4463 user_hash
= XCAR (XCDR (prop
));
4466 user_test
= user_hash
= Qnil
;
4468 /* See if there's a `:size SIZE' argument. */
4469 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4470 size
= i
< 0 ? Qnil
: args
[i
];
4472 size
= make_number (DEFAULT_HASH_SIZE
);
4473 else if (!INTEGERP (size
) || XINT (size
) < 0)
4474 signal_error ("Invalid hash table size", size
);
4476 /* Look for `:rehash-size SIZE'. */
4477 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4478 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4479 if (!NUMBERP (rehash_size
)
4480 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4481 || XFLOATINT (rehash_size
) <= 1.0)
4482 signal_error ("Invalid hash table rehash size", rehash_size
);
4484 /* Look for `:rehash-threshold THRESHOLD'. */
4485 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4486 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4487 if (!FLOATP (rehash_threshold
)
4488 || XFLOATINT (rehash_threshold
) <= 0.0
4489 || XFLOATINT (rehash_threshold
) > 1.0)
4490 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4492 /* Look for `:weakness WEAK'. */
4493 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4494 weak
= i
< 0 ? Qnil
: args
[i
];
4496 weak
= Qkey_and_value
;
4499 && !EQ (weak
, Qvalue
)
4500 && !EQ (weak
, Qkey_or_value
)
4501 && !EQ (weak
, Qkey_and_value
))
4502 signal_error ("Invalid hash table weakness", weak
);
4504 /* Now, all args should have been used up, or there's a problem. */
4505 for (i
= 0; i
< nargs
; ++i
)
4507 signal_error ("Invalid argument list", args
[i
]);
4509 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4510 user_test
, user_hash
);
4514 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4515 doc
: /* Return a copy of hash table TABLE. */)
4518 return copy_hash_table (check_hash_table (table
));
4522 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4523 doc
: /* Return the number of elements in TABLE. */)
4526 return make_number (check_hash_table (table
)->count
);
4530 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4531 Shash_table_rehash_size
, 1, 1, 0,
4532 doc
: /* Return the current rehash size of TABLE. */)
4535 return check_hash_table (table
)->rehash_size
;
4539 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4540 Shash_table_rehash_threshold
, 1, 1, 0,
4541 doc
: /* Return the current rehash threshold of TABLE. */)
4544 return check_hash_table (table
)->rehash_threshold
;
4548 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4549 doc
: /* Return the size of TABLE.
4550 The size can be used as an argument to `make-hash-table' to create
4551 a hash table than can hold as many elements as TABLE holds
4552 without need for resizing. */)
4555 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4556 return make_number (HASH_TABLE_SIZE (h
));
4560 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4561 doc
: /* Return the test TABLE uses. */)
4564 return check_hash_table (table
)->test
;
4568 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4570 doc
: /* Return the weakness of TABLE. */)
4573 return check_hash_table (table
)->weak
;
4577 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4578 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4581 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4585 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4586 doc
: /* Clear hash table TABLE and return it. */)
4589 hash_clear (check_hash_table (table
));
4590 /* Be compatible with XEmacs. */
4595 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4596 doc
: /* Look up KEY in TABLE and return its associated value.
4597 If KEY is not found, return DFLT which defaults to nil. */)
4598 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4600 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4601 int i
= hash_lookup (h
, key
, NULL
);
4602 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4606 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4607 doc
: /* Associate KEY with VALUE in hash table TABLE.
4608 If KEY is already present in table, replace its current value with
4610 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4612 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4616 i
= hash_lookup (h
, key
, &hash
);
4618 HASH_VALUE (h
, i
) = value
;
4620 hash_put (h
, key
, value
, hash
);
4626 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4627 doc
: /* Remove KEY from TABLE. */)
4628 (Lisp_Object key
, Lisp_Object table
)
4630 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4631 hash_remove_from_table (h
, key
);
4636 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4637 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4638 FUNCTION is called with two arguments, KEY and VALUE. */)
4639 (Lisp_Object function
, Lisp_Object table
)
4641 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4642 Lisp_Object args
[3];
4645 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4646 if (!NILP (HASH_HASH (h
, i
)))
4649 args
[1] = HASH_KEY (h
, i
);
4650 args
[2] = HASH_VALUE (h
, i
);
4658 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4659 Sdefine_hash_table_test
, 3, 3, 0,
4660 doc
: /* Define a new hash table test with name NAME, a symbol.
4662 In hash tables created with NAME specified as test, use TEST to
4663 compare keys, and HASH for computing hash codes of keys.
4665 TEST must be a function taking two arguments and returning non-nil if
4666 both arguments are the same. HASH must be a function taking one
4667 argument and return an integer that is the hash code of the argument.
4668 Hash code computation should use the whole value range of integers,
4669 including negative integers. */)
4670 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4672 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4677 /************************************************************************
4679 ************************************************************************/
4683 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4684 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4686 A message digest is a cryptographic checksum of a document, and the
4687 algorithm to calculate it is defined in RFC 1321.
4689 The two optional arguments START and END are character positions
4690 specifying for which part of OBJECT the message digest should be
4691 computed. If nil or omitted, the digest is computed for the whole
4694 The MD5 message digest is computed from the result of encoding the
4695 text in a coding system, not directly from the internal Emacs form of
4696 the text. The optional fourth argument CODING-SYSTEM specifies which
4697 coding system to encode the text with. It should be the same coding
4698 system that you used or will use when actually writing the text into a
4701 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4702 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4703 system would be chosen by default for writing this text into a file.
4705 If OBJECT is a string, the most preferred coding system (see the
4706 command `prefer-coding-system') is used.
4708 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4709 guesswork fails. Normally, an error is signaled in such case. */)
4710 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4712 unsigned char digest
[16];
4713 unsigned char value
[33];
4717 int start_char
= 0, end_char
= 0;
4718 int start_byte
= 0, end_byte
= 0;
4720 register struct buffer
*bp
;
4723 if (STRINGP (object
))
4725 if (NILP (coding_system
))
4727 /* Decide the coding-system to encode the data with. */
4729 if (STRING_MULTIBYTE (object
))
4730 /* use default, we can't guess correct value */
4731 coding_system
= preferred_coding_system ();
4733 coding_system
= Qraw_text
;
4736 if (NILP (Fcoding_system_p (coding_system
)))
4738 /* Invalid coding system. */
4740 if (!NILP (noerror
))
4741 coding_system
= Qraw_text
;
4743 xsignal1 (Qcoding_system_error
, coding_system
);
4746 if (STRING_MULTIBYTE (object
))
4747 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4749 size
= SCHARS (object
);
4750 size_byte
= SBYTES (object
);
4754 CHECK_NUMBER (start
);
4756 start_char
= XINT (start
);
4761 start_byte
= string_char_to_byte (object
, start_char
);
4767 end_byte
= size_byte
;
4773 end_char
= XINT (end
);
4778 end_byte
= string_char_to_byte (object
, end_char
);
4781 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4782 args_out_of_range_3 (object
, make_number (start_char
),
4783 make_number (end_char
));
4787 struct buffer
*prev
= current_buffer
;
4789 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4791 CHECK_BUFFER (object
);
4793 bp
= XBUFFER (object
);
4794 if (bp
!= current_buffer
)
4795 set_buffer_internal (bp
);
4801 CHECK_NUMBER_COERCE_MARKER (start
);
4809 CHECK_NUMBER_COERCE_MARKER (end
);
4814 temp
= b
, b
= e
, e
= temp
;
4816 if (!(BEGV
<= b
&& e
<= ZV
))
4817 args_out_of_range (start
, end
);
4819 if (NILP (coding_system
))
4821 /* Decide the coding-system to encode the data with.
4822 See fileio.c:Fwrite-region */
4824 if (!NILP (Vcoding_system_for_write
))
4825 coding_system
= Vcoding_system_for_write
;
4828 int force_raw_text
= 0;
4830 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4831 if (NILP (coding_system
)
4832 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4834 coding_system
= Qnil
;
4835 if (NILP (current_buffer
->enable_multibyte_characters
))
4839 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4841 /* Check file-coding-system-alist. */
4842 Lisp_Object args
[4], val
;
4844 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4845 args
[3] = Fbuffer_file_name(object
);
4846 val
= Ffind_operation_coding_system (4, args
);
4847 if (CONSP (val
) && !NILP (XCDR (val
)))
4848 coding_system
= XCDR (val
);
4851 if (NILP (coding_system
)
4852 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4854 /* If we still have not decided a coding system, use the
4855 default value of buffer-file-coding-system. */
4856 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4860 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4861 /* Confirm that VAL can surely encode the current region. */
4862 coding_system
= call4 (Vselect_safe_coding_system_function
,
4863 make_number (b
), make_number (e
),
4864 coding_system
, Qnil
);
4867 coding_system
= Qraw_text
;
4870 if (NILP (Fcoding_system_p (coding_system
)))
4872 /* Invalid coding system. */
4874 if (!NILP (noerror
))
4875 coding_system
= Qraw_text
;
4877 xsignal1 (Qcoding_system_error
, coding_system
);
4881 object
= make_buffer_string (b
, e
, 0);
4882 if (prev
!= current_buffer
)
4883 set_buffer_internal (prev
);
4884 /* Discard the unwind protect for recovering the current
4888 if (STRING_MULTIBYTE (object
))
4889 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4892 md5_buffer (SDATA (object
) + start_byte
,
4893 SBYTES (object
) - (size_byte
- end_byte
),
4896 for (i
= 0; i
< 16; i
++)
4897 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4900 return make_string (value
, 32);
4907 /* Hash table stuff. */
4908 Qhash_table_p
= intern_c_string ("hash-table-p");
4909 staticpro (&Qhash_table_p
);
4910 Qeq
= intern_c_string ("eq");
4912 Qeql
= intern_c_string ("eql");
4914 Qequal
= intern_c_string ("equal");
4915 staticpro (&Qequal
);
4916 QCtest
= intern_c_string (":test");
4917 staticpro (&QCtest
);
4918 QCsize
= intern_c_string (":size");
4919 staticpro (&QCsize
);
4920 QCrehash_size
= intern_c_string (":rehash-size");
4921 staticpro (&QCrehash_size
);
4922 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4923 staticpro (&QCrehash_threshold
);
4924 QCweakness
= intern_c_string (":weakness");
4925 staticpro (&QCweakness
);
4926 Qkey
= intern_c_string ("key");
4928 Qvalue
= intern_c_string ("value");
4929 staticpro (&Qvalue
);
4930 Qhash_table_test
= intern_c_string ("hash-table-test");
4931 staticpro (&Qhash_table_test
);
4932 Qkey_or_value
= intern_c_string ("key-or-value");
4933 staticpro (&Qkey_or_value
);
4934 Qkey_and_value
= intern_c_string ("key-and-value");
4935 staticpro (&Qkey_and_value
);
4938 defsubr (&Smake_hash_table
);
4939 defsubr (&Scopy_hash_table
);
4940 defsubr (&Shash_table_count
);
4941 defsubr (&Shash_table_rehash_size
);
4942 defsubr (&Shash_table_rehash_threshold
);
4943 defsubr (&Shash_table_size
);
4944 defsubr (&Shash_table_test
);
4945 defsubr (&Shash_table_weakness
);
4946 defsubr (&Shash_table_p
);
4947 defsubr (&Sclrhash
);
4948 defsubr (&Sgethash
);
4949 defsubr (&Sputhash
);
4950 defsubr (&Sremhash
);
4951 defsubr (&Smaphash
);
4952 defsubr (&Sdefine_hash_table_test
);
4954 Qstring_lessp
= intern_c_string ("string-lessp");
4955 staticpro (&Qstring_lessp
);
4956 Qprovide
= intern_c_string ("provide");
4957 staticpro (&Qprovide
);
4958 Qrequire
= intern_c_string ("require");
4959 staticpro (&Qrequire
);
4960 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4961 staticpro (&Qyes_or_no_p_history
);
4962 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4963 staticpro (&Qcursor_in_echo_area
);
4964 Qwidget_type
= intern_c_string ("widget-type");
4965 staticpro (&Qwidget_type
);
4967 staticpro (&string_char_byte_cache_string
);
4968 string_char_byte_cache_string
= Qnil
;
4970 require_nesting_list
= Qnil
;
4971 staticpro (&require_nesting_list
);
4973 Fset (Qyes_or_no_p_history
, Qnil
);
4975 DEFVAR_LISP ("features", &Vfeatures
,
4976 doc
: /* A list of symbols which are the features of the executing Emacs.
4977 Used by `featurep' and `require', and altered by `provide'. */);
4978 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4979 Qsubfeatures
= intern_c_string ("subfeatures");
4980 staticpro (&Qsubfeatures
);
4982 #ifdef HAVE_LANGINFO_CODESET
4983 Qcodeset
= intern_c_string ("codeset");
4984 staticpro (&Qcodeset
);
4985 Qdays
= intern_c_string ("days");
4987 Qmonths
= intern_c_string ("months");
4988 staticpro (&Qmonths
);
4989 Qpaper
= intern_c_string ("paper");
4990 staticpro (&Qpaper
);
4991 #endif /* HAVE_LANGINFO_CODESET */
4993 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4994 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4995 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4996 invoked by mouse clicks and mouse menu items.
4998 On some platforms, file selection dialogs are also enabled if this is
5002 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5003 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5004 This applies to commands from menus and tool bar buttons even when
5005 they are initiated from the keyboard. If `use-dialog-box' is nil,
5006 that disables the use of a file dialog, regardless of the value of
5008 use_file_dialog
= 1;
5010 defsubr (&Sidentity
);
5013 defsubr (&Ssafe_length
);
5014 defsubr (&Sstring_bytes
);
5015 defsubr (&Sstring_equal
);
5016 defsubr (&Scompare_strings
);
5017 defsubr (&Sstring_lessp
);
5020 defsubr (&Svconcat
);
5021 defsubr (&Scopy_sequence
);
5022 defsubr (&Sstring_make_multibyte
);
5023 defsubr (&Sstring_make_unibyte
);
5024 defsubr (&Sstring_as_multibyte
);
5025 defsubr (&Sstring_as_unibyte
);
5026 defsubr (&Sstring_to_multibyte
);
5027 defsubr (&Sstring_to_unibyte
);
5028 defsubr (&Scopy_alist
);
5029 defsubr (&Ssubstring
);
5030 defsubr (&Ssubstring_no_properties
);
5043 defsubr (&Snreverse
);
5044 defsubr (&Sreverse
);
5046 defsubr (&Splist_get
);
5048 defsubr (&Splist_put
);
5050 defsubr (&Slax_plist_get
);
5051 defsubr (&Slax_plist_put
);
5054 defsubr (&Sequal_including_properties
);
5055 defsubr (&Sfillarray
);
5056 defsubr (&Sclear_string
);
5060 defsubr (&Smapconcat
);
5061 defsubr (&Sy_or_n_p
);
5062 defsubr (&Syes_or_no_p
);
5063 defsubr (&Sload_average
);
5064 defsubr (&Sfeaturep
);
5065 defsubr (&Srequire
);
5066 defsubr (&Sprovide
);
5067 defsubr (&Splist_member
);
5068 defsubr (&Swidget_put
);
5069 defsubr (&Swidget_get
);
5070 defsubr (&Swidget_apply
);
5071 defsubr (&Sbase64_encode_region
);
5072 defsubr (&Sbase64_decode_region
);
5073 defsubr (&Sbase64_encode_string
);
5074 defsubr (&Sbase64_decode_string
);
5076 defsubr (&Slocale_info
);
5085 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5086 (do not change this comment) */