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, 2011
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/>. */
28 /* Note on some machines this defines `vector' as a typedef,
29 so make sure we don't use that name in this file. */
35 #include "character.h"
40 #include "intervals.h"
43 #include "blockinput.h"
45 #if defined (HAVE_X_WINDOWS)
48 #endif /* HAVE_MENUS */
51 #define NULL ((POINTER_TYPE *)0)
54 /* Nonzero enables use of dialog boxes for questions
55 asked by mouse commands. */
58 /* Nonzero enables use of a file dialog for file name
59 questions asked by mouse commands. */
62 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
63 Lisp_Object Qyes_or_no_p_history
;
64 Lisp_Object Qcursor_in_echo_area
;
65 Lisp_Object Qwidget_type
;
66 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
68 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
70 extern long get_random (void);
71 extern void seed_random (long);
77 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
78 doc
: /* Return the argument unchanged. */)
84 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
85 doc
: /* Return a pseudo-random number.
86 All integers representable in Lisp are equally likely.
87 On most systems, this is 29 bits' worth.
88 With positive integer LIMIT, return random number in interval [0,LIMIT).
89 With argument t, set the random number seed from the current time and pid.
90 Other values of LIMIT are ignored. */)
94 Lisp_Object lispy_val
;
95 unsigned long denominator
;
98 seed_random (getpid () + time (NULL
));
99 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
101 /* Try to take our random number from the higher bits of VAL,
102 not the lower, since (says Gentzel) the low bits of `random'
103 are less random than the higher ones. We do this by using the
104 quotient rather than the remainder. At the high end of the RNG
105 it's possible to get a quotient larger than n; discarding
106 these values eliminates the bias that would otherwise appear
107 when using a large n. */
108 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
110 val
= get_random () / denominator
;
111 while (val
>= XFASTINT (limit
));
115 XSETINT (lispy_val
, val
);
119 /* Random data-structure functions */
121 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
122 doc
: /* Return the length of vector, list or string SEQUENCE.
123 A byte-code function object is also allowed.
124 If the string contains multibyte characters, this is not necessarily
125 the number of bytes in the string; it is the number of characters.
126 To get the number of bytes, use `string-bytes'. */)
127 (register Lisp_Object sequence
)
129 register Lisp_Object val
;
132 if (STRINGP (sequence
))
133 XSETFASTINT (val
, SCHARS (sequence
));
134 else if (VECTORP (sequence
))
135 XSETFASTINT (val
, ASIZE (sequence
));
136 else if (CHAR_TABLE_P (sequence
))
137 XSETFASTINT (val
, MAX_CHAR
);
138 else if (BOOL_VECTOR_P (sequence
))
139 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
140 else if (COMPILEDP (sequence
))
141 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
142 else if (CONSP (sequence
))
145 while (CONSP (sequence
))
147 sequence
= XCDR (sequence
);
150 if (!CONSP (sequence
))
153 sequence
= XCDR (sequence
);
158 CHECK_LIST_END (sequence
, sequence
);
160 val
= make_number (i
);
162 else if (NILP (sequence
))
163 XSETFASTINT (val
, 0);
165 wrong_type_argument (Qsequencep
, sequence
);
170 /* This does not check for quits. That is safe since it must terminate. */
172 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
173 doc
: /* Return the length of a list, but avoid error or infinite loop.
174 This function never gets an error. If LIST is not really a list,
175 it returns 0. If LIST is circular, it returns a finite value
176 which is at least the number of distinct elements. */)
179 Lisp_Object tail
, halftail
, length
;
182 /* halftail is used to detect circular lists. */
184 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
186 if (EQ (tail
, halftail
) && len
!= 0)
190 halftail
= XCDR (halftail
);
193 XSETINT (length
, len
);
197 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
198 doc
: /* Return the number of bytes in STRING.
199 If STRING is multibyte, this may be greater than the length of STRING. */)
202 CHECK_STRING (string
);
203 return make_number (SBYTES (string
));
206 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
207 doc
: /* Return t if two strings have identical contents.
208 Case is significant, but text properties are ignored.
209 Symbols are also allowed; their print names are used instead. */)
210 (register Lisp_Object s1
, Lisp_Object s2
)
213 s1
= SYMBOL_NAME (s1
);
215 s2
= SYMBOL_NAME (s2
);
219 if (SCHARS (s1
) != SCHARS (s2
)
220 || SBYTES (s1
) != SBYTES (s2
)
221 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
226 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
227 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
228 In string STR1, skip the first START1 characters and stop at END1.
229 In string STR2, skip the first START2 characters and stop at END2.
230 END1 and END2 default to the full lengths of the respective strings.
232 Case is significant in this comparison if IGNORE-CASE is nil.
233 Unibyte strings are converted to multibyte for comparison.
235 The value is t if the strings (or specified portions) match.
236 If string STR1 is less, the value is a negative number N;
237 - 1 - N is the number of characters that match at the beginning.
238 If string STR1 is greater, the value is a positive number N;
239 N - 1 is the number of characters that match at the beginning. */)
240 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
242 register EMACS_INT end1_char
, end2_char
;
243 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
248 start1
= make_number (0);
250 start2
= make_number (0);
251 CHECK_NATNUM (start1
);
252 CHECK_NATNUM (start2
);
261 i1_byte
= string_char_to_byte (str1
, i1
);
262 i2_byte
= string_char_to_byte (str2
, i2
);
264 end1_char
= SCHARS (str1
);
265 if (! NILP (end1
) && end1_char
> XINT (end1
))
266 end1_char
= XINT (end1
);
268 end2_char
= SCHARS (str2
);
269 if (! NILP (end2
) && end2_char
> XINT (end2
))
270 end2_char
= XINT (end2
);
272 while (i1
< end1_char
&& i2
< end2_char
)
274 /* When we find a mismatch, we must compare the
275 characters, not just the bytes. */
278 if (STRING_MULTIBYTE (str1
))
279 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
282 c1
= SREF (str1
, i1
++);
283 MAKE_CHAR_MULTIBYTE (c1
);
286 if (STRING_MULTIBYTE (str2
))
287 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
290 c2
= SREF (str2
, i2
++);
291 MAKE_CHAR_MULTIBYTE (c2
);
297 if (! NILP (ignore_case
))
301 tem
= Fupcase (make_number (c1
));
303 tem
= Fupcase (make_number (c2
));
310 /* Note that I1 has already been incremented
311 past the character that we are comparing;
312 hence we don't add or subtract 1 here. */
314 return make_number (- i1
+ XINT (start1
));
316 return make_number (i1
- XINT (start1
));
320 return make_number (i1
- XINT (start1
) + 1);
322 return make_number (- i1
+ XINT (start1
) - 1);
327 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
328 doc
: /* Return t if first arg string is less than second in lexicographic order.
330 Symbols are also allowed; their print names are used instead. */)
331 (register Lisp_Object s1
, Lisp_Object s2
)
333 register EMACS_INT end
;
334 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
337 s1
= SYMBOL_NAME (s1
);
339 s2
= SYMBOL_NAME (s2
);
343 i1
= i1_byte
= i2
= i2_byte
= 0;
346 if (end
> SCHARS (s2
))
351 /* When we find a mismatch, we must compare the
352 characters, not just the bytes. */
355 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
356 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
359 return c1
< c2
? Qt
: Qnil
;
361 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
364 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
365 enum Lisp_Type target_type
, int last_special
);
369 concat2 (Lisp_Object s1
, Lisp_Object s2
)
374 return concat (2, args
, Lisp_String
, 0);
379 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
385 return concat (3, args
, Lisp_String
, 0);
388 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
389 doc
: /* Concatenate all the arguments and make the result a list.
390 The result is a list whose elements are the elements of all the arguments.
391 Each argument may be a list, vector or string.
392 The last argument is not copied, just used as the tail of the new list.
393 usage: (append &rest SEQUENCES) */)
394 (int nargs
, Lisp_Object
*args
)
396 return concat (nargs
, args
, Lisp_Cons
, 1);
399 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
400 doc
: /* Concatenate all the arguments and make the result a string.
401 The result is a string whose elements are the elements of all the arguments.
402 Each argument may be a string or a list or vector of characters (integers).
403 usage: (concat &rest SEQUENCES) */)
404 (int nargs
, Lisp_Object
*args
)
406 return concat (nargs
, args
, Lisp_String
, 0);
409 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
410 doc
: /* Concatenate all the arguments and make the result a vector.
411 The result is a vector whose elements are the elements of all the arguments.
412 Each argument may be a list, vector or string.
413 usage: (vconcat &rest SEQUENCES) */)
414 (int nargs
, Lisp_Object
*args
)
416 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
420 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
421 doc
: /* Return a copy of a list, vector, string or char-table.
422 The elements of a list or vector are not copied; they are shared
423 with the original. */)
426 if (NILP (arg
)) return arg
;
428 if (CHAR_TABLE_P (arg
))
430 return copy_char_table (arg
);
433 if (BOOL_VECTOR_P (arg
))
437 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
438 / BOOL_VECTOR_BITS_PER_CHAR
);
440 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
441 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
446 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
447 wrong_type_argument (Qsequencep
, arg
);
449 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
452 /* This structure holds information of an argument of `concat' that is
453 a string and has text properties to be copied. */
456 int argnum
; /* refer to ARGS (arguments of `concat') */
457 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
458 EMACS_INT to
; /* refer to VAL (the target string) */
462 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
465 register Lisp_Object tail
;
466 register Lisp_Object
this;
468 EMACS_INT toindex_byte
= 0;
469 register EMACS_INT result_len
;
470 register EMACS_INT result_len_byte
;
472 Lisp_Object last_tail
;
475 /* When we make a multibyte string, we can't copy text properties
476 while concatinating each string because the length of resulting
477 string can't be decided until we finish the whole concatination.
478 So, we record strings that have text properties to be copied
479 here, and copy the text properties after the concatination. */
480 struct textprop_rec
*textprops
= NULL
;
481 /* Number of elements in textprops. */
482 int num_textprops
= 0;
487 /* In append, the last arg isn't treated like the others */
488 if (last_special
&& nargs
> 0)
491 last_tail
= args
[nargs
];
496 /* Check each argument. */
497 for (argnum
= 0; argnum
< nargs
; argnum
++)
500 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
501 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
502 wrong_type_argument (Qsequencep
, this);
505 /* Compute total length in chars of arguments in RESULT_LEN.
506 If desired output is a string, also compute length in bytes
507 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
508 whether the result should be a multibyte string. */
512 for (argnum
= 0; argnum
< nargs
; argnum
++)
516 len
= XFASTINT (Flength (this));
517 if (target_type
== Lisp_String
)
519 /* We must count the number of bytes needed in the string
520 as well as the number of characters. */
523 EMACS_INT this_len_byte
;
526 for (i
= 0; i
< len
; i
++)
529 CHECK_CHARACTER (ch
);
530 this_len_byte
= CHAR_BYTES (XINT (ch
));
531 result_len_byte
+= this_len_byte
;
532 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
535 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
536 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
537 else if (CONSP (this))
538 for (; CONSP (this); this = XCDR (this))
541 CHECK_CHARACTER (ch
);
542 this_len_byte
= CHAR_BYTES (XINT (ch
));
543 result_len_byte
+= this_len_byte
;
544 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
547 else if (STRINGP (this))
549 if (STRING_MULTIBYTE (this))
552 result_len_byte
+= SBYTES (this);
555 result_len_byte
+= count_size_as_multibyte (SDATA (this),
562 error ("String overflow");
565 if (! some_multibyte
)
566 result_len_byte
= result_len
;
568 /* Create the output object. */
569 if (target_type
== Lisp_Cons
)
570 val
= Fmake_list (make_number (result_len
), Qnil
);
571 else if (target_type
== Lisp_Vectorlike
)
572 val
= Fmake_vector (make_number (result_len
), Qnil
);
573 else if (some_multibyte
)
574 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
576 val
= make_uninit_string (result_len
);
578 /* In `append', if all but last arg are nil, return last arg. */
579 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
582 /* Copy the contents of the args into the result. */
584 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
586 toindex
= 0, toindex_byte
= 0;
590 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
592 for (argnum
= 0; argnum
< nargs
; argnum
++)
595 EMACS_INT thisleni
= 0;
596 register EMACS_INT thisindex
= 0;
597 register EMACS_INT thisindex_byte
= 0;
601 thislen
= Flength (this), thisleni
= XINT (thislen
);
603 /* Between strings of the same kind, copy fast. */
604 if (STRINGP (this) && STRINGP (val
)
605 && STRING_MULTIBYTE (this) == some_multibyte
)
607 EMACS_INT thislen_byte
= SBYTES (this);
609 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
610 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
612 textprops
[num_textprops
].argnum
= argnum
;
613 textprops
[num_textprops
].from
= 0;
614 textprops
[num_textprops
++].to
= toindex
;
616 toindex_byte
+= thislen_byte
;
619 /* Copy a single-byte string to a multibyte string. */
620 else if (STRINGP (this) && STRINGP (val
))
622 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
624 textprops
[num_textprops
].argnum
= argnum
;
625 textprops
[num_textprops
].from
= 0;
626 textprops
[num_textprops
++].to
= toindex
;
628 toindex_byte
+= copy_text (SDATA (this),
629 SDATA (val
) + toindex_byte
,
630 SCHARS (this), 0, 1);
634 /* Copy element by element. */
637 register Lisp_Object elt
;
639 /* Fetch next element of `this' arg into `elt', or break if
640 `this' is exhausted. */
641 if (NILP (this)) break;
643 elt
= XCAR (this), this = XCDR (this);
644 else if (thisindex
>= thisleni
)
646 else if (STRINGP (this))
649 if (STRING_MULTIBYTE (this))
651 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
654 XSETFASTINT (elt
, c
);
658 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
660 && !ASCII_CHAR_P (XINT (elt
))
661 && XINT (elt
) < 0400)
663 c
= BYTE8_TO_CHAR (XINT (elt
));
668 else if (BOOL_VECTOR_P (this))
671 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
672 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
680 elt
= AREF (this, thisindex
);
684 /* Store this element into the result. */
691 else if (VECTORP (val
))
693 ASET (val
, toindex
, elt
);
700 toindex_byte
+= CHAR_STRING (XINT (elt
),
701 SDATA (val
) + toindex_byte
);
703 SSET (val
, toindex_byte
++, XINT (elt
));
709 XSETCDR (prev
, last_tail
);
711 if (num_textprops
> 0)
714 EMACS_INT last_to_end
= -1;
716 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
718 this = args
[textprops
[argnum
].argnum
];
719 props
= text_property_list (this,
721 make_number (SCHARS (this)),
723 /* If successive arguments have properites, be sure that the
724 value of `composition' property be the copy. */
725 if (last_to_end
== textprops
[argnum
].to
)
726 make_composition_value_copy (props
);
727 add_text_properties_from_list (val
, props
,
728 make_number (textprops
[argnum
].to
));
729 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
737 static Lisp_Object string_char_byte_cache_string
;
738 static EMACS_INT string_char_byte_cache_charpos
;
739 static EMACS_INT string_char_byte_cache_bytepos
;
742 clear_string_char_byte_cache (void)
744 string_char_byte_cache_string
= Qnil
;
747 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
750 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
753 EMACS_INT best_below
, best_below_byte
;
754 EMACS_INT best_above
, best_above_byte
;
756 best_below
= best_below_byte
= 0;
757 best_above
= SCHARS (string
);
758 best_above_byte
= SBYTES (string
);
759 if (best_above
== best_above_byte
)
762 if (EQ (string
, string_char_byte_cache_string
))
764 if (string_char_byte_cache_charpos
< char_index
)
766 best_below
= string_char_byte_cache_charpos
;
767 best_below_byte
= string_char_byte_cache_bytepos
;
771 best_above
= string_char_byte_cache_charpos
;
772 best_above_byte
= string_char_byte_cache_bytepos
;
776 if (char_index
- best_below
< best_above
- char_index
)
778 unsigned char *p
= SDATA (string
) + best_below_byte
;
780 while (best_below
< char_index
)
782 p
+= BYTES_BY_CHAR_HEAD (*p
);
785 i_byte
= p
- SDATA (string
);
789 unsigned char *p
= SDATA (string
) + best_above_byte
;
791 while (best_above
> char_index
)
794 while (!CHAR_HEAD_P (*p
)) p
--;
797 i_byte
= p
- SDATA (string
);
800 string_char_byte_cache_bytepos
= i_byte
;
801 string_char_byte_cache_charpos
= char_index
;
802 string_char_byte_cache_string
= string
;
807 /* Return the character index corresponding to BYTE_INDEX in STRING. */
810 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
813 EMACS_INT best_below
, best_below_byte
;
814 EMACS_INT best_above
, best_above_byte
;
816 best_below
= best_below_byte
= 0;
817 best_above
= SCHARS (string
);
818 best_above_byte
= SBYTES (string
);
819 if (best_above
== best_above_byte
)
822 if (EQ (string
, string_char_byte_cache_string
))
824 if (string_char_byte_cache_bytepos
< byte_index
)
826 best_below
= string_char_byte_cache_charpos
;
827 best_below_byte
= string_char_byte_cache_bytepos
;
831 best_above
= string_char_byte_cache_charpos
;
832 best_above_byte
= string_char_byte_cache_bytepos
;
836 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
838 unsigned char *p
= SDATA (string
) + best_below_byte
;
839 unsigned char *pend
= SDATA (string
) + byte_index
;
843 p
+= BYTES_BY_CHAR_HEAD (*p
);
847 i_byte
= p
- SDATA (string
);
851 unsigned char *p
= SDATA (string
) + best_above_byte
;
852 unsigned char *pbeg
= SDATA (string
) + byte_index
;
857 while (!CHAR_HEAD_P (*p
)) p
--;
861 i_byte
= p
- SDATA (string
);
864 string_char_byte_cache_bytepos
= i_byte
;
865 string_char_byte_cache_charpos
= i
;
866 string_char_byte_cache_string
= string
;
871 /* Convert STRING to a multibyte string. */
874 string_make_multibyte (Lisp_Object string
)
881 if (STRING_MULTIBYTE (string
))
884 nbytes
= count_size_as_multibyte (SDATA (string
),
886 /* If all the chars are ASCII, they won't need any more bytes
887 once converted. In that case, we can return STRING itself. */
888 if (nbytes
== SBYTES (string
))
891 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
892 copy_text (SDATA (string
), buf
, SBYTES (string
),
895 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
902 /* Convert STRING (if unibyte) to a multibyte string without changing
903 the number of characters. Characters 0200 trough 0237 are
904 converted to eight-bit characters. */
907 string_to_multibyte (Lisp_Object string
)
914 if (STRING_MULTIBYTE (string
))
917 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
918 /* If all the chars are ASCII, they won't need any more bytes once
920 if (nbytes
== SBYTES (string
))
921 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
923 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
924 memcpy (buf
, SDATA (string
), SBYTES (string
));
925 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
927 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
934 /* Convert STRING to a single-byte string. */
937 string_make_unibyte (Lisp_Object string
)
944 if (! STRING_MULTIBYTE (string
))
947 nchars
= SCHARS (string
);
949 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
950 copy_text (SDATA (string
), buf
, SBYTES (string
),
953 ret
= make_unibyte_string (buf
, nchars
);
959 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
961 doc
: /* Return the multibyte equivalent of STRING.
962 If STRING is unibyte and contains non-ASCII characters, the function
963 `unibyte-char-to-multibyte' is used to convert each unibyte character
964 to a multibyte character. In this case, the returned string is a
965 newly created string with no text properties. If STRING is multibyte
966 or entirely ASCII, it is returned unchanged. In particular, when
967 STRING is unibyte and entirely ASCII, the returned string is unibyte.
968 \(When the characters are all ASCII, Emacs primitives will treat the
969 string the same way whether it is unibyte or multibyte.) */)
972 CHECK_STRING (string
);
974 return string_make_multibyte (string
);
977 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
979 doc
: /* Return the unibyte equivalent of STRING.
980 Multibyte character codes are converted to unibyte according to
981 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
982 If the lookup in the translation table fails, this function takes just
983 the low 8 bits of each character. */)
986 CHECK_STRING (string
);
988 return string_make_unibyte (string
);
991 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
993 doc
: /* Return a unibyte string with the same individual bytes as STRING.
994 If STRING is unibyte, the result is STRING itself.
995 Otherwise it is a newly created string, with no text properties.
996 If STRING is multibyte and contains a character of charset
997 `eight-bit', it is converted to the corresponding single byte. */)
1000 CHECK_STRING (string
);
1002 if (STRING_MULTIBYTE (string
))
1004 EMACS_INT bytes
= SBYTES (string
);
1005 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1007 memcpy (str
, SDATA (string
), bytes
);
1008 bytes
= str_as_unibyte (str
, bytes
);
1009 string
= make_unibyte_string (str
, bytes
);
1015 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1017 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1018 If STRING is multibyte, the result is STRING itself.
1019 Otherwise it is a newly created string, with no text properties.
1021 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1022 part of a correct utf-8 sequence), it is converted to the corresponding
1023 multibyte character of charset `eight-bit'.
1024 See also `string-to-multibyte'.
1026 Beware, this often doesn't really do what you think it does.
1027 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1028 If you're not sure, whether to use `string-as-multibyte' or
1029 `string-to-multibyte', use `string-to-multibyte'. */)
1030 (Lisp_Object string
)
1032 CHECK_STRING (string
);
1034 if (! STRING_MULTIBYTE (string
))
1036 Lisp_Object new_string
;
1037 EMACS_INT nchars
, nbytes
;
1039 parse_str_as_multibyte (SDATA (string
),
1042 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1043 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1044 if (nbytes
!= SBYTES (string
))
1045 str_as_multibyte (SDATA (new_string
), nbytes
,
1046 SBYTES (string
), NULL
);
1047 string
= new_string
;
1048 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1053 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1055 doc
: /* Return a multibyte string with the same individual chars as STRING.
1056 If STRING is multibyte, the result is STRING itself.
1057 Otherwise it is a newly created string, with no text properties.
1059 If STRING is unibyte and contains an 8-bit byte, it is converted to
1060 the corresponding multibyte character of charset `eight-bit'.
1062 This differs from `string-as-multibyte' by converting each byte of a correct
1063 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1064 correct sequence. */)
1065 (Lisp_Object string
)
1067 CHECK_STRING (string
);
1069 return string_to_multibyte (string
);
1072 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1074 doc
: /* Return a unibyte string with the same individual chars as STRING.
1075 If STRING is unibyte, the result is STRING itself.
1076 Otherwise it is a newly created string, with no text properties,
1077 where each `eight-bit' character is converted to the corresponding byte.
1078 If STRING contains a non-ASCII, non-`eight-bit' character,
1079 an error is signaled. */)
1080 (Lisp_Object string
)
1082 CHECK_STRING (string
);
1084 if (STRING_MULTIBYTE (string
))
1086 EMACS_INT chars
= SCHARS (string
);
1087 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1088 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1090 if (converted
< chars
)
1091 error ("Can't convert the %dth character to unibyte", converted
);
1092 string
= make_unibyte_string (str
, chars
);
1099 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1100 doc
: /* Return a copy of ALIST.
1101 This is an alist which represents the same mapping from objects to objects,
1102 but does not share the alist structure with ALIST.
1103 The objects mapped (cars and cdrs of elements of the alist)
1104 are shared, however.
1105 Elements of ALIST that are not conses are also shared. */)
1108 register Lisp_Object tem
;
1113 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1114 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1116 register Lisp_Object car
;
1120 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1125 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1126 doc
: /* Return a new string whose contents are a substring of STRING.
1127 The returned string consists of the characters between index FROM
1128 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1129 zero-indexed: 0 means the first character of STRING. Negative values
1130 are counted from the end of STRING. If TO is nil, the substring runs
1131 to the end of STRING.
1133 The STRING argument may also be a vector. In that case, the return
1134 value is a new vector that contains the elements between index FROM
1135 \(inclusive) and index TO (exclusive) of that vector argument. */)
1136 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1140 EMACS_INT size_byte
= 0;
1141 EMACS_INT from_char
, to_char
;
1142 EMACS_INT from_byte
= 0, to_byte
= 0;
1144 CHECK_VECTOR_OR_STRING (string
);
1145 CHECK_NUMBER (from
);
1147 if (STRINGP (string
))
1149 size
= SCHARS (string
);
1150 size_byte
= SBYTES (string
);
1153 size
= ASIZE (string
);
1158 to_byte
= size_byte
;
1164 to_char
= XINT (to
);
1168 if (STRINGP (string
))
1169 to_byte
= string_char_to_byte (string
, to_char
);
1172 from_char
= XINT (from
);
1175 if (STRINGP (string
))
1176 from_byte
= string_char_to_byte (string
, from_char
);
1178 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1179 args_out_of_range_3 (string
, make_number (from_char
),
1180 make_number (to_char
));
1182 if (STRINGP (string
))
1184 res
= make_specified_string (SDATA (string
) + from_byte
,
1185 to_char
- from_char
, to_byte
- from_byte
,
1186 STRING_MULTIBYTE (string
));
1187 copy_text_properties (make_number (from_char
), make_number (to_char
),
1188 string
, make_number (0), res
, Qnil
);
1191 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1197 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1198 doc
: /* Return a substring of STRING, without text properties.
1199 It starts at index FROM and ends before TO.
1200 TO may be nil or omitted; then the substring runs to the end of STRING.
1201 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1202 If FROM or TO is negative, it counts from the end.
1204 With one argument, just copy STRING without its properties. */)
1205 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1207 EMACS_INT size
, size_byte
;
1208 EMACS_INT from_char
, to_char
;
1209 EMACS_INT from_byte
, to_byte
;
1211 CHECK_STRING (string
);
1213 size
= SCHARS (string
);
1214 size_byte
= SBYTES (string
);
1217 from_char
= from_byte
= 0;
1220 CHECK_NUMBER (from
);
1221 from_char
= XINT (from
);
1225 from_byte
= string_char_to_byte (string
, from_char
);
1231 to_byte
= size_byte
;
1237 to_char
= XINT (to
);
1241 to_byte
= string_char_to_byte (string
, to_char
);
1244 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1245 args_out_of_range_3 (string
, make_number (from_char
),
1246 make_number (to_char
));
1248 return make_specified_string (SDATA (string
) + from_byte
,
1249 to_char
- from_char
, to_byte
- from_byte
,
1250 STRING_MULTIBYTE (string
));
1253 /* Extract a substring of STRING, giving start and end positions
1254 both in characters and in bytes. */
1257 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1258 EMACS_INT to
, EMACS_INT to_byte
)
1262 EMACS_INT size_byte
;
1264 CHECK_VECTOR_OR_STRING (string
);
1266 if (STRINGP (string
))
1268 size
= SCHARS (string
);
1269 size_byte
= SBYTES (string
);
1272 size
= ASIZE (string
);
1274 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1275 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1277 if (STRINGP (string
))
1279 res
= make_specified_string (SDATA (string
) + from_byte
,
1280 to
- from
, to_byte
- from_byte
,
1281 STRING_MULTIBYTE (string
));
1282 copy_text_properties (make_number (from
), make_number (to
),
1283 string
, make_number (0), res
, Qnil
);
1286 res
= Fvector (to
- from
, &AREF (string
, from
));
1291 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1292 doc
: /* Take cdr N times on LIST, return the result. */)
1293 (Lisp_Object n
, Lisp_Object list
)
1295 register int i
, num
;
1298 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1301 CHECK_LIST_CONS (list
, list
);
1307 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1308 doc
: /* Return the Nth element of LIST.
1309 N counts from zero. If LIST is not that long, nil is returned. */)
1310 (Lisp_Object n
, Lisp_Object list
)
1312 return Fcar (Fnthcdr (n
, list
));
1315 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1316 doc
: /* Return element of SEQUENCE at index N. */)
1317 (register Lisp_Object sequence
, Lisp_Object n
)
1320 if (CONSP (sequence
) || NILP (sequence
))
1321 return Fcar (Fnthcdr (n
, sequence
));
1323 /* Faref signals a "not array" error, so check here. */
1324 CHECK_ARRAY (sequence
, Qsequencep
);
1325 return Faref (sequence
, n
);
1328 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1329 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1330 The value is actually the tail of LIST whose car is ELT. */)
1331 (register Lisp_Object elt
, Lisp_Object list
)
1333 register Lisp_Object tail
;
1334 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1336 register Lisp_Object tem
;
1337 CHECK_LIST_CONS (tail
, list
);
1339 if (! NILP (Fequal (elt
, tem
)))
1346 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1347 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1348 The value is actually the tail of LIST whose car is ELT. */)
1349 (register Lisp_Object elt
, Lisp_Object list
)
1353 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1361 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1372 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1373 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1374 The value is actually the tail of LIST whose car is ELT. */)
1375 (register Lisp_Object elt
, Lisp_Object list
)
1377 register Lisp_Object tail
;
1380 return Fmemq (elt
, list
);
1382 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1384 register Lisp_Object tem
;
1385 CHECK_LIST_CONS (tail
, list
);
1387 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1394 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1395 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1396 The value is actually the first element of LIST whose car is KEY.
1397 Elements of LIST that are not conses are ignored. */)
1398 (Lisp_Object key
, Lisp_Object list
)
1403 || (CONSP (XCAR (list
))
1404 && EQ (XCAR (XCAR (list
)), key
)))
1409 || (CONSP (XCAR (list
))
1410 && EQ (XCAR (XCAR (list
)), key
)))
1415 || (CONSP (XCAR (list
))
1416 && EQ (XCAR (XCAR (list
)), key
)))
1426 /* Like Fassq but never report an error and do not allow quits.
1427 Use only on lists known never to be circular. */
1430 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1433 && (!CONSP (XCAR (list
))
1434 || !EQ (XCAR (XCAR (list
)), key
)))
1437 return CAR_SAFE (list
);
1440 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1441 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1442 The value is actually the first element of LIST whose car equals KEY. */)
1443 (Lisp_Object key
, Lisp_Object list
)
1450 || (CONSP (XCAR (list
))
1451 && (car
= XCAR (XCAR (list
)),
1452 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1457 || (CONSP (XCAR (list
))
1458 && (car
= XCAR (XCAR (list
)),
1459 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1464 || (CONSP (XCAR (list
))
1465 && (car
= XCAR (XCAR (list
)),
1466 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1476 /* Like Fassoc but never report an error and do not allow quits.
1477 Use only on lists known never to be circular. */
1480 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1483 && (!CONSP (XCAR (list
))
1484 || (!EQ (XCAR (XCAR (list
)), key
)
1485 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1488 return CONSP (list
) ? XCAR (list
) : Qnil
;
1491 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1492 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1493 The value is actually the first element of LIST whose cdr is KEY. */)
1494 (register Lisp_Object key
, Lisp_Object list
)
1499 || (CONSP (XCAR (list
))
1500 && EQ (XCDR (XCAR (list
)), key
)))
1505 || (CONSP (XCAR (list
))
1506 && EQ (XCDR (XCAR (list
)), key
)))
1511 || (CONSP (XCAR (list
))
1512 && EQ (XCDR (XCAR (list
)), key
)))
1522 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1523 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1524 The value is actually the first element of LIST whose cdr equals KEY. */)
1525 (Lisp_Object key
, Lisp_Object list
)
1532 || (CONSP (XCAR (list
))
1533 && (cdr
= XCDR (XCAR (list
)),
1534 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1539 || (CONSP (XCAR (list
))
1540 && (cdr
= XCDR (XCAR (list
)),
1541 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1546 || (CONSP (XCAR (list
))
1547 && (cdr
= XCDR (XCAR (list
)),
1548 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1558 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1559 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1560 The modified LIST is returned. Comparison is done with `eq'.
1561 If the first member of LIST is ELT, there is no way to remove it by side effect;
1562 therefore, write `(setq foo (delq element foo))'
1563 to be sure of changing the value of `foo'. */)
1564 (register Lisp_Object elt
, Lisp_Object list
)
1566 register Lisp_Object tail
, prev
;
1567 register Lisp_Object tem
;
1571 while (!NILP (tail
))
1573 CHECK_LIST_CONS (tail
, list
);
1580 Fsetcdr (prev
, XCDR (tail
));
1590 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1591 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1592 SEQ must be a list, a vector, or a string.
1593 The modified SEQ is returned. Comparison is done with `equal'.
1594 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1595 is not a side effect; it is simply using a different sequence.
1596 Therefore, write `(setq foo (delete element foo))'
1597 to be sure of changing the value of `foo'. */)
1598 (Lisp_Object elt
, Lisp_Object seq
)
1604 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1605 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1608 if (n
!= ASIZE (seq
))
1610 struct Lisp_Vector
*p
= allocate_vector (n
);
1612 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1613 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1614 p
->contents
[n
++] = AREF (seq
, i
);
1616 XSETVECTOR (seq
, p
);
1619 else if (STRINGP (seq
))
1621 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1624 for (i
= nchars
= nbytes
= ibyte
= 0;
1626 ++i
, ibyte
+= cbytes
)
1628 if (STRING_MULTIBYTE (seq
))
1630 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1631 cbytes
= CHAR_BYTES (c
);
1639 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1646 if (nchars
!= SCHARS (seq
))
1650 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1651 if (!STRING_MULTIBYTE (seq
))
1652 STRING_SET_UNIBYTE (tem
);
1654 for (i
= nchars
= nbytes
= ibyte
= 0;
1656 ++i
, ibyte
+= cbytes
)
1658 if (STRING_MULTIBYTE (seq
))
1660 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1661 cbytes
= CHAR_BYTES (c
);
1669 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1671 unsigned char *from
= SDATA (seq
) + ibyte
;
1672 unsigned char *to
= SDATA (tem
) + nbytes
;
1678 for (n
= cbytes
; n
--; )
1688 Lisp_Object tail
, prev
;
1690 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1692 CHECK_LIST_CONS (tail
, seq
);
1694 if (!NILP (Fequal (elt
, XCAR (tail
))))
1699 Fsetcdr (prev
, XCDR (tail
));
1710 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1711 doc
: /* Reverse LIST by modifying cdr pointers.
1712 Return the reversed list. */)
1715 register Lisp_Object prev
, tail
, next
;
1717 if (NILP (list
)) return list
;
1720 while (!NILP (tail
))
1723 CHECK_LIST_CONS (tail
, list
);
1725 Fsetcdr (tail
, prev
);
1732 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1733 doc
: /* Reverse LIST, copying. Return the reversed list.
1734 See also the function `nreverse', which is used more often. */)
1739 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1742 new = Fcons (XCAR (list
), new);
1744 CHECK_LIST_END (list
, list
);
1748 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1750 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1751 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1752 Returns the sorted list. LIST is modified by side effects.
1753 PREDICATE is called with two elements of LIST, and should return non-nil
1754 if the first element should sort before the second. */)
1755 (Lisp_Object list
, Lisp_Object predicate
)
1757 Lisp_Object front
, back
;
1758 register Lisp_Object len
, tem
;
1759 struct gcpro gcpro1
, gcpro2
;
1760 register int length
;
1763 len
= Flength (list
);
1764 length
= XINT (len
);
1768 XSETINT (len
, (length
/ 2) - 1);
1769 tem
= Fnthcdr (len
, list
);
1771 Fsetcdr (tem
, Qnil
);
1773 GCPRO2 (front
, back
);
1774 front
= Fsort (front
, predicate
);
1775 back
= Fsort (back
, predicate
);
1777 return merge (front
, back
, predicate
);
1781 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1784 register Lisp_Object tail
;
1786 register Lisp_Object l1
, l2
;
1787 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1794 /* It is sufficient to protect org_l1 and org_l2.
1795 When l1 and l2 are updated, we copy the new values
1796 back into the org_ vars. */
1797 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1817 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1833 Fsetcdr (tail
, tem
);
1839 /* This does not check for quits. That is safe since it must terminate. */
1841 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1842 doc
: /* Extract a value from a property list.
1843 PLIST is a property list, which is a list of the form
1844 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1845 corresponding to the given PROP, or nil if PROP is not one of the
1846 properties on the list. This function never signals an error. */)
1847 (Lisp_Object plist
, Lisp_Object prop
)
1849 Lisp_Object tail
, halftail
;
1851 /* halftail is used to detect circular lists. */
1852 tail
= halftail
= plist
;
1853 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1855 if (EQ (prop
, XCAR (tail
)))
1856 return XCAR (XCDR (tail
));
1858 tail
= XCDR (XCDR (tail
));
1859 halftail
= XCDR (halftail
);
1860 if (EQ (tail
, halftail
))
1863 #if 0 /* Unsafe version. */
1864 /* This function can be called asynchronously
1865 (setup_coding_system). Don't QUIT in that case. */
1866 if (!interrupt_input_blocked
)
1874 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1875 doc
: /* Return the value of SYMBOL's PROPNAME property.
1876 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1877 (Lisp_Object symbol
, Lisp_Object propname
)
1879 CHECK_SYMBOL (symbol
);
1880 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1883 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1884 doc
: /* Change value in PLIST of PROP to VAL.
1885 PLIST is a property list, which is a list of the form
1886 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1887 If PROP is already a property on the list, its value is set to VAL,
1888 otherwise the new PROP VAL pair is added. The new plist is returned;
1889 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1890 The PLIST is modified by side effects. */)
1891 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1893 register Lisp_Object tail
, prev
;
1894 Lisp_Object newcell
;
1896 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1897 tail
= XCDR (XCDR (tail
)))
1899 if (EQ (prop
, XCAR (tail
)))
1901 Fsetcar (XCDR (tail
), val
);
1908 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1912 Fsetcdr (XCDR (prev
), newcell
);
1916 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1917 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1918 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1919 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1921 CHECK_SYMBOL (symbol
);
1922 XSYMBOL (symbol
)->plist
1923 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1927 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1928 doc
: /* Extract a value from a property list, comparing with `equal'.
1929 PLIST is a property list, which is a list of the form
1930 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1931 corresponding to the given PROP, or nil if PROP is not
1932 one of the properties on the list. */)
1933 (Lisp_Object plist
, Lisp_Object prop
)
1938 CONSP (tail
) && CONSP (XCDR (tail
));
1939 tail
= XCDR (XCDR (tail
)))
1941 if (! NILP (Fequal (prop
, XCAR (tail
))))
1942 return XCAR (XCDR (tail
));
1947 CHECK_LIST_END (tail
, prop
);
1952 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1953 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1954 PLIST is a property list, which is a list of the form
1955 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1956 If PROP is already a property on the list, its value is set to VAL,
1957 otherwise the new PROP VAL pair is added. The new plist is returned;
1958 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1959 The PLIST is modified by side effects. */)
1960 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1962 register Lisp_Object tail
, prev
;
1963 Lisp_Object newcell
;
1965 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1966 tail
= XCDR (XCDR (tail
)))
1968 if (! NILP (Fequal (prop
, XCAR (tail
))))
1970 Fsetcar (XCDR (tail
), val
);
1977 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1981 Fsetcdr (XCDR (prev
), newcell
);
1985 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1986 doc
: /* Return t if the two args are the same Lisp object.
1987 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1988 (Lisp_Object obj1
, Lisp_Object obj2
)
1991 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1993 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1996 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1997 doc
: /* Return t if two Lisp objects have similar structure and contents.
1998 They must have the same data type.
1999 Conses are compared by comparing the cars and the cdrs.
2000 Vectors and strings are compared element by element.
2001 Numbers are compared by value, but integers cannot equal floats.
2002 (Use `=' if you want integers and floats to be able to be equal.)
2003 Symbols must match exactly. */)
2004 (register Lisp_Object o1
, Lisp_Object o2
)
2006 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2009 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2010 doc
: /* Return t if two Lisp objects have similar structure and contents.
2011 This is like `equal' except that it compares the text properties
2012 of strings. (`equal' ignores text properties.) */)
2013 (register Lisp_Object o1
, Lisp_Object o2
)
2015 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2018 /* DEPTH is current depth of recursion. Signal an error if it
2020 PROPS, if non-nil, means compare string text properties too. */
2023 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2026 error ("Stack overflow in equal");
2032 if (XTYPE (o1
) != XTYPE (o2
))
2041 d1
= extract_float (o1
);
2042 d2
= extract_float (o2
);
2043 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2044 though they are not =. */
2045 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2049 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2056 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2060 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2062 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2065 o1
= XOVERLAY (o1
)->plist
;
2066 o2
= XOVERLAY (o2
)->plist
;
2071 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2072 && (XMARKER (o1
)->buffer
== 0
2073 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2077 case Lisp_Vectorlike
:
2080 EMACS_INT size
= ASIZE (o1
);
2081 /* Pseudovectors have the type encoded in the size field, so this test
2082 actually checks that the objects have the same type as well as the
2084 if (ASIZE (o2
) != size
)
2086 /* Boolvectors are compared much like strings. */
2087 if (BOOL_VECTOR_P (o1
))
2090 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2091 / BOOL_VECTOR_BITS_PER_CHAR
);
2093 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2095 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2100 if (WINDOW_CONFIGURATIONP (o1
))
2101 return compare_window_configurations (o1
, o2
, 0);
2103 /* Aside from them, only true vectors, char-tables, compiled
2104 functions, and fonts (font-spec, font-entity, font-ojbect)
2105 are sensible to compare, so eliminate the others now. */
2106 if (size
& PSEUDOVECTOR_FLAG
)
2108 if (!(size
& (PVEC_COMPILED
2109 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2111 size
&= PSEUDOVECTOR_SIZE_MASK
;
2113 for (i
= 0; i
< size
; i
++)
2118 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2126 if (SCHARS (o1
) != SCHARS (o2
))
2128 if (SBYTES (o1
) != SBYTES (o2
))
2130 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2132 if (props
&& !compare_string_intervals (o1
, o2
))
2144 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2145 doc
: /* Store each element of ARRAY with ITEM.
2146 ARRAY is a vector, string, char-table, or bool-vector. */)
2147 (Lisp_Object array
, Lisp_Object item
)
2149 register EMACS_INT size
, index
;
2152 if (VECTORP (array
))
2154 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2155 size
= ASIZE (array
);
2156 for (index
= 0; index
< size
; index
++)
2159 else if (CHAR_TABLE_P (array
))
2163 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2164 XCHAR_TABLE (array
)->contents
[i
] = item
;
2165 XCHAR_TABLE (array
)->defalt
= item
;
2167 else if (STRINGP (array
))
2169 register unsigned char *p
= SDATA (array
);
2170 CHECK_NUMBER (item
);
2171 charval
= XINT (item
);
2172 size
= SCHARS (array
);
2173 if (STRING_MULTIBYTE (array
))
2175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2176 int len
= CHAR_STRING (charval
, str
);
2177 EMACS_INT size_byte
= SBYTES (array
);
2178 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2181 if (size
!= size_byte
)
2184 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2185 if (len
!= this_len
)
2186 error ("Attempt to change byte length of a string");
2189 for (i
= 0; i
< size_byte
; i
++)
2190 *p
++ = str
[i
% len
];
2193 for (index
= 0; index
< size
; index
++)
2196 else if (BOOL_VECTOR_P (array
))
2198 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2200 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2201 / BOOL_VECTOR_BITS_PER_CHAR
);
2203 charval
= (! NILP (item
) ? -1 : 0);
2204 for (index
= 0; index
< size_in_chars
- 1; index
++)
2206 if (index
< size_in_chars
)
2208 /* Mask out bits beyond the vector size. */
2209 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2210 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2215 wrong_type_argument (Qarrayp
, array
);
2219 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2221 doc
: /* Clear the contents of STRING.
2222 This makes STRING unibyte and may change its length. */)
2223 (Lisp_Object string
)
2226 CHECK_STRING (string
);
2227 len
= SBYTES (string
);
2228 memset (SDATA (string
), 0, len
);
2229 STRING_SET_CHARS (string
, len
);
2230 STRING_SET_UNIBYTE (string
);
2236 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2238 Lisp_Object args
[2];
2241 return Fnconc (2, args
);
2244 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2245 doc
: /* Concatenate any number of lists by altering them.
2246 Only the last argument is not altered, and need not be a list.
2247 usage: (nconc &rest LISTS) */)
2248 (int nargs
, Lisp_Object
*args
)
2250 register int argnum
;
2251 register Lisp_Object tail
, tem
, val
;
2255 for (argnum
= 0; argnum
< nargs
; argnum
++)
2258 if (NILP (tem
)) continue;
2263 if (argnum
+ 1 == nargs
) break;
2265 CHECK_LIST_CONS (tem
, tem
);
2274 tem
= args
[argnum
+ 1];
2275 Fsetcdr (tail
, tem
);
2277 args
[argnum
+ 1] = tail
;
2283 /* This is the guts of all mapping functions.
2284 Apply FN to each element of SEQ, one by one,
2285 storing the results into elements of VALS, a C vector of Lisp_Objects.
2286 LENI is the length of VALS, which should also be the length of SEQ. */
2289 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2291 register Lisp_Object tail
;
2293 register EMACS_INT i
;
2294 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2298 /* Don't let vals contain any garbage when GC happens. */
2299 for (i
= 0; i
< leni
; i
++)
2302 GCPRO3 (dummy
, fn
, seq
);
2304 gcpro1
.nvars
= leni
;
2308 /* We need not explicitly protect `tail' because it is used only on lists, and
2309 1) lists are not relocated and 2) the list is marked via `seq' so will not
2314 for (i
= 0; i
< leni
; i
++)
2316 dummy
= call1 (fn
, AREF (seq
, i
));
2321 else if (BOOL_VECTOR_P (seq
))
2323 for (i
= 0; i
< leni
; i
++)
2326 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2327 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2328 dummy
= call1 (fn
, dummy
);
2333 else if (STRINGP (seq
))
2337 for (i
= 0, i_byte
= 0; i
< leni
;)
2340 EMACS_INT i_before
= i
;
2342 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2343 XSETFASTINT (dummy
, c
);
2344 dummy
= call1 (fn
, dummy
);
2346 vals
[i_before
] = dummy
;
2349 else /* Must be a list, since Flength did not get an error */
2352 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2354 dummy
= call1 (fn
, XCAR (tail
));
2364 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2365 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2366 In between each pair of results, stick in SEPARATOR. Thus, " " as
2367 SEPARATOR results in spaces between the values returned by FUNCTION.
2368 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2369 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2372 register EMACS_INT leni
;
2374 register Lisp_Object
*args
;
2375 register EMACS_INT i
;
2376 struct gcpro gcpro1
;
2380 len
= Flength (sequence
);
2381 if (CHAR_TABLE_P (sequence
))
2382 wrong_type_argument (Qlistp
, sequence
);
2384 nargs
= leni
+ leni
- 1;
2385 if (nargs
< 0) return empty_unibyte_string
;
2387 SAFE_ALLOCA_LISP (args
, nargs
);
2390 mapcar1 (leni
, args
, function
, sequence
);
2393 for (i
= leni
- 1; i
> 0; i
--)
2394 args
[i
+ i
] = args
[i
];
2396 for (i
= 1; i
< nargs
; i
+= 2)
2397 args
[i
] = separator
;
2399 ret
= Fconcat (nargs
, args
);
2405 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2406 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2407 The result is a list just as long as SEQUENCE.
2408 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2409 (Lisp_Object function
, Lisp_Object sequence
)
2411 register Lisp_Object len
;
2412 register EMACS_INT leni
;
2413 register Lisp_Object
*args
;
2417 len
= Flength (sequence
);
2418 if (CHAR_TABLE_P (sequence
))
2419 wrong_type_argument (Qlistp
, sequence
);
2420 leni
= XFASTINT (len
);
2422 SAFE_ALLOCA_LISP (args
, leni
);
2424 mapcar1 (leni
, args
, function
, sequence
);
2426 ret
= Flist (leni
, args
);
2432 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2433 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2434 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2435 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2436 (Lisp_Object function
, Lisp_Object sequence
)
2438 register EMACS_INT leni
;
2440 leni
= XFASTINT (Flength (sequence
));
2441 if (CHAR_TABLE_P (sequence
))
2442 wrong_type_argument (Qlistp
, sequence
);
2443 mapcar1 (leni
, 0, function
, sequence
);
2448 /* This is how C code calls `yes-or-no-p' and allows the user
2451 Anything that calls this function must protect from GC! */
2454 do_yes_or_no_p (Lisp_Object prompt
)
2456 return call1 (intern ("yes-or-no-p"), prompt
);
2459 /* Anything that calls this function must protect from GC! */
2461 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, MANY
, 0,
2462 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2463 The string to display to ask the question is obtained by
2464 formatting the string PROMPT with arguments ARGS (see `format').
2465 The result should end in a space; `yes-or-no-p' adds
2466 \"(yes or no) \" to it.
2468 The user must confirm the answer with RET, and can edit it until it
2471 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2472 is nil, and `use-dialog-box' is non-nil.
2473 usage: (yes-or-no-p PROMPT &rest ARGS) */)
2474 (int nargs
, Lisp_Object
*args
)
2476 register Lisp_Object ans
;
2477 struct gcpro gcpro1
;
2478 Lisp_Object prompt
= Fformat (nargs
, args
);
2481 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2482 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2486 Lisp_Object pane
, menu
, obj
;
2487 redisplay_preserve_echo_area (4);
2488 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2489 Fcons (Fcons (build_string ("No"), Qnil
),
2492 menu
= Fcons (prompt
, pane
);
2493 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2497 #endif /* HAVE_MENUS */
2499 prompt
= concat2 (prompt
, build_string ("(yes or no) "));
2504 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2505 Qyes_or_no_p_history
, Qnil
,
2507 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2512 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2520 message ("Please answer yes or no.");
2521 Fsleep_for (make_number (2), Qnil
);
2525 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2526 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2528 Each of the three load averages is multiplied by 100, then converted
2531 When USE-FLOATS is non-nil, floats will be used instead of integers.
2532 These floats are not multiplied by 100.
2534 If the 5-minute or 15-minute load averages are not available, return a
2535 shortened list, containing only those averages which are available.
2537 An error is thrown if the load average can't be obtained. In some
2538 cases making it work would require Emacs being installed setuid or
2539 setgid so that it can read kernel information, and that usually isn't
2541 (Lisp_Object use_floats
)
2544 int loads
= getloadavg (load_ave
, 3);
2545 Lisp_Object ret
= Qnil
;
2548 error ("load-average not implemented for this operating system");
2552 Lisp_Object load
= (NILP (use_floats
) ?
2553 make_number ((int) (100.0 * load_ave
[loads
]))
2554 : make_float (load_ave
[loads
]));
2555 ret
= Fcons (load
, ret
);
2561 Lisp_Object Vfeatures
, Qsubfeatures
;
2563 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2564 doc
: /* Return t if FEATURE is present in this Emacs.
2566 Use this to conditionalize execution of lisp code based on the
2567 presence or absence of Emacs or environment extensions.
2568 Use `provide' to declare that a feature is available. This function
2569 looks at the value of the variable `features'. The optional argument
2570 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2571 (Lisp_Object feature
, Lisp_Object subfeature
)
2573 register Lisp_Object tem
;
2574 CHECK_SYMBOL (feature
);
2575 tem
= Fmemq (feature
, Vfeatures
);
2576 if (!NILP (tem
) && !NILP (subfeature
))
2577 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2578 return (NILP (tem
)) ? Qnil
: Qt
;
2581 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2582 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2583 The optional argument SUBFEATURES should be a list of symbols listing
2584 particular subfeatures supported in this version of FEATURE. */)
2585 (Lisp_Object feature
, Lisp_Object subfeatures
)
2587 register Lisp_Object tem
;
2588 CHECK_SYMBOL (feature
);
2589 CHECK_LIST (subfeatures
);
2590 if (!NILP (Vautoload_queue
))
2591 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2593 tem
= Fmemq (feature
, Vfeatures
);
2595 Vfeatures
= Fcons (feature
, Vfeatures
);
2596 if (!NILP (subfeatures
))
2597 Fput (feature
, Qsubfeatures
, subfeatures
);
2598 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2600 /* Run any load-hooks for this file. */
2601 tem
= Fassq (feature
, Vafter_load_alist
);
2603 Fprogn (XCDR (tem
));
2608 /* `require' and its subroutines. */
2610 /* List of features currently being require'd, innermost first. */
2612 Lisp_Object require_nesting_list
;
2615 require_unwind (Lisp_Object old_value
)
2617 return require_nesting_list
= old_value
;
2620 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2621 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2622 If FEATURE is not a member of the list `features', then the feature
2623 is not loaded; so load the file FILENAME.
2624 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2625 and `load' will try to load this name appended with the suffix `.elc' or
2626 `.el', in that order. The name without appended suffix will not be used.
2627 If the optional third argument NOERROR is non-nil,
2628 then return nil if the file is not found instead of signaling an error.
2629 Normally the return value is FEATURE.
2630 The normal messages at start and end of loading FILENAME are suppressed. */)
2631 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2633 register Lisp_Object tem
;
2634 struct gcpro gcpro1
, gcpro2
;
2635 int from_file
= load_in_progress
;
2637 CHECK_SYMBOL (feature
);
2639 /* Record the presence of `require' in this file
2640 even if the feature specified is already loaded.
2641 But not more than once in any file,
2642 and not when we aren't loading or reading from a file. */
2644 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2645 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2650 tem
= Fcons (Qrequire
, feature
);
2651 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2652 LOADHIST_ATTACH (tem
);
2654 tem
= Fmemq (feature
, Vfeatures
);
2658 int count
= SPECPDL_INDEX ();
2661 /* This is to make sure that loadup.el gives a clear picture
2662 of what files are preloaded and when. */
2663 if (! NILP (Vpurify_flag
))
2664 error ("(require %s) while preparing to dump",
2665 SDATA (SYMBOL_NAME (feature
)));
2667 /* A certain amount of recursive `require' is legitimate,
2668 but if we require the same feature recursively 3 times,
2670 tem
= require_nesting_list
;
2671 while (! NILP (tem
))
2673 if (! NILP (Fequal (feature
, XCAR (tem
))))
2678 error ("Recursive `require' for feature `%s'",
2679 SDATA (SYMBOL_NAME (feature
)));
2681 /* Update the list for any nested `require's that occur. */
2682 record_unwind_protect (require_unwind
, require_nesting_list
);
2683 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2685 /* Value saved here is to be restored into Vautoload_queue */
2686 record_unwind_protect (un_autoload
, Vautoload_queue
);
2687 Vautoload_queue
= Qt
;
2689 /* Load the file. */
2690 GCPRO2 (feature
, filename
);
2691 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2692 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2695 /* If load failed entirely, return nil. */
2697 return unbind_to (count
, Qnil
);
2699 tem
= Fmemq (feature
, Vfeatures
);
2701 error ("Required feature `%s' was not provided",
2702 SDATA (SYMBOL_NAME (feature
)));
2704 /* Once loading finishes, don't undo it. */
2705 Vautoload_queue
= Qt
;
2706 feature
= unbind_to (count
, feature
);
2712 /* Primitives for work of the "widget" library.
2713 In an ideal world, this section would not have been necessary.
2714 However, lisp function calls being as slow as they are, it turns
2715 out that some functions in the widget library (wid-edit.el) are the
2716 bottleneck of Widget operation. Here is their translation to C,
2717 for the sole reason of efficiency. */
2719 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2720 doc
: /* Return non-nil if PLIST has the property PROP.
2721 PLIST is a property list, which is a list of the form
2722 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2723 Unlike `plist-get', this allows you to distinguish between a missing
2724 property and a property with the value nil.
2725 The value is actually the tail of PLIST whose car is PROP. */)
2726 (Lisp_Object plist
, Lisp_Object prop
)
2728 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2731 plist
= XCDR (plist
);
2732 plist
= CDR (plist
);
2737 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2738 doc
: /* In WIDGET, set PROPERTY to VALUE.
2739 The value can later be retrieved with `widget-get'. */)
2740 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2742 CHECK_CONS (widget
);
2743 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2747 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2748 doc
: /* In WIDGET, get the value of PROPERTY.
2749 The value could either be specified when the widget was created, or
2750 later with `widget-put'. */)
2751 (Lisp_Object widget
, Lisp_Object property
)
2759 CHECK_CONS (widget
);
2760 tmp
= Fplist_member (XCDR (widget
), property
);
2766 tmp
= XCAR (widget
);
2769 widget
= Fget (tmp
, Qwidget_type
);
2773 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2774 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2775 ARGS are passed as extra arguments to the function.
2776 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2777 (int nargs
, Lisp_Object
*args
)
2779 /* This function can GC. */
2780 Lisp_Object newargs
[3];
2781 struct gcpro gcpro1
, gcpro2
;
2784 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2785 newargs
[1] = args
[0];
2786 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2787 GCPRO2 (newargs
[0], newargs
[2]);
2788 result
= Fapply (3, newargs
);
2793 #ifdef HAVE_LANGINFO_CODESET
2794 #include <langinfo.h>
2797 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2798 doc
: /* Access locale data ITEM for the current C locale, if available.
2799 ITEM should be one of the following:
2801 `codeset', returning the character set as a string (locale item CODESET);
2803 `days', returning a 7-element vector of day names (locale items DAY_n);
2805 `months', returning a 12-element vector of month names (locale items MON_n);
2807 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2808 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2810 If the system can't provide such information through a call to
2811 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2813 See also Info node `(libc)Locales'.
2815 The data read from the system are decoded using `locale-coding-system'. */)
2819 #ifdef HAVE_LANGINFO_CODESET
2821 if (EQ (item
, Qcodeset
))
2823 str
= nl_langinfo (CODESET
);
2824 return build_string (str
);
2827 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2829 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2830 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2832 struct gcpro gcpro1
;
2834 synchronize_system_time_locale ();
2835 for (i
= 0; i
< 7; i
++)
2837 str
= nl_langinfo (days
[i
]);
2838 val
= make_unibyte_string (str
, strlen (str
));
2839 /* Fixme: Is this coding system necessarily right, even if
2840 it is consistent with CODESET? If not, what to do? */
2841 Faset (v
, make_number (i
),
2842 code_convert_string_norecord (val
, Vlocale_coding_system
,
2850 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2852 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2853 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2854 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2856 struct gcpro gcpro1
;
2858 synchronize_system_time_locale ();
2859 for (i
= 0; i
< 12; i
++)
2861 str
= nl_langinfo (months
[i
]);
2862 val
= make_unibyte_string (str
, strlen (str
));
2863 Faset (v
, make_number (i
),
2864 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2870 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2871 but is in the locale files. This could be used by ps-print. */
2873 else if (EQ (item
, Qpaper
))
2875 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2876 make_number (nl_langinfo (PAPER_HEIGHT
)));
2878 #endif /* PAPER_WIDTH */
2879 #endif /* HAVE_LANGINFO_CODESET*/
2883 /* base64 encode/decode functions (RFC 2045).
2884 Based on code from GNU recode. */
2886 #define MIME_LINE_LENGTH 76
2888 #define IS_ASCII(Character) \
2890 #define IS_BASE64(Character) \
2891 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2892 #define IS_BASE64_IGNORABLE(Character) \
2893 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2894 || (Character) == '\f' || (Character) == '\r')
2896 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2897 character or return retval if there are no characters left to
2899 #define READ_QUADRUPLET_BYTE(retval) \
2904 if (nchars_return) \
2905 *nchars_return = nchars; \
2910 while (IS_BASE64_IGNORABLE (c))
2912 /* Table of characters coding the 64 values. */
2913 static const char base64_value_to_char
[64] =
2915 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2916 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2917 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2918 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2919 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2920 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2921 '8', '9', '+', '/' /* 60-63 */
2924 /* Table of base64 values for first 128 characters. */
2925 static const short base64_char_to_value
[128] =
2927 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2928 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2929 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2930 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2931 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2932 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2933 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2934 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2935 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2936 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2937 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2938 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2939 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2942 /* The following diagram shows the logical steps by which three octets
2943 get transformed into four base64 characters.
2945 .--------. .--------. .--------.
2946 |aaaaaabb| |bbbbcccc| |ccdddddd|
2947 `--------' `--------' `--------'
2949 .--------+--------+--------+--------.
2950 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2951 `--------+--------+--------+--------'
2953 .--------+--------+--------+--------.
2954 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2955 `--------+--------+--------+--------'
2957 The octets are divided into 6 bit chunks, which are then encoded into
2958 base64 characters. */
2961 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2962 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2965 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2967 doc
: /* Base64-encode the region between BEG and END.
2968 Return the length of the encoded text.
2969 Optional third argument NO-LINE-BREAK means do not break long lines
2970 into shorter lines. */)
2971 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2974 EMACS_INT allength
, length
;
2975 EMACS_INT ibeg
, iend
, encoded_length
;
2976 EMACS_INT old_pos
= PT
;
2979 validate_region (&beg
, &end
);
2981 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2982 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2983 move_gap_both (XFASTINT (beg
), ibeg
);
2985 /* We need to allocate enough room for encoding the text.
2986 We need 33 1/3% more space, plus a newline every 76
2987 characters, and then we round up. */
2988 length
= iend
- ibeg
;
2989 allength
= length
+ length
/3 + 1;
2990 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2992 SAFE_ALLOCA (encoded
, char *, allength
);
2993 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2994 NILP (no_line_break
),
2995 !NILP (current_buffer
->enable_multibyte_characters
));
2996 if (encoded_length
> allength
)
2999 if (encoded_length
< 0)
3001 /* The encoding wasn't possible. */
3003 error ("Multibyte character in data for base64 encoding");
3006 /* Now we have encoded the region, so we insert the new contents
3007 and delete the old. (Insert first in order to preserve markers.) */
3008 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3009 insert (encoded
, encoded_length
);
3011 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3013 /* If point was outside of the region, restore it exactly; else just
3014 move to the beginning of the region. */
3015 if (old_pos
>= XFASTINT (end
))
3016 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3017 else if (old_pos
> XFASTINT (beg
))
3018 old_pos
= XFASTINT (beg
);
3021 /* We return the length of the encoded text. */
3022 return make_number (encoded_length
);
3025 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3027 doc
: /* Base64-encode STRING and return the result.
3028 Optional second argument NO-LINE-BREAK means do not break long lines
3029 into shorter lines. */)
3030 (Lisp_Object string
, Lisp_Object no_line_break
)
3032 EMACS_INT allength
, length
, encoded_length
;
3034 Lisp_Object encoded_string
;
3037 CHECK_STRING (string
);
3039 /* We need to allocate enough room for encoding the text.
3040 We need 33 1/3% more space, plus a newline every 76
3041 characters, and then we round up. */
3042 length
= SBYTES (string
);
3043 allength
= length
+ length
/3 + 1;
3044 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3046 /* We need to allocate enough room for decoding the text. */
3047 SAFE_ALLOCA (encoded
, char *, allength
);
3049 encoded_length
= base64_encode_1 (SDATA (string
),
3050 encoded
, length
, NILP (no_line_break
),
3051 STRING_MULTIBYTE (string
));
3052 if (encoded_length
> allength
)
3055 if (encoded_length
< 0)
3057 /* The encoding wasn't possible. */
3059 error ("Multibyte character in data for base64 encoding");
3062 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3065 return encoded_string
;
3069 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3070 int line_break
, int multibyte
)
3083 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3084 if (CHAR_BYTE8_P (c
))
3085 c
= CHAR_TO_BYTE8 (c
);
3093 /* Wrap line every 76 characters. */
3097 if (counter
< MIME_LINE_LENGTH
/ 4)
3106 /* Process first byte of a triplet. */
3108 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3109 value
= (0x03 & c
) << 4;
3111 /* Process second byte of a triplet. */
3115 *e
++ = base64_value_to_char
[value
];
3123 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3124 if (CHAR_BYTE8_P (c
))
3125 c
= CHAR_TO_BYTE8 (c
);
3133 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3134 value
= (0x0f & c
) << 2;
3136 /* Process third byte of a triplet. */
3140 *e
++ = base64_value_to_char
[value
];
3147 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3148 if (CHAR_BYTE8_P (c
))
3149 c
= CHAR_TO_BYTE8 (c
);
3157 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3158 *e
++ = base64_value_to_char
[0x3f & c
];
3165 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3167 doc
: /* Base64-decode the region between BEG and END.
3168 Return the length of the decoded text.
3169 If the region can't be decoded, signal an error and don't modify the buffer. */)
3170 (Lisp_Object beg
, Lisp_Object end
)
3172 EMACS_INT ibeg
, iend
, length
, allength
;
3174 EMACS_INT old_pos
= PT
;
3175 EMACS_INT decoded_length
;
3176 EMACS_INT inserted_chars
;
3177 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3180 validate_region (&beg
, &end
);
3182 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3183 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3185 length
= iend
- ibeg
;
3187 /* We need to allocate enough room for decoding the text. If we are
3188 working on a multibyte buffer, each decoded code may occupy at
3190 allength
= multibyte
? length
* 2 : length
;
3191 SAFE_ALLOCA (decoded
, char *, allength
);
3193 move_gap_both (XFASTINT (beg
), ibeg
);
3194 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3195 multibyte
, &inserted_chars
);
3196 if (decoded_length
> allength
)
3199 if (decoded_length
< 0)
3201 /* The decoding wasn't possible. */
3203 error ("Invalid base64 data");
3206 /* Now we have decoded the region, so we insert the new contents
3207 and delete the old. (Insert first in order to preserve markers.) */
3208 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3209 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3212 /* Delete the original text. */
3213 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3214 iend
+ decoded_length
, 1);
3216 /* If point was outside of the region, restore it exactly; else just
3217 move to the beginning of the region. */
3218 if (old_pos
>= XFASTINT (end
))
3219 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3220 else if (old_pos
> XFASTINT (beg
))
3221 old_pos
= XFASTINT (beg
);
3222 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3224 return make_number (inserted_chars
);
3227 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3229 doc
: /* Base64-decode STRING and return the result. */)
3230 (Lisp_Object string
)
3233 EMACS_INT length
, decoded_length
;
3234 Lisp_Object decoded_string
;
3237 CHECK_STRING (string
);
3239 length
= SBYTES (string
);
3240 /* We need to allocate enough room for decoding the text. */
3241 SAFE_ALLOCA (decoded
, char *, length
);
3243 /* The decoded result should be unibyte. */
3244 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3246 if (decoded_length
> length
)
3248 else if (decoded_length
>= 0)
3249 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3251 decoded_string
= Qnil
;
3254 if (!STRINGP (decoded_string
))
3255 error ("Invalid base64 data");
3257 return decoded_string
;
3260 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3261 MULTIBYTE is nonzero, the decoded result should be in multibyte
3262 form. If NCHARS_RETRUN is not NULL, store the number of produced
3263 characters in *NCHARS_RETURN. */
3266 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3267 int multibyte
, EMACS_INT
*nchars_return
)
3269 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3272 unsigned long value
;
3273 EMACS_INT nchars
= 0;
3277 /* Process first byte of a quadruplet. */
3279 READ_QUADRUPLET_BYTE (e
-to
);
3283 value
= base64_char_to_value
[c
] << 18;
3285 /* Process second byte of a quadruplet. */
3287 READ_QUADRUPLET_BYTE (-1);
3291 value
|= base64_char_to_value
[c
] << 12;
3293 c
= (unsigned char) (value
>> 16);
3294 if (multibyte
&& c
>= 128)
3295 e
+= BYTE8_STRING (c
, e
);
3300 /* Process third byte of a quadruplet. */
3302 READ_QUADRUPLET_BYTE (-1);
3306 READ_QUADRUPLET_BYTE (-1);
3315 value
|= base64_char_to_value
[c
] << 6;
3317 c
= (unsigned char) (0xff & value
>> 8);
3318 if (multibyte
&& c
>= 128)
3319 e
+= BYTE8_STRING (c
, e
);
3324 /* Process fourth byte of a quadruplet. */
3326 READ_QUADRUPLET_BYTE (-1);
3333 value
|= base64_char_to_value
[c
];
3335 c
= (unsigned char) (0xff & value
);
3336 if (multibyte
&& c
>= 128)
3337 e
+= BYTE8_STRING (c
, e
);
3346 /***********************************************************************
3348 ***** Hash Tables *****
3350 ***********************************************************************/
3352 /* Implemented by gerd@gnu.org. This hash table implementation was
3353 inspired by CMUCL hash tables. */
3357 1. For small tables, association lists are probably faster than
3358 hash tables because they have lower overhead.
3360 For uses of hash tables where the O(1) behavior of table
3361 operations is not a requirement, it might therefore be a good idea
3362 not to hash. Instead, we could just do a linear search in the
3363 key_and_value vector of the hash table. This could be done
3364 if a `:linear-search t' argument is given to make-hash-table. */
3367 /* The list of all weak hash tables. Don't staticpro this one. */
3369 struct Lisp_Hash_Table
*weak_hash_tables
;
3371 /* Various symbols. */
3373 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3374 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3375 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3377 /* Function prototypes. */
3379 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3380 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3381 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3382 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3383 Lisp_Object
, unsigned);
3384 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3385 Lisp_Object
, unsigned);
3386 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3387 unsigned, Lisp_Object
, unsigned);
3388 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3389 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3390 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3391 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3393 static unsigned sxhash_string (unsigned char *, int);
3394 static unsigned sxhash_list (Lisp_Object
, int);
3395 static unsigned sxhash_vector (Lisp_Object
, int);
3396 static unsigned sxhash_bool_vector (Lisp_Object
);
3397 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3401 /***********************************************************************
3403 ***********************************************************************/
3405 /* If OBJ is a Lisp hash table, return a pointer to its struct
3406 Lisp_Hash_Table. Otherwise, signal an error. */
3408 static struct Lisp_Hash_Table
*
3409 check_hash_table (Lisp_Object obj
)
3411 CHECK_HASH_TABLE (obj
);
3412 return XHASH_TABLE (obj
);
3416 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3420 next_almost_prime (int n
)
3432 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3433 which USED[I] is non-zero. If found at index I in ARGS, set
3434 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3435 -1. This function is used to extract a keyword/argument pair from
3436 a DEFUN parameter list. */
3439 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3443 for (i
= 0; i
< nargs
- 1; ++i
)
3444 if (!used
[i
] && EQ (args
[i
], key
))
3459 /* Return a Lisp vector which has the same contents as VEC but has
3460 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3461 vector that are not copied from VEC are set to INIT. */
3464 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3466 struct Lisp_Vector
*v
;
3469 xassert (VECTORP (vec
));
3470 old_size
= ASIZE (vec
);
3471 xassert (new_size
>= old_size
);
3473 v
= allocate_vector (new_size
);
3474 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3475 for (i
= old_size
; i
< new_size
; ++i
)
3476 v
->contents
[i
] = init
;
3477 XSETVECTOR (vec
, v
);
3482 /***********************************************************************
3484 ***********************************************************************/
3486 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3487 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3488 KEY2 are the same. */
3491 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3493 return (FLOATP (key1
)
3495 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3499 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3500 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3501 KEY2 are the same. */
3504 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3506 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3510 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3511 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3512 if KEY1 and KEY2 are the same. */
3515 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3519 Lisp_Object args
[3];
3521 args
[0] = h
->user_cmp_function
;
3524 return !NILP (Ffuncall (3, args
));
3531 /* Value is a hash code for KEY for use in hash table H which uses
3532 `eq' to compare keys. The hash code returned is guaranteed to fit
3533 in a Lisp integer. */
3536 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3538 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3539 xassert ((hash
& ~INTMASK
) == 0);
3544 /* Value is a hash code for KEY for use in hash table H which uses
3545 `eql' to compare keys. The hash code returned is guaranteed to fit
3546 in a Lisp integer. */
3549 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3553 hash
= sxhash (key
, 0);
3555 hash
= XUINT (key
) ^ XTYPE (key
);
3556 xassert ((hash
& ~INTMASK
) == 0);
3561 /* Value is a hash code for KEY for use in hash table H which uses
3562 `equal' to compare keys. The hash code returned is guaranteed to fit
3563 in a Lisp integer. */
3566 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3568 unsigned hash
= sxhash (key
, 0);
3569 xassert ((hash
& ~INTMASK
) == 0);
3574 /* Value is a hash code for KEY for use in hash table H which uses as
3575 user-defined function to compare keys. The hash code returned is
3576 guaranteed to fit in a Lisp integer. */
3579 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3581 Lisp_Object args
[2], hash
;
3583 args
[0] = h
->user_hash_function
;
3585 hash
= Ffuncall (2, args
);
3586 if (!INTEGERP (hash
))
3587 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3588 return XUINT (hash
);
3592 /* Create and initialize a new hash table.
3594 TEST specifies the test the hash table will use to compare keys.
3595 It must be either one of the predefined tests `eq', `eql' or
3596 `equal' or a symbol denoting a user-defined test named TEST with
3597 test and hash functions USER_TEST and USER_HASH.
3599 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3601 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3602 new size when it becomes full is computed by adding REHASH_SIZE to
3603 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3604 table's new size is computed by multiplying its old size with
3607 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3608 be resized when the ratio of (number of entries in the table) /
3609 (table size) is >= REHASH_THRESHOLD.
3611 WEAK specifies the weakness of the table. If non-nil, it must be
3612 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3615 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3616 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3617 Lisp_Object user_test
, Lisp_Object user_hash
)
3619 struct Lisp_Hash_Table
*h
;
3621 int index_size
, i
, sz
;
3623 /* Preconditions. */
3624 xassert (SYMBOLP (test
));
3625 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3626 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3627 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3628 xassert (FLOATP (rehash_threshold
)
3629 && XFLOATINT (rehash_threshold
) > 0
3630 && XFLOATINT (rehash_threshold
) <= 1.0);
3632 if (XFASTINT (size
) == 0)
3633 size
= make_number (1);
3635 /* Allocate a table and initialize it. */
3636 h
= allocate_hash_table ();
3638 /* Initialize hash table slots. */
3639 sz
= XFASTINT (size
);
3642 if (EQ (test
, Qeql
))
3644 h
->cmpfn
= cmpfn_eql
;
3645 h
->hashfn
= hashfn_eql
;
3647 else if (EQ (test
, Qeq
))
3650 h
->hashfn
= hashfn_eq
;
3652 else if (EQ (test
, Qequal
))
3654 h
->cmpfn
= cmpfn_equal
;
3655 h
->hashfn
= hashfn_equal
;
3659 h
->user_cmp_function
= user_test
;
3660 h
->user_hash_function
= user_hash
;
3661 h
->cmpfn
= cmpfn_user_defined
;
3662 h
->hashfn
= hashfn_user_defined
;
3666 h
->rehash_threshold
= rehash_threshold
;
3667 h
->rehash_size
= rehash_size
;
3669 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3670 h
->hash
= Fmake_vector (size
, Qnil
);
3671 h
->next
= Fmake_vector (size
, Qnil
);
3672 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3673 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3674 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3676 /* Set up the free list. */
3677 for (i
= 0; i
< sz
- 1; ++i
)
3678 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3679 h
->next_free
= make_number (0);
3681 XSET_HASH_TABLE (table
, h
);
3682 xassert (HASH_TABLE_P (table
));
3683 xassert (XHASH_TABLE (table
) == h
);
3685 /* Maybe add this hash table to the list of all weak hash tables. */
3687 h
->next_weak
= NULL
;
3690 h
->next_weak
= weak_hash_tables
;
3691 weak_hash_tables
= h
;
3698 /* Return a copy of hash table H1. Keys and values are not copied,
3699 only the table itself is. */
3702 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3705 struct Lisp_Hash_Table
*h2
;
3706 struct Lisp_Vector
*next
;
3708 h2
= allocate_hash_table ();
3709 next
= h2
->vec_next
;
3710 memcpy (h2
, h1
, sizeof *h2
);
3711 h2
->vec_next
= next
;
3712 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3713 h2
->hash
= Fcopy_sequence (h1
->hash
);
3714 h2
->next
= Fcopy_sequence (h1
->next
);
3715 h2
->index
= Fcopy_sequence (h1
->index
);
3716 XSET_HASH_TABLE (table
, h2
);
3718 /* Maybe add this hash table to the list of all weak hash tables. */
3719 if (!NILP (h2
->weak
))
3721 h2
->next_weak
= weak_hash_tables
;
3722 weak_hash_tables
= h2
;
3729 /* Resize hash table H if it's too full. If H cannot be resized
3730 because it's already too large, throw an error. */
3733 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3735 if (NILP (h
->next_free
))
3737 int old_size
= HASH_TABLE_SIZE (h
);
3738 int i
, new_size
, index_size
;
3741 if (INTEGERP (h
->rehash_size
))
3742 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3744 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3745 new_size
= max (old_size
+ 1, new_size
);
3746 index_size
= next_almost_prime ((int)
3748 / XFLOATINT (h
->rehash_threshold
)));
3749 /* Assignment to EMACS_INT stops GCC whining about limited range
3751 nsize
= max (index_size
, 2 * new_size
);
3752 if (nsize
> MOST_POSITIVE_FIXNUM
)
3753 error ("Hash table too large to resize");
3755 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3756 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3757 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3758 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3760 /* Update the free list. Do it so that new entries are added at
3761 the end of the free list. This makes some operations like
3763 for (i
= old_size
; i
< new_size
- 1; ++i
)
3764 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3766 if (!NILP (h
->next_free
))
3768 Lisp_Object last
, next
;
3770 last
= h
->next_free
;
3771 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3775 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3778 XSETFASTINT (h
->next_free
, old_size
);
3781 for (i
= 0; i
< old_size
; ++i
)
3782 if (!NILP (HASH_HASH (h
, i
)))
3784 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3785 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3786 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3787 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3793 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3794 the hash code of KEY. Value is the index of the entry in H
3795 matching KEY, or -1 if not found. */
3798 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3801 int start_of_bucket
;
3804 hash_code
= h
->hashfn (h
, key
);
3808 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3809 idx
= HASH_INDEX (h
, start_of_bucket
);
3811 /* We need not gcpro idx since it's either an integer or nil. */
3814 int i
= XFASTINT (idx
);
3815 if (EQ (key
, HASH_KEY (h
, i
))
3817 && h
->cmpfn (h
, key
, hash_code
,
3818 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3820 idx
= HASH_NEXT (h
, i
);
3823 return NILP (idx
) ? -1 : XFASTINT (idx
);
3827 /* Put an entry into hash table H that associates KEY with VALUE.
3828 HASH is a previously computed hash code of KEY.
3829 Value is the index of the entry in H matching KEY. */
3832 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3834 int start_of_bucket
, i
;
3836 xassert ((hash
& ~INTMASK
) == 0);
3838 /* Increment count after resizing because resizing may fail. */
3839 maybe_resize_hash_table (h
);
3842 /* Store key/value in the key_and_value vector. */
3843 i
= XFASTINT (h
->next_free
);
3844 h
->next_free
= HASH_NEXT (h
, i
);
3845 HASH_KEY (h
, i
) = key
;
3846 HASH_VALUE (h
, i
) = value
;
3848 /* Remember its hash code. */
3849 HASH_HASH (h
, i
) = make_number (hash
);
3851 /* Add new entry to its collision chain. */
3852 start_of_bucket
= hash
% ASIZE (h
->index
);
3853 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3854 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3859 /* Remove the entry matching KEY from hash table H, if there is one. */
3862 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3865 int start_of_bucket
;
3866 Lisp_Object idx
, prev
;
3868 hash_code
= h
->hashfn (h
, key
);
3869 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3870 idx
= HASH_INDEX (h
, start_of_bucket
);
3873 /* We need not gcpro idx, prev since they're either integers or nil. */
3876 int i
= XFASTINT (idx
);
3878 if (EQ (key
, HASH_KEY (h
, i
))
3880 && h
->cmpfn (h
, key
, hash_code
,
3881 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3883 /* Take entry out of collision chain. */
3885 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3887 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3889 /* Clear slots in key_and_value and add the slots to
3891 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3892 HASH_NEXT (h
, i
) = h
->next_free
;
3893 h
->next_free
= make_number (i
);
3895 xassert (h
->count
>= 0);
3901 idx
= HASH_NEXT (h
, i
);
3907 /* Clear hash table H. */
3910 hash_clear (struct Lisp_Hash_Table
*h
)
3914 int i
, size
= HASH_TABLE_SIZE (h
);
3916 for (i
= 0; i
< size
; ++i
)
3918 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3919 HASH_KEY (h
, i
) = Qnil
;
3920 HASH_VALUE (h
, i
) = Qnil
;
3921 HASH_HASH (h
, i
) = Qnil
;
3924 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3925 ASET (h
->index
, i
, Qnil
);
3927 h
->next_free
= make_number (0);
3934 /************************************************************************
3936 ************************************************************************/
3939 init_weak_hash_tables (void)
3941 weak_hash_tables
= NULL
;
3944 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3945 entries from the table that don't survive the current GC.
3946 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3947 non-zero if anything was marked. */
3950 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3952 int bucket
, n
, marked
;
3954 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3957 for (bucket
= 0; bucket
< n
; ++bucket
)
3959 Lisp_Object idx
, next
, prev
;
3961 /* Follow collision chain, removing entries that
3962 don't survive this garbage collection. */
3964 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3966 int i
= XFASTINT (idx
);
3967 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3968 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3971 if (EQ (h
->weak
, Qkey
))
3972 remove_p
= !key_known_to_survive_p
;
3973 else if (EQ (h
->weak
, Qvalue
))
3974 remove_p
= !value_known_to_survive_p
;
3975 else if (EQ (h
->weak
, Qkey_or_value
))
3976 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3977 else if (EQ (h
->weak
, Qkey_and_value
))
3978 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3982 next
= HASH_NEXT (h
, i
);
3984 if (remove_entries_p
)
3988 /* Take out of collision chain. */
3990 HASH_INDEX (h
, bucket
) = next
;
3992 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3994 /* Add to free list. */
3995 HASH_NEXT (h
, i
) = h
->next_free
;
3998 /* Clear key, value, and hash. */
3999 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4000 HASH_HASH (h
, i
) = Qnil
;
4013 /* Make sure key and value survive. */
4014 if (!key_known_to_survive_p
)
4016 mark_object (HASH_KEY (h
, i
));
4020 if (!value_known_to_survive_p
)
4022 mark_object (HASH_VALUE (h
, i
));
4033 /* Remove elements from weak hash tables that don't survive the
4034 current garbage collection. Remove weak tables that don't survive
4035 from Vweak_hash_tables. Called from gc_sweep. */
4038 sweep_weak_hash_tables (void)
4040 struct Lisp_Hash_Table
*h
, *used
, *next
;
4043 /* Mark all keys and values that are in use. Keep on marking until
4044 there is no more change. This is necessary for cases like
4045 value-weak table A containing an entry X -> Y, where Y is used in a
4046 key-weak table B, Z -> Y. If B comes after A in the list of weak
4047 tables, X -> Y might be removed from A, although when looking at B
4048 one finds that it shouldn't. */
4052 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4054 if (h
->size
& ARRAY_MARK_FLAG
)
4055 marked
|= sweep_weak_table (h
, 0);
4060 /* Remove tables and entries that aren't used. */
4061 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4063 next
= h
->next_weak
;
4065 if (h
->size
& ARRAY_MARK_FLAG
)
4067 /* TABLE is marked as used. Sweep its contents. */
4069 sweep_weak_table (h
, 1);
4071 /* Add table to the list of used weak hash tables. */
4072 h
->next_weak
= used
;
4077 weak_hash_tables
= used
;
4082 /***********************************************************************
4083 Hash Code Computation
4084 ***********************************************************************/
4086 /* Maximum depth up to which to dive into Lisp structures. */
4088 #define SXHASH_MAX_DEPTH 3
4090 /* Maximum length up to which to take list and vector elements into
4093 #define SXHASH_MAX_LEN 7
4095 /* Combine two integers X and Y for hashing. */
4097 #define SXHASH_COMBINE(X, Y) \
4098 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4102 /* Return a hash for string PTR which has length LEN. The hash
4103 code returned is guaranteed to fit in a Lisp integer. */
4106 sxhash_string (unsigned char *ptr
, int len
)
4108 unsigned char *p
= ptr
;
4109 unsigned char *end
= p
+ len
;
4118 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4121 return hash
& INTMASK
;
4125 /* Return a hash for list LIST. DEPTH is the current depth in the
4126 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4129 sxhash_list (Lisp_Object list
, int depth
)
4134 if (depth
< SXHASH_MAX_DEPTH
)
4136 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4137 list
= XCDR (list
), ++i
)
4139 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4140 hash
= SXHASH_COMBINE (hash
, hash2
);
4145 unsigned hash2
= sxhash (list
, depth
+ 1);
4146 hash
= SXHASH_COMBINE (hash
, hash2
);
4153 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4154 the Lisp structure. */
4157 sxhash_vector (Lisp_Object vec
, int depth
)
4159 unsigned hash
= ASIZE (vec
);
4162 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4163 for (i
= 0; i
< n
; ++i
)
4165 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4166 hash
= SXHASH_COMBINE (hash
, hash2
);
4173 /* Return a hash for bool-vector VECTOR. */
4176 sxhash_bool_vector (Lisp_Object vec
)
4178 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4181 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4182 for (i
= 0; i
< n
; ++i
)
4183 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4189 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4190 structure. Value is an unsigned integer clipped to INTMASK. */
4193 sxhash (Lisp_Object obj
, int depth
)
4197 if (depth
> SXHASH_MAX_DEPTH
)
4200 switch (XTYPE (obj
))
4211 obj
= SYMBOL_NAME (obj
);
4215 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4218 /* This can be everything from a vector to an overlay. */
4219 case Lisp_Vectorlike
:
4221 /* According to the CL HyperSpec, two arrays are equal only if
4222 they are `eq', except for strings and bit-vectors. In
4223 Emacs, this works differently. We have to compare element
4225 hash
= sxhash_vector (obj
, depth
);
4226 else if (BOOL_VECTOR_P (obj
))
4227 hash
= sxhash_bool_vector (obj
);
4229 /* Others are `equal' if they are `eq', so let's take their
4235 hash
= sxhash_list (obj
, depth
);
4240 double val
= XFLOAT_DATA (obj
);
4241 unsigned char *p
= (unsigned char *) &val
;
4242 unsigned char *e
= p
+ sizeof val
;
4243 for (hash
= 0; p
< e
; ++p
)
4244 hash
= SXHASH_COMBINE (hash
, *p
);
4252 return hash
& INTMASK
;
4257 /***********************************************************************
4259 ***********************************************************************/
4262 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4263 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4266 unsigned hash
= sxhash (obj
, 0);
4267 return make_number (hash
);
4271 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4272 doc
: /* Create and return a new hash table.
4274 Arguments are specified as keyword/argument pairs. The following
4275 arguments are defined:
4277 :test TEST -- TEST must be a symbol that specifies how to compare
4278 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4279 `equal'. User-supplied test and hash functions can be specified via
4280 `define-hash-table-test'.
4282 :size SIZE -- A hint as to how many elements will be put in the table.
4285 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4286 fills up. If REHASH-SIZE is an integer, increase the size by that
4287 amount. If it is a float, it must be > 1.0, and the new size is the
4288 old size multiplied by that factor. Default is 1.5.
4290 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4291 Resize the hash table when the ratio (number of entries / table size)
4292 is greater than or equal to THRESHOLD. Default is 0.8.
4294 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4295 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4296 returned is a weak table. Key/value pairs are removed from a weak
4297 hash table when there are no non-weak references pointing to their
4298 key, value, one of key or value, or both key and value, depending on
4299 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4302 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4303 (int nargs
, Lisp_Object
*args
)
4305 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4306 Lisp_Object user_test
, user_hash
;
4310 /* The vector `used' is used to keep track of arguments that
4311 have been consumed. */
4312 used
= (char *) alloca (nargs
* sizeof *used
);
4313 memset (used
, 0, nargs
* sizeof *used
);
4315 /* See if there's a `:test TEST' among the arguments. */
4316 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4317 test
= i
< 0 ? Qeql
: args
[i
];
4318 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4320 /* See if it is a user-defined test. */
4323 prop
= Fget (test
, Qhash_table_test
);
4324 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4325 signal_error ("Invalid hash table test", test
);
4326 user_test
= XCAR (prop
);
4327 user_hash
= XCAR (XCDR (prop
));
4330 user_test
= user_hash
= Qnil
;
4332 /* See if there's a `:size SIZE' argument. */
4333 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4334 size
= i
< 0 ? Qnil
: args
[i
];
4336 size
= make_number (DEFAULT_HASH_SIZE
);
4337 else if (!INTEGERP (size
) || XINT (size
) < 0)
4338 signal_error ("Invalid hash table size", size
);
4340 /* Look for `:rehash-size SIZE'. */
4341 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4342 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4343 if (!NUMBERP (rehash_size
)
4344 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4345 || XFLOATINT (rehash_size
) <= 1.0)
4346 signal_error ("Invalid hash table rehash size", rehash_size
);
4348 /* Look for `:rehash-threshold THRESHOLD'. */
4349 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4350 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4351 if (!FLOATP (rehash_threshold
)
4352 || XFLOATINT (rehash_threshold
) <= 0.0
4353 || XFLOATINT (rehash_threshold
) > 1.0)
4354 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4356 /* Look for `:weakness WEAK'. */
4357 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4358 weak
= i
< 0 ? Qnil
: args
[i
];
4360 weak
= Qkey_and_value
;
4363 && !EQ (weak
, Qvalue
)
4364 && !EQ (weak
, Qkey_or_value
)
4365 && !EQ (weak
, Qkey_and_value
))
4366 signal_error ("Invalid hash table weakness", weak
);
4368 /* Now, all args should have been used up, or there's a problem. */
4369 for (i
= 0; i
< nargs
; ++i
)
4371 signal_error ("Invalid argument list", args
[i
]);
4373 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4374 user_test
, user_hash
);
4378 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4379 doc
: /* Return a copy of hash table TABLE. */)
4382 return copy_hash_table (check_hash_table (table
));
4386 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4387 doc
: /* Return the number of elements in TABLE. */)
4390 return make_number (check_hash_table (table
)->count
);
4394 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4395 Shash_table_rehash_size
, 1, 1, 0,
4396 doc
: /* Return the current rehash size of TABLE. */)
4399 return check_hash_table (table
)->rehash_size
;
4403 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4404 Shash_table_rehash_threshold
, 1, 1, 0,
4405 doc
: /* Return the current rehash threshold of TABLE. */)
4408 return check_hash_table (table
)->rehash_threshold
;
4412 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4413 doc
: /* Return the size of TABLE.
4414 The size can be used as an argument to `make-hash-table' to create
4415 a hash table than can hold as many elements as TABLE holds
4416 without need for resizing. */)
4419 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4420 return make_number (HASH_TABLE_SIZE (h
));
4424 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4425 doc
: /* Return the test TABLE uses. */)
4428 return check_hash_table (table
)->test
;
4432 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4434 doc
: /* Return the weakness of TABLE. */)
4437 return check_hash_table (table
)->weak
;
4441 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4442 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4445 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4449 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4450 doc
: /* Clear hash table TABLE and return it. */)
4453 hash_clear (check_hash_table (table
));
4454 /* Be compatible with XEmacs. */
4459 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4460 doc
: /* Look up KEY in TABLE and return its associated value.
4461 If KEY is not found, return DFLT which defaults to nil. */)
4462 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4464 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4465 int i
= hash_lookup (h
, key
, NULL
);
4466 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4470 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4471 doc
: /* Associate KEY with VALUE in hash table TABLE.
4472 If KEY is already present in table, replace its current value with
4474 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4476 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4480 i
= hash_lookup (h
, key
, &hash
);
4482 HASH_VALUE (h
, i
) = value
;
4484 hash_put (h
, key
, value
, hash
);
4490 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4491 doc
: /* Remove KEY from TABLE. */)
4492 (Lisp_Object key
, Lisp_Object table
)
4494 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4495 hash_remove_from_table (h
, key
);
4500 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4501 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4502 FUNCTION is called with two arguments, KEY and VALUE. */)
4503 (Lisp_Object function
, Lisp_Object table
)
4505 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4506 Lisp_Object args
[3];
4509 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4510 if (!NILP (HASH_HASH (h
, i
)))
4513 args
[1] = HASH_KEY (h
, i
);
4514 args
[2] = HASH_VALUE (h
, i
);
4522 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4523 Sdefine_hash_table_test
, 3, 3, 0,
4524 doc
: /* Define a new hash table test with name NAME, a symbol.
4526 In hash tables created with NAME specified as test, use TEST to
4527 compare keys, and HASH for computing hash codes of keys.
4529 TEST must be a function taking two arguments and returning non-nil if
4530 both arguments are the same. HASH must be a function taking one
4531 argument and return an integer that is the hash code of the argument.
4532 Hash code computation should use the whole value range of integers,
4533 including negative integers. */)
4534 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4536 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4541 /************************************************************************
4543 ************************************************************************/
4547 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4548 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4550 A message digest is a cryptographic checksum of a document, and the
4551 algorithm to calculate it is defined in RFC 1321.
4553 The two optional arguments START and END are character positions
4554 specifying for which part of OBJECT the message digest should be
4555 computed. If nil or omitted, the digest is computed for the whole
4558 The MD5 message digest is computed from the result of encoding the
4559 text in a coding system, not directly from the internal Emacs form of
4560 the text. The optional fourth argument CODING-SYSTEM specifies which
4561 coding system to encode the text with. It should be the same coding
4562 system that you used or will use when actually writing the text into a
4565 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4566 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4567 system would be chosen by default for writing this text into a file.
4569 If OBJECT is a string, the most preferred coding system (see the
4570 command `prefer-coding-system') is used.
4572 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4573 guesswork fails. Normally, an error is signaled in such case. */)
4574 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4576 unsigned char digest
[16];
4577 unsigned char value
[33];
4580 EMACS_INT size_byte
= 0;
4581 EMACS_INT start_char
= 0, end_char
= 0;
4582 EMACS_INT start_byte
= 0, end_byte
= 0;
4583 register EMACS_INT b
, e
;
4584 register struct buffer
*bp
;
4587 if (STRINGP (object
))
4589 if (NILP (coding_system
))
4591 /* Decide the coding-system to encode the data with. */
4593 if (STRING_MULTIBYTE (object
))
4594 /* use default, we can't guess correct value */
4595 coding_system
= preferred_coding_system ();
4597 coding_system
= Qraw_text
;
4600 if (NILP (Fcoding_system_p (coding_system
)))
4602 /* Invalid coding system. */
4604 if (!NILP (noerror
))
4605 coding_system
= Qraw_text
;
4607 xsignal1 (Qcoding_system_error
, coding_system
);
4610 if (STRING_MULTIBYTE (object
))
4611 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4613 size
= SCHARS (object
);
4614 size_byte
= SBYTES (object
);
4618 CHECK_NUMBER (start
);
4620 start_char
= XINT (start
);
4625 start_byte
= string_char_to_byte (object
, start_char
);
4631 end_byte
= size_byte
;
4637 end_char
= XINT (end
);
4642 end_byte
= string_char_to_byte (object
, end_char
);
4645 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4646 args_out_of_range_3 (object
, make_number (start_char
),
4647 make_number (end_char
));
4651 struct buffer
*prev
= current_buffer
;
4653 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4655 CHECK_BUFFER (object
);
4657 bp
= XBUFFER (object
);
4658 if (bp
!= current_buffer
)
4659 set_buffer_internal (bp
);
4665 CHECK_NUMBER_COERCE_MARKER (start
);
4673 CHECK_NUMBER_COERCE_MARKER (end
);
4678 temp
= b
, b
= e
, e
= temp
;
4680 if (!(BEGV
<= b
&& e
<= ZV
))
4681 args_out_of_range (start
, end
);
4683 if (NILP (coding_system
))
4685 /* Decide the coding-system to encode the data with.
4686 See fileio.c:Fwrite-region */
4688 if (!NILP (Vcoding_system_for_write
))
4689 coding_system
= Vcoding_system_for_write
;
4692 int force_raw_text
= 0;
4694 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4695 if (NILP (coding_system
)
4696 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4698 coding_system
= Qnil
;
4699 if (NILP (current_buffer
->enable_multibyte_characters
))
4703 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4705 /* Check file-coding-system-alist. */
4706 Lisp_Object args
[4], val
;
4708 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4709 args
[3] = Fbuffer_file_name(object
);
4710 val
= Ffind_operation_coding_system (4, args
);
4711 if (CONSP (val
) && !NILP (XCDR (val
)))
4712 coding_system
= XCDR (val
);
4715 if (NILP (coding_system
)
4716 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4718 /* If we still have not decided a coding system, use the
4719 default value of buffer-file-coding-system. */
4720 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4724 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4725 /* Confirm that VAL can surely encode the current region. */
4726 coding_system
= call4 (Vselect_safe_coding_system_function
,
4727 make_number (b
), make_number (e
),
4728 coding_system
, Qnil
);
4731 coding_system
= Qraw_text
;
4734 if (NILP (Fcoding_system_p (coding_system
)))
4736 /* Invalid coding system. */
4738 if (!NILP (noerror
))
4739 coding_system
= Qraw_text
;
4741 xsignal1 (Qcoding_system_error
, coding_system
);
4745 object
= make_buffer_string (b
, e
, 0);
4746 if (prev
!= current_buffer
)
4747 set_buffer_internal (prev
);
4748 /* Discard the unwind protect for recovering the current
4752 if (STRING_MULTIBYTE (object
))
4753 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4756 md5_buffer (SDATA (object
) + start_byte
,
4757 SBYTES (object
) - (size_byte
- end_byte
),
4760 for (i
= 0; i
< 16; i
++)
4761 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4764 return make_string (value
, 32);
4771 /* Hash table stuff. */
4772 Qhash_table_p
= intern_c_string ("hash-table-p");
4773 staticpro (&Qhash_table_p
);
4774 Qeq
= intern_c_string ("eq");
4776 Qeql
= intern_c_string ("eql");
4778 Qequal
= intern_c_string ("equal");
4779 staticpro (&Qequal
);
4780 QCtest
= intern_c_string (":test");
4781 staticpro (&QCtest
);
4782 QCsize
= intern_c_string (":size");
4783 staticpro (&QCsize
);
4784 QCrehash_size
= intern_c_string (":rehash-size");
4785 staticpro (&QCrehash_size
);
4786 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4787 staticpro (&QCrehash_threshold
);
4788 QCweakness
= intern_c_string (":weakness");
4789 staticpro (&QCweakness
);
4790 Qkey
= intern_c_string ("key");
4792 Qvalue
= intern_c_string ("value");
4793 staticpro (&Qvalue
);
4794 Qhash_table_test
= intern_c_string ("hash-table-test");
4795 staticpro (&Qhash_table_test
);
4796 Qkey_or_value
= intern_c_string ("key-or-value");
4797 staticpro (&Qkey_or_value
);
4798 Qkey_and_value
= intern_c_string ("key-and-value");
4799 staticpro (&Qkey_and_value
);
4802 defsubr (&Smake_hash_table
);
4803 defsubr (&Scopy_hash_table
);
4804 defsubr (&Shash_table_count
);
4805 defsubr (&Shash_table_rehash_size
);
4806 defsubr (&Shash_table_rehash_threshold
);
4807 defsubr (&Shash_table_size
);
4808 defsubr (&Shash_table_test
);
4809 defsubr (&Shash_table_weakness
);
4810 defsubr (&Shash_table_p
);
4811 defsubr (&Sclrhash
);
4812 defsubr (&Sgethash
);
4813 defsubr (&Sputhash
);
4814 defsubr (&Sremhash
);
4815 defsubr (&Smaphash
);
4816 defsubr (&Sdefine_hash_table_test
);
4818 Qstring_lessp
= intern_c_string ("string-lessp");
4819 staticpro (&Qstring_lessp
);
4820 Qprovide
= intern_c_string ("provide");
4821 staticpro (&Qprovide
);
4822 Qrequire
= intern_c_string ("require");
4823 staticpro (&Qrequire
);
4824 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4825 staticpro (&Qyes_or_no_p_history
);
4826 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4827 staticpro (&Qcursor_in_echo_area
);
4828 Qwidget_type
= intern_c_string ("widget-type");
4829 staticpro (&Qwidget_type
);
4831 staticpro (&string_char_byte_cache_string
);
4832 string_char_byte_cache_string
= Qnil
;
4834 require_nesting_list
= Qnil
;
4835 staticpro (&require_nesting_list
);
4837 Fset (Qyes_or_no_p_history
, Qnil
);
4839 DEFVAR_LISP ("features", &Vfeatures
,
4840 doc
: /* A list of symbols which are the features of the executing Emacs.
4841 Used by `featurep' and `require', and altered by `provide'. */);
4842 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4843 Qsubfeatures
= intern_c_string ("subfeatures");
4844 staticpro (&Qsubfeatures
);
4846 #ifdef HAVE_LANGINFO_CODESET
4847 Qcodeset
= intern_c_string ("codeset");
4848 staticpro (&Qcodeset
);
4849 Qdays
= intern_c_string ("days");
4851 Qmonths
= intern_c_string ("months");
4852 staticpro (&Qmonths
);
4853 Qpaper
= intern_c_string ("paper");
4854 staticpro (&Qpaper
);
4855 #endif /* HAVE_LANGINFO_CODESET */
4857 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4858 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4859 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4860 invoked by mouse clicks and mouse menu items.
4862 On some platforms, file selection dialogs are also enabled if this is
4866 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
4867 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4868 This applies to commands from menus and tool bar buttons even when
4869 they are initiated from the keyboard. If `use-dialog-box' is nil,
4870 that disables the use of a file dialog, regardless of the value of
4872 use_file_dialog
= 1;
4874 defsubr (&Sidentity
);
4877 defsubr (&Ssafe_length
);
4878 defsubr (&Sstring_bytes
);
4879 defsubr (&Sstring_equal
);
4880 defsubr (&Scompare_strings
);
4881 defsubr (&Sstring_lessp
);
4884 defsubr (&Svconcat
);
4885 defsubr (&Scopy_sequence
);
4886 defsubr (&Sstring_make_multibyte
);
4887 defsubr (&Sstring_make_unibyte
);
4888 defsubr (&Sstring_as_multibyte
);
4889 defsubr (&Sstring_as_unibyte
);
4890 defsubr (&Sstring_to_multibyte
);
4891 defsubr (&Sstring_to_unibyte
);
4892 defsubr (&Scopy_alist
);
4893 defsubr (&Ssubstring
);
4894 defsubr (&Ssubstring_no_properties
);
4907 defsubr (&Snreverse
);
4908 defsubr (&Sreverse
);
4910 defsubr (&Splist_get
);
4912 defsubr (&Splist_put
);
4914 defsubr (&Slax_plist_get
);
4915 defsubr (&Slax_plist_put
);
4918 defsubr (&Sequal_including_properties
);
4919 defsubr (&Sfillarray
);
4920 defsubr (&Sclear_string
);
4924 defsubr (&Smapconcat
);
4925 defsubr (&Syes_or_no_p
);
4926 defsubr (&Sload_average
);
4927 defsubr (&Sfeaturep
);
4928 defsubr (&Srequire
);
4929 defsubr (&Sprovide
);
4930 defsubr (&Splist_member
);
4931 defsubr (&Swidget_put
);
4932 defsubr (&Swidget_get
);
4933 defsubr (&Swidget_apply
);
4934 defsubr (&Sbase64_encode_region
);
4935 defsubr (&Sbase64_decode_region
);
4936 defsubr (&Sbase64_encode_string
);
4937 defsubr (&Sbase64_decode_string
);
4939 defsubr (&Slocale_info
);
4948 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
4949 (do not change this comment) */