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 Takes one argument, which is the string to display to ask the question.
2464 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2465 The user must confirm the answer with RET,
2466 and can edit it until it has been confirmed.
2468 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2469 is nil, and `use-dialog-box' is non-nil.
2470 usage: (yes-or-no-p PROMPT &rest ARGS) */)
2471 (int nargs
, Lisp_Object
*args
)
2473 register Lisp_Object ans
;
2474 struct gcpro gcpro1
;
2475 Lisp_Object prompt
= Fformat (nargs
, args
);
2478 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2479 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2483 Lisp_Object pane
, menu
, obj
;
2484 redisplay_preserve_echo_area (4);
2485 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2486 Fcons (Fcons (build_string ("No"), Qnil
),
2489 menu
= Fcons (prompt
, pane
);
2490 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2494 #endif /* HAVE_MENUS */
2496 prompt
= concat2 (prompt
, build_string ("(yes or no) "));
2501 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2502 Qyes_or_no_p_history
, Qnil
,
2504 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2509 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2517 message ("Please answer yes or no.");
2518 Fsleep_for (make_number (2), Qnil
);
2522 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2523 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2525 Each of the three load averages is multiplied by 100, then converted
2528 When USE-FLOATS is non-nil, floats will be used instead of integers.
2529 These floats are not multiplied by 100.
2531 If the 5-minute or 15-minute load averages are not available, return a
2532 shortened list, containing only those averages which are available.
2534 An error is thrown if the load average can't be obtained. In some
2535 cases making it work would require Emacs being installed setuid or
2536 setgid so that it can read kernel information, and that usually isn't
2538 (Lisp_Object use_floats
)
2541 int loads
= getloadavg (load_ave
, 3);
2542 Lisp_Object ret
= Qnil
;
2545 error ("load-average not implemented for this operating system");
2549 Lisp_Object load
= (NILP (use_floats
) ?
2550 make_number ((int) (100.0 * load_ave
[loads
]))
2551 : make_float (load_ave
[loads
]));
2552 ret
= Fcons (load
, ret
);
2558 Lisp_Object Vfeatures
, Qsubfeatures
;
2560 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2561 doc
: /* Return t if FEATURE is present in this Emacs.
2563 Use this to conditionalize execution of lisp code based on the
2564 presence or absence of Emacs or environment extensions.
2565 Use `provide' to declare that a feature is available. This function
2566 looks at the value of the variable `features'. The optional argument
2567 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2568 (Lisp_Object feature
, Lisp_Object subfeature
)
2570 register Lisp_Object tem
;
2571 CHECK_SYMBOL (feature
);
2572 tem
= Fmemq (feature
, Vfeatures
);
2573 if (!NILP (tem
) && !NILP (subfeature
))
2574 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2575 return (NILP (tem
)) ? Qnil
: Qt
;
2578 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2579 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2580 The optional argument SUBFEATURES should be a list of symbols listing
2581 particular subfeatures supported in this version of FEATURE. */)
2582 (Lisp_Object feature
, Lisp_Object subfeatures
)
2584 register Lisp_Object tem
;
2585 CHECK_SYMBOL (feature
);
2586 CHECK_LIST (subfeatures
);
2587 if (!NILP (Vautoload_queue
))
2588 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2590 tem
= Fmemq (feature
, Vfeatures
);
2592 Vfeatures
= Fcons (feature
, Vfeatures
);
2593 if (!NILP (subfeatures
))
2594 Fput (feature
, Qsubfeatures
, subfeatures
);
2595 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2597 /* Run any load-hooks for this file. */
2598 tem
= Fassq (feature
, Vafter_load_alist
);
2600 Fprogn (XCDR (tem
));
2605 /* `require' and its subroutines. */
2607 /* List of features currently being require'd, innermost first. */
2609 Lisp_Object require_nesting_list
;
2612 require_unwind (Lisp_Object old_value
)
2614 return require_nesting_list
= old_value
;
2617 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2618 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2619 If FEATURE is not a member of the list `features', then the feature
2620 is not loaded; so load the file FILENAME.
2621 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2622 and `load' will try to load this name appended with the suffix `.elc' or
2623 `.el', in that order. The name without appended suffix will not be used.
2624 If the optional third argument NOERROR is non-nil,
2625 then return nil if the file is not found instead of signaling an error.
2626 Normally the return value is FEATURE.
2627 The normal messages at start and end of loading FILENAME are suppressed. */)
2628 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2630 register Lisp_Object tem
;
2631 struct gcpro gcpro1
, gcpro2
;
2632 int from_file
= load_in_progress
;
2634 CHECK_SYMBOL (feature
);
2636 /* Record the presence of `require' in this file
2637 even if the feature specified is already loaded.
2638 But not more than once in any file,
2639 and not when we aren't loading or reading from a file. */
2641 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2642 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2647 tem
= Fcons (Qrequire
, feature
);
2648 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2649 LOADHIST_ATTACH (tem
);
2651 tem
= Fmemq (feature
, Vfeatures
);
2655 int count
= SPECPDL_INDEX ();
2658 /* This is to make sure that loadup.el gives a clear picture
2659 of what files are preloaded and when. */
2660 if (! NILP (Vpurify_flag
))
2661 error ("(require %s) while preparing to dump",
2662 SDATA (SYMBOL_NAME (feature
)));
2664 /* A certain amount of recursive `require' is legitimate,
2665 but if we require the same feature recursively 3 times,
2667 tem
= require_nesting_list
;
2668 while (! NILP (tem
))
2670 if (! NILP (Fequal (feature
, XCAR (tem
))))
2675 error ("Recursive `require' for feature `%s'",
2676 SDATA (SYMBOL_NAME (feature
)));
2678 /* Update the list for any nested `require's that occur. */
2679 record_unwind_protect (require_unwind
, require_nesting_list
);
2680 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2682 /* Value saved here is to be restored into Vautoload_queue */
2683 record_unwind_protect (un_autoload
, Vautoload_queue
);
2684 Vautoload_queue
= Qt
;
2686 /* Load the file. */
2687 GCPRO2 (feature
, filename
);
2688 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2689 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2692 /* If load failed entirely, return nil. */
2694 return unbind_to (count
, Qnil
);
2696 tem
= Fmemq (feature
, Vfeatures
);
2698 error ("Required feature `%s' was not provided",
2699 SDATA (SYMBOL_NAME (feature
)));
2701 /* Once loading finishes, don't undo it. */
2702 Vautoload_queue
= Qt
;
2703 feature
= unbind_to (count
, feature
);
2709 /* Primitives for work of the "widget" library.
2710 In an ideal world, this section would not have been necessary.
2711 However, lisp function calls being as slow as they are, it turns
2712 out that some functions in the widget library (wid-edit.el) are the
2713 bottleneck of Widget operation. Here is their translation to C,
2714 for the sole reason of efficiency. */
2716 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2717 doc
: /* Return non-nil if PLIST has the property PROP.
2718 PLIST is a property list, which is a list of the form
2719 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2720 Unlike `plist-get', this allows you to distinguish between a missing
2721 property and a property with the value nil.
2722 The value is actually the tail of PLIST whose car is PROP. */)
2723 (Lisp_Object plist
, Lisp_Object prop
)
2725 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2728 plist
= XCDR (plist
);
2729 plist
= CDR (plist
);
2734 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2735 doc
: /* In WIDGET, set PROPERTY to VALUE.
2736 The value can later be retrieved with `widget-get'. */)
2737 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2739 CHECK_CONS (widget
);
2740 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2744 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2745 doc
: /* In WIDGET, get the value of PROPERTY.
2746 The value could either be specified when the widget was created, or
2747 later with `widget-put'. */)
2748 (Lisp_Object widget
, Lisp_Object property
)
2756 CHECK_CONS (widget
);
2757 tmp
= Fplist_member (XCDR (widget
), property
);
2763 tmp
= XCAR (widget
);
2766 widget
= Fget (tmp
, Qwidget_type
);
2770 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2771 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2772 ARGS are passed as extra arguments to the function.
2773 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 /* This function can GC. */
2777 Lisp_Object newargs
[3];
2778 struct gcpro gcpro1
, gcpro2
;
2781 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2782 newargs
[1] = args
[0];
2783 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2784 GCPRO2 (newargs
[0], newargs
[2]);
2785 result
= Fapply (3, newargs
);
2790 #ifdef HAVE_LANGINFO_CODESET
2791 #include <langinfo.h>
2794 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2795 doc
: /* Access locale data ITEM for the current C locale, if available.
2796 ITEM should be one of the following:
2798 `codeset', returning the character set as a string (locale item CODESET);
2800 `days', returning a 7-element vector of day names (locale items DAY_n);
2802 `months', returning a 12-element vector of month names (locale items MON_n);
2804 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2805 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2807 If the system can't provide such information through a call to
2808 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2810 See also Info node `(libc)Locales'.
2812 The data read from the system are decoded using `locale-coding-system'. */)
2816 #ifdef HAVE_LANGINFO_CODESET
2818 if (EQ (item
, Qcodeset
))
2820 str
= nl_langinfo (CODESET
);
2821 return build_string (str
);
2824 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2826 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2827 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2829 struct gcpro gcpro1
;
2831 synchronize_system_time_locale ();
2832 for (i
= 0; i
< 7; i
++)
2834 str
= nl_langinfo (days
[i
]);
2835 val
= make_unibyte_string (str
, strlen (str
));
2836 /* Fixme: Is this coding system necessarily right, even if
2837 it is consistent with CODESET? If not, what to do? */
2838 Faset (v
, make_number (i
),
2839 code_convert_string_norecord (val
, Vlocale_coding_system
,
2847 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2849 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2850 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2851 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2853 struct gcpro gcpro1
;
2855 synchronize_system_time_locale ();
2856 for (i
= 0; i
< 12; i
++)
2858 str
= nl_langinfo (months
[i
]);
2859 val
= make_unibyte_string (str
, strlen (str
));
2860 Faset (v
, make_number (i
),
2861 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2867 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2868 but is in the locale files. This could be used by ps-print. */
2870 else if (EQ (item
, Qpaper
))
2872 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2873 make_number (nl_langinfo (PAPER_HEIGHT
)));
2875 #endif /* PAPER_WIDTH */
2876 #endif /* HAVE_LANGINFO_CODESET*/
2880 /* base64 encode/decode functions (RFC 2045).
2881 Based on code from GNU recode. */
2883 #define MIME_LINE_LENGTH 76
2885 #define IS_ASCII(Character) \
2887 #define IS_BASE64(Character) \
2888 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2889 #define IS_BASE64_IGNORABLE(Character) \
2890 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2891 || (Character) == '\f' || (Character) == '\r')
2893 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2894 character or return retval if there are no characters left to
2896 #define READ_QUADRUPLET_BYTE(retval) \
2901 if (nchars_return) \
2902 *nchars_return = nchars; \
2907 while (IS_BASE64_IGNORABLE (c))
2909 /* Table of characters coding the 64 values. */
2910 static const char base64_value_to_char
[64] =
2912 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2913 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2914 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2915 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2916 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2917 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2918 '8', '9', '+', '/' /* 60-63 */
2921 /* Table of base64 values for first 128 characters. */
2922 static const short base64_char_to_value
[128] =
2924 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2925 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2926 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2927 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2928 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2929 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2930 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2931 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2932 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2933 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2934 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2935 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2936 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2939 /* The following diagram shows the logical steps by which three octets
2940 get transformed into four base64 characters.
2942 .--------. .--------. .--------.
2943 |aaaaaabb| |bbbbcccc| |ccdddddd|
2944 `--------' `--------' `--------'
2946 .--------+--------+--------+--------.
2947 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2948 `--------+--------+--------+--------'
2950 .--------+--------+--------+--------.
2951 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2952 `--------+--------+--------+--------'
2954 The octets are divided into 6 bit chunks, which are then encoded into
2955 base64 characters. */
2958 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2959 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2962 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2964 doc
: /* Base64-encode the region between BEG and END.
2965 Return the length of the encoded text.
2966 Optional third argument NO-LINE-BREAK means do not break long lines
2967 into shorter lines. */)
2968 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2971 EMACS_INT allength
, length
;
2972 EMACS_INT ibeg
, iend
, encoded_length
;
2973 EMACS_INT old_pos
= PT
;
2976 validate_region (&beg
, &end
);
2978 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2979 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2980 move_gap_both (XFASTINT (beg
), ibeg
);
2982 /* We need to allocate enough room for encoding the text.
2983 We need 33 1/3% more space, plus a newline every 76
2984 characters, and then we round up. */
2985 length
= iend
- ibeg
;
2986 allength
= length
+ length
/3 + 1;
2987 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2989 SAFE_ALLOCA (encoded
, char *, allength
);
2990 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2991 NILP (no_line_break
),
2992 !NILP (current_buffer
->enable_multibyte_characters
));
2993 if (encoded_length
> allength
)
2996 if (encoded_length
< 0)
2998 /* The encoding wasn't possible. */
3000 error ("Multibyte character in data for base64 encoding");
3003 /* Now we have encoded the region, so we insert the new contents
3004 and delete the old. (Insert first in order to preserve markers.) */
3005 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3006 insert (encoded
, encoded_length
);
3008 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3010 /* If point was outside of the region, restore it exactly; else just
3011 move to the beginning of the region. */
3012 if (old_pos
>= XFASTINT (end
))
3013 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3014 else if (old_pos
> XFASTINT (beg
))
3015 old_pos
= XFASTINT (beg
);
3018 /* We return the length of the encoded text. */
3019 return make_number (encoded_length
);
3022 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3024 doc
: /* Base64-encode STRING and return the result.
3025 Optional second argument NO-LINE-BREAK means do not break long lines
3026 into shorter lines. */)
3027 (Lisp_Object string
, Lisp_Object no_line_break
)
3029 EMACS_INT allength
, length
, encoded_length
;
3031 Lisp_Object encoded_string
;
3034 CHECK_STRING (string
);
3036 /* We need to allocate enough room for encoding the text.
3037 We need 33 1/3% more space, plus a newline every 76
3038 characters, and then we round up. */
3039 length
= SBYTES (string
);
3040 allength
= length
+ length
/3 + 1;
3041 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3043 /* We need to allocate enough room for decoding the text. */
3044 SAFE_ALLOCA (encoded
, char *, allength
);
3046 encoded_length
= base64_encode_1 (SDATA (string
),
3047 encoded
, length
, NILP (no_line_break
),
3048 STRING_MULTIBYTE (string
));
3049 if (encoded_length
> allength
)
3052 if (encoded_length
< 0)
3054 /* The encoding wasn't possible. */
3056 error ("Multibyte character in data for base64 encoding");
3059 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3062 return encoded_string
;
3066 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3067 int line_break
, int multibyte
)
3080 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3081 if (CHAR_BYTE8_P (c
))
3082 c
= CHAR_TO_BYTE8 (c
);
3090 /* Wrap line every 76 characters. */
3094 if (counter
< MIME_LINE_LENGTH
/ 4)
3103 /* Process first byte of a triplet. */
3105 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3106 value
= (0x03 & c
) << 4;
3108 /* Process second byte of a triplet. */
3112 *e
++ = base64_value_to_char
[value
];
3120 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3121 if (CHAR_BYTE8_P (c
))
3122 c
= CHAR_TO_BYTE8 (c
);
3130 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3131 value
= (0x0f & c
) << 2;
3133 /* Process third byte of a triplet. */
3137 *e
++ = base64_value_to_char
[value
];
3144 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3145 if (CHAR_BYTE8_P (c
))
3146 c
= CHAR_TO_BYTE8 (c
);
3154 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3155 *e
++ = base64_value_to_char
[0x3f & c
];
3162 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3164 doc
: /* Base64-decode the region between BEG and END.
3165 Return the length of the decoded text.
3166 If the region can't be decoded, signal an error and don't modify the buffer. */)
3167 (Lisp_Object beg
, Lisp_Object end
)
3169 EMACS_INT ibeg
, iend
, length
, allength
;
3171 EMACS_INT old_pos
= PT
;
3172 EMACS_INT decoded_length
;
3173 EMACS_INT inserted_chars
;
3174 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3177 validate_region (&beg
, &end
);
3179 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3180 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3182 length
= iend
- ibeg
;
3184 /* We need to allocate enough room for decoding the text. If we are
3185 working on a multibyte buffer, each decoded code may occupy at
3187 allength
= multibyte
? length
* 2 : length
;
3188 SAFE_ALLOCA (decoded
, char *, allength
);
3190 move_gap_both (XFASTINT (beg
), ibeg
);
3191 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3192 multibyte
, &inserted_chars
);
3193 if (decoded_length
> allength
)
3196 if (decoded_length
< 0)
3198 /* The decoding wasn't possible. */
3200 error ("Invalid base64 data");
3203 /* Now we have decoded the region, so we insert the new contents
3204 and delete the old. (Insert first in order to preserve markers.) */
3205 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3206 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3209 /* Delete the original text. */
3210 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3211 iend
+ decoded_length
, 1);
3213 /* If point was outside of the region, restore it exactly; else just
3214 move to the beginning of the region. */
3215 if (old_pos
>= XFASTINT (end
))
3216 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3217 else if (old_pos
> XFASTINT (beg
))
3218 old_pos
= XFASTINT (beg
);
3219 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3221 return make_number (inserted_chars
);
3224 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3226 doc
: /* Base64-decode STRING and return the result. */)
3227 (Lisp_Object string
)
3230 EMACS_INT length
, decoded_length
;
3231 Lisp_Object decoded_string
;
3234 CHECK_STRING (string
);
3236 length
= SBYTES (string
);
3237 /* We need to allocate enough room for decoding the text. */
3238 SAFE_ALLOCA (decoded
, char *, length
);
3240 /* The decoded result should be unibyte. */
3241 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3243 if (decoded_length
> length
)
3245 else if (decoded_length
>= 0)
3246 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3248 decoded_string
= Qnil
;
3251 if (!STRINGP (decoded_string
))
3252 error ("Invalid base64 data");
3254 return decoded_string
;
3257 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3258 MULTIBYTE is nonzero, the decoded result should be in multibyte
3259 form. If NCHARS_RETRUN is not NULL, store the number of produced
3260 characters in *NCHARS_RETURN. */
3263 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3264 int multibyte
, EMACS_INT
*nchars_return
)
3266 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3269 unsigned long value
;
3270 EMACS_INT nchars
= 0;
3274 /* Process first byte of a quadruplet. */
3276 READ_QUADRUPLET_BYTE (e
-to
);
3280 value
= base64_char_to_value
[c
] << 18;
3282 /* Process second byte of a quadruplet. */
3284 READ_QUADRUPLET_BYTE (-1);
3288 value
|= base64_char_to_value
[c
] << 12;
3290 c
= (unsigned char) (value
>> 16);
3291 if (multibyte
&& c
>= 128)
3292 e
+= BYTE8_STRING (c
, e
);
3297 /* Process third byte of a quadruplet. */
3299 READ_QUADRUPLET_BYTE (-1);
3303 READ_QUADRUPLET_BYTE (-1);
3312 value
|= base64_char_to_value
[c
] << 6;
3314 c
= (unsigned char) (0xff & value
>> 8);
3315 if (multibyte
&& c
>= 128)
3316 e
+= BYTE8_STRING (c
, e
);
3321 /* Process fourth byte of a quadruplet. */
3323 READ_QUADRUPLET_BYTE (-1);
3330 value
|= base64_char_to_value
[c
];
3332 c
= (unsigned char) (0xff & value
);
3333 if (multibyte
&& c
>= 128)
3334 e
+= BYTE8_STRING (c
, e
);
3343 /***********************************************************************
3345 ***** Hash Tables *****
3347 ***********************************************************************/
3349 /* Implemented by gerd@gnu.org. This hash table implementation was
3350 inspired by CMUCL hash tables. */
3354 1. For small tables, association lists are probably faster than
3355 hash tables because they have lower overhead.
3357 For uses of hash tables where the O(1) behavior of table
3358 operations is not a requirement, it might therefore be a good idea
3359 not to hash. Instead, we could just do a linear search in the
3360 key_and_value vector of the hash table. This could be done
3361 if a `:linear-search t' argument is given to make-hash-table. */
3364 /* The list of all weak hash tables. Don't staticpro this one. */
3366 struct Lisp_Hash_Table
*weak_hash_tables
;
3368 /* Various symbols. */
3370 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3371 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3372 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3374 /* Function prototypes. */
3376 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3377 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3378 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3379 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3380 Lisp_Object
, unsigned);
3381 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3382 Lisp_Object
, unsigned);
3383 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3384 unsigned, Lisp_Object
, unsigned);
3385 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3386 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3387 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3388 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3390 static unsigned sxhash_string (unsigned char *, int);
3391 static unsigned sxhash_list (Lisp_Object
, int);
3392 static unsigned sxhash_vector (Lisp_Object
, int);
3393 static unsigned sxhash_bool_vector (Lisp_Object
);
3394 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3398 /***********************************************************************
3400 ***********************************************************************/
3402 /* If OBJ is a Lisp hash table, return a pointer to its struct
3403 Lisp_Hash_Table. Otherwise, signal an error. */
3405 static struct Lisp_Hash_Table
*
3406 check_hash_table (Lisp_Object obj
)
3408 CHECK_HASH_TABLE (obj
);
3409 return XHASH_TABLE (obj
);
3413 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3417 next_almost_prime (int n
)
3429 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3430 which USED[I] is non-zero. If found at index I in ARGS, set
3431 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3432 -1. This function is used to extract a keyword/argument pair from
3433 a DEFUN parameter list. */
3436 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3440 for (i
= 0; i
< nargs
- 1; ++i
)
3441 if (!used
[i
] && EQ (args
[i
], key
))
3456 /* Return a Lisp vector which has the same contents as VEC but has
3457 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3458 vector that are not copied from VEC are set to INIT. */
3461 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3463 struct Lisp_Vector
*v
;
3466 xassert (VECTORP (vec
));
3467 old_size
= ASIZE (vec
);
3468 xassert (new_size
>= old_size
);
3470 v
= allocate_vector (new_size
);
3471 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3472 for (i
= old_size
; i
< new_size
; ++i
)
3473 v
->contents
[i
] = init
;
3474 XSETVECTOR (vec
, v
);
3479 /***********************************************************************
3481 ***********************************************************************/
3483 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3484 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3485 KEY2 are the same. */
3488 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3490 return (FLOATP (key1
)
3492 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3496 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3497 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3498 KEY2 are the same. */
3501 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3503 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3507 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3508 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3509 if KEY1 and KEY2 are the same. */
3512 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3516 Lisp_Object args
[3];
3518 args
[0] = h
->user_cmp_function
;
3521 return !NILP (Ffuncall (3, args
));
3528 /* Value is a hash code for KEY for use in hash table H which uses
3529 `eq' to compare keys. The hash code returned is guaranteed to fit
3530 in a Lisp integer. */
3533 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3535 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3536 xassert ((hash
& ~INTMASK
) == 0);
3541 /* Value is a hash code for KEY for use in hash table H which uses
3542 `eql' to compare keys. The hash code returned is guaranteed to fit
3543 in a Lisp integer. */
3546 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3550 hash
= sxhash (key
, 0);
3552 hash
= XUINT (key
) ^ XTYPE (key
);
3553 xassert ((hash
& ~INTMASK
) == 0);
3558 /* Value is a hash code for KEY for use in hash table H which uses
3559 `equal' to compare keys. The hash code returned is guaranteed to fit
3560 in a Lisp integer. */
3563 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3565 unsigned hash
= sxhash (key
, 0);
3566 xassert ((hash
& ~INTMASK
) == 0);
3571 /* Value is a hash code for KEY for use in hash table H which uses as
3572 user-defined function to compare keys. The hash code returned is
3573 guaranteed to fit in a Lisp integer. */
3576 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3578 Lisp_Object args
[2], hash
;
3580 args
[0] = h
->user_hash_function
;
3582 hash
= Ffuncall (2, args
);
3583 if (!INTEGERP (hash
))
3584 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3585 return XUINT (hash
);
3589 /* Create and initialize a new hash table.
3591 TEST specifies the test the hash table will use to compare keys.
3592 It must be either one of the predefined tests `eq', `eql' or
3593 `equal' or a symbol denoting a user-defined test named TEST with
3594 test and hash functions USER_TEST and USER_HASH.
3596 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3598 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3599 new size when it becomes full is computed by adding REHASH_SIZE to
3600 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3601 table's new size is computed by multiplying its old size with
3604 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3605 be resized when the ratio of (number of entries in the table) /
3606 (table size) is >= REHASH_THRESHOLD.
3608 WEAK specifies the weakness of the table. If non-nil, it must be
3609 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3612 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3613 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3614 Lisp_Object user_test
, Lisp_Object user_hash
)
3616 struct Lisp_Hash_Table
*h
;
3618 int index_size
, i
, sz
;
3620 /* Preconditions. */
3621 xassert (SYMBOLP (test
));
3622 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3623 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3624 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3625 xassert (FLOATP (rehash_threshold
)
3626 && XFLOATINT (rehash_threshold
) > 0
3627 && XFLOATINT (rehash_threshold
) <= 1.0);
3629 if (XFASTINT (size
) == 0)
3630 size
= make_number (1);
3632 /* Allocate a table and initialize it. */
3633 h
= allocate_hash_table ();
3635 /* Initialize hash table slots. */
3636 sz
= XFASTINT (size
);
3639 if (EQ (test
, Qeql
))
3641 h
->cmpfn
= cmpfn_eql
;
3642 h
->hashfn
= hashfn_eql
;
3644 else if (EQ (test
, Qeq
))
3647 h
->hashfn
= hashfn_eq
;
3649 else if (EQ (test
, Qequal
))
3651 h
->cmpfn
= cmpfn_equal
;
3652 h
->hashfn
= hashfn_equal
;
3656 h
->user_cmp_function
= user_test
;
3657 h
->user_hash_function
= user_hash
;
3658 h
->cmpfn
= cmpfn_user_defined
;
3659 h
->hashfn
= hashfn_user_defined
;
3663 h
->rehash_threshold
= rehash_threshold
;
3664 h
->rehash_size
= rehash_size
;
3666 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3667 h
->hash
= Fmake_vector (size
, Qnil
);
3668 h
->next
= Fmake_vector (size
, Qnil
);
3669 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3670 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3671 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3673 /* Set up the free list. */
3674 for (i
= 0; i
< sz
- 1; ++i
)
3675 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3676 h
->next_free
= make_number (0);
3678 XSET_HASH_TABLE (table
, h
);
3679 xassert (HASH_TABLE_P (table
));
3680 xassert (XHASH_TABLE (table
) == h
);
3682 /* Maybe add this hash table to the list of all weak hash tables. */
3684 h
->next_weak
= NULL
;
3687 h
->next_weak
= weak_hash_tables
;
3688 weak_hash_tables
= h
;
3695 /* Return a copy of hash table H1. Keys and values are not copied,
3696 only the table itself is. */
3699 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3702 struct Lisp_Hash_Table
*h2
;
3703 struct Lisp_Vector
*next
;
3705 h2
= allocate_hash_table ();
3706 next
= h2
->vec_next
;
3707 memcpy (h2
, h1
, sizeof *h2
);
3708 h2
->vec_next
= next
;
3709 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3710 h2
->hash
= Fcopy_sequence (h1
->hash
);
3711 h2
->next
= Fcopy_sequence (h1
->next
);
3712 h2
->index
= Fcopy_sequence (h1
->index
);
3713 XSET_HASH_TABLE (table
, h2
);
3715 /* Maybe add this hash table to the list of all weak hash tables. */
3716 if (!NILP (h2
->weak
))
3718 h2
->next_weak
= weak_hash_tables
;
3719 weak_hash_tables
= h2
;
3726 /* Resize hash table H if it's too full. If H cannot be resized
3727 because it's already too large, throw an error. */
3730 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3732 if (NILP (h
->next_free
))
3734 int old_size
= HASH_TABLE_SIZE (h
);
3735 int i
, new_size
, index_size
;
3738 if (INTEGERP (h
->rehash_size
))
3739 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3741 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3742 new_size
= max (old_size
+ 1, new_size
);
3743 index_size
= next_almost_prime ((int)
3745 / XFLOATINT (h
->rehash_threshold
)));
3746 /* Assignment to EMACS_INT stops GCC whining about limited range
3748 nsize
= max (index_size
, 2 * new_size
);
3749 if (nsize
> MOST_POSITIVE_FIXNUM
)
3750 error ("Hash table too large to resize");
3752 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3753 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3754 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3755 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3757 /* Update the free list. Do it so that new entries are added at
3758 the end of the free list. This makes some operations like
3760 for (i
= old_size
; i
< new_size
- 1; ++i
)
3761 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3763 if (!NILP (h
->next_free
))
3765 Lisp_Object last
, next
;
3767 last
= h
->next_free
;
3768 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3772 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3775 XSETFASTINT (h
->next_free
, old_size
);
3778 for (i
= 0; i
< old_size
; ++i
)
3779 if (!NILP (HASH_HASH (h
, i
)))
3781 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3782 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3783 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3784 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3790 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3791 the hash code of KEY. Value is the index of the entry in H
3792 matching KEY, or -1 if not found. */
3795 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3798 int start_of_bucket
;
3801 hash_code
= h
->hashfn (h
, key
);
3805 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3806 idx
= HASH_INDEX (h
, start_of_bucket
);
3808 /* We need not gcpro idx since it's either an integer or nil. */
3811 int i
= XFASTINT (idx
);
3812 if (EQ (key
, HASH_KEY (h
, i
))
3814 && h
->cmpfn (h
, key
, hash_code
,
3815 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3817 idx
= HASH_NEXT (h
, i
);
3820 return NILP (idx
) ? -1 : XFASTINT (idx
);
3824 /* Put an entry into hash table H that associates KEY with VALUE.
3825 HASH is a previously computed hash code of KEY.
3826 Value is the index of the entry in H matching KEY. */
3829 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3831 int start_of_bucket
, i
;
3833 xassert ((hash
& ~INTMASK
) == 0);
3835 /* Increment count after resizing because resizing may fail. */
3836 maybe_resize_hash_table (h
);
3839 /* Store key/value in the key_and_value vector. */
3840 i
= XFASTINT (h
->next_free
);
3841 h
->next_free
= HASH_NEXT (h
, i
);
3842 HASH_KEY (h
, i
) = key
;
3843 HASH_VALUE (h
, i
) = value
;
3845 /* Remember its hash code. */
3846 HASH_HASH (h
, i
) = make_number (hash
);
3848 /* Add new entry to its collision chain. */
3849 start_of_bucket
= hash
% ASIZE (h
->index
);
3850 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3851 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3856 /* Remove the entry matching KEY from hash table H, if there is one. */
3859 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3862 int start_of_bucket
;
3863 Lisp_Object idx
, prev
;
3865 hash_code
= h
->hashfn (h
, key
);
3866 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3867 idx
= HASH_INDEX (h
, start_of_bucket
);
3870 /* We need not gcpro idx, prev since they're either integers or nil. */
3873 int i
= XFASTINT (idx
);
3875 if (EQ (key
, HASH_KEY (h
, i
))
3877 && h
->cmpfn (h
, key
, hash_code
,
3878 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3880 /* Take entry out of collision chain. */
3882 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3884 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3886 /* Clear slots in key_and_value and add the slots to
3888 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3889 HASH_NEXT (h
, i
) = h
->next_free
;
3890 h
->next_free
= make_number (i
);
3892 xassert (h
->count
>= 0);
3898 idx
= HASH_NEXT (h
, i
);
3904 /* Clear hash table H. */
3907 hash_clear (struct Lisp_Hash_Table
*h
)
3911 int i
, size
= HASH_TABLE_SIZE (h
);
3913 for (i
= 0; i
< size
; ++i
)
3915 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3916 HASH_KEY (h
, i
) = Qnil
;
3917 HASH_VALUE (h
, i
) = Qnil
;
3918 HASH_HASH (h
, i
) = Qnil
;
3921 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3922 ASET (h
->index
, i
, Qnil
);
3924 h
->next_free
= make_number (0);
3931 /************************************************************************
3933 ************************************************************************/
3936 init_weak_hash_tables (void)
3938 weak_hash_tables
= NULL
;
3941 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3942 entries from the table that don't survive the current GC.
3943 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3944 non-zero if anything was marked. */
3947 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3949 int bucket
, n
, marked
;
3951 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3954 for (bucket
= 0; bucket
< n
; ++bucket
)
3956 Lisp_Object idx
, next
, prev
;
3958 /* Follow collision chain, removing entries that
3959 don't survive this garbage collection. */
3961 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3963 int i
= XFASTINT (idx
);
3964 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3965 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3968 if (EQ (h
->weak
, Qkey
))
3969 remove_p
= !key_known_to_survive_p
;
3970 else if (EQ (h
->weak
, Qvalue
))
3971 remove_p
= !value_known_to_survive_p
;
3972 else if (EQ (h
->weak
, Qkey_or_value
))
3973 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3974 else if (EQ (h
->weak
, Qkey_and_value
))
3975 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3979 next
= HASH_NEXT (h
, i
);
3981 if (remove_entries_p
)
3985 /* Take out of collision chain. */
3987 HASH_INDEX (h
, bucket
) = next
;
3989 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3991 /* Add to free list. */
3992 HASH_NEXT (h
, i
) = h
->next_free
;
3995 /* Clear key, value, and hash. */
3996 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3997 HASH_HASH (h
, i
) = Qnil
;
4010 /* Make sure key and value survive. */
4011 if (!key_known_to_survive_p
)
4013 mark_object (HASH_KEY (h
, i
));
4017 if (!value_known_to_survive_p
)
4019 mark_object (HASH_VALUE (h
, i
));
4030 /* Remove elements from weak hash tables that don't survive the
4031 current garbage collection. Remove weak tables that don't survive
4032 from Vweak_hash_tables. Called from gc_sweep. */
4035 sweep_weak_hash_tables (void)
4037 struct Lisp_Hash_Table
*h
, *used
, *next
;
4040 /* Mark all keys and values that are in use. Keep on marking until
4041 there is no more change. This is necessary for cases like
4042 value-weak table A containing an entry X -> Y, where Y is used in a
4043 key-weak table B, Z -> Y. If B comes after A in the list of weak
4044 tables, X -> Y might be removed from A, although when looking at B
4045 one finds that it shouldn't. */
4049 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4051 if (h
->size
& ARRAY_MARK_FLAG
)
4052 marked
|= sweep_weak_table (h
, 0);
4057 /* Remove tables and entries that aren't used. */
4058 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4060 next
= h
->next_weak
;
4062 if (h
->size
& ARRAY_MARK_FLAG
)
4064 /* TABLE is marked as used. Sweep its contents. */
4066 sweep_weak_table (h
, 1);
4068 /* Add table to the list of used weak hash tables. */
4069 h
->next_weak
= used
;
4074 weak_hash_tables
= used
;
4079 /***********************************************************************
4080 Hash Code Computation
4081 ***********************************************************************/
4083 /* Maximum depth up to which to dive into Lisp structures. */
4085 #define SXHASH_MAX_DEPTH 3
4087 /* Maximum length up to which to take list and vector elements into
4090 #define SXHASH_MAX_LEN 7
4092 /* Combine two integers X and Y for hashing. */
4094 #define SXHASH_COMBINE(X, Y) \
4095 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4099 /* Return a hash for string PTR which has length LEN. The hash
4100 code returned is guaranteed to fit in a Lisp integer. */
4103 sxhash_string (unsigned char *ptr
, int len
)
4105 unsigned char *p
= ptr
;
4106 unsigned char *end
= p
+ len
;
4115 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4118 return hash
& INTMASK
;
4122 /* Return a hash for list LIST. DEPTH is the current depth in the
4123 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4126 sxhash_list (Lisp_Object list
, int depth
)
4131 if (depth
< SXHASH_MAX_DEPTH
)
4133 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4134 list
= XCDR (list
), ++i
)
4136 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4137 hash
= SXHASH_COMBINE (hash
, hash2
);
4142 unsigned hash2
= sxhash (list
, depth
+ 1);
4143 hash
= SXHASH_COMBINE (hash
, hash2
);
4150 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4151 the Lisp structure. */
4154 sxhash_vector (Lisp_Object vec
, int depth
)
4156 unsigned hash
= ASIZE (vec
);
4159 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4160 for (i
= 0; i
< n
; ++i
)
4162 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4163 hash
= SXHASH_COMBINE (hash
, hash2
);
4170 /* Return a hash for bool-vector VECTOR. */
4173 sxhash_bool_vector (Lisp_Object vec
)
4175 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4178 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4179 for (i
= 0; i
< n
; ++i
)
4180 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4186 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4187 structure. Value is an unsigned integer clipped to INTMASK. */
4190 sxhash (Lisp_Object obj
, int depth
)
4194 if (depth
> SXHASH_MAX_DEPTH
)
4197 switch (XTYPE (obj
))
4208 obj
= SYMBOL_NAME (obj
);
4212 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4215 /* This can be everything from a vector to an overlay. */
4216 case Lisp_Vectorlike
:
4218 /* According to the CL HyperSpec, two arrays are equal only if
4219 they are `eq', except for strings and bit-vectors. In
4220 Emacs, this works differently. We have to compare element
4222 hash
= sxhash_vector (obj
, depth
);
4223 else if (BOOL_VECTOR_P (obj
))
4224 hash
= sxhash_bool_vector (obj
);
4226 /* Others are `equal' if they are `eq', so let's take their
4232 hash
= sxhash_list (obj
, depth
);
4237 double val
= XFLOAT_DATA (obj
);
4238 unsigned char *p
= (unsigned char *) &val
;
4239 unsigned char *e
= p
+ sizeof val
;
4240 for (hash
= 0; p
< e
; ++p
)
4241 hash
= SXHASH_COMBINE (hash
, *p
);
4249 return hash
& INTMASK
;
4254 /***********************************************************************
4256 ***********************************************************************/
4259 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4260 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4263 unsigned hash
= sxhash (obj
, 0);
4264 return make_number (hash
);
4268 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4269 doc
: /* Create and return a new hash table.
4271 Arguments are specified as keyword/argument pairs. The following
4272 arguments are defined:
4274 :test TEST -- TEST must be a symbol that specifies how to compare
4275 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4276 `equal'. User-supplied test and hash functions can be specified via
4277 `define-hash-table-test'.
4279 :size SIZE -- A hint as to how many elements will be put in the table.
4282 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4283 fills up. If REHASH-SIZE is an integer, increase the size by that
4284 amount. If it is a float, it must be > 1.0, and the new size is the
4285 old size multiplied by that factor. Default is 1.5.
4287 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4288 Resize the hash table when the ratio (number of entries / table size)
4289 is greater than or equal to THRESHOLD. Default is 0.8.
4291 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4292 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4293 returned is a weak table. Key/value pairs are removed from a weak
4294 hash table when there are no non-weak references pointing to their
4295 key, value, one of key or value, or both key and value, depending on
4296 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4299 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4300 (int nargs
, Lisp_Object
*args
)
4302 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4303 Lisp_Object user_test
, user_hash
;
4307 /* The vector `used' is used to keep track of arguments that
4308 have been consumed. */
4309 used
= (char *) alloca (nargs
* sizeof *used
);
4310 memset (used
, 0, nargs
* sizeof *used
);
4312 /* See if there's a `:test TEST' among the arguments. */
4313 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4314 test
= i
< 0 ? Qeql
: args
[i
];
4315 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4317 /* See if it is a user-defined test. */
4320 prop
= Fget (test
, Qhash_table_test
);
4321 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4322 signal_error ("Invalid hash table test", test
);
4323 user_test
= XCAR (prop
);
4324 user_hash
= XCAR (XCDR (prop
));
4327 user_test
= user_hash
= Qnil
;
4329 /* See if there's a `:size SIZE' argument. */
4330 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4331 size
= i
< 0 ? Qnil
: args
[i
];
4333 size
= make_number (DEFAULT_HASH_SIZE
);
4334 else if (!INTEGERP (size
) || XINT (size
) < 0)
4335 signal_error ("Invalid hash table size", size
);
4337 /* Look for `:rehash-size SIZE'. */
4338 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4339 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4340 if (!NUMBERP (rehash_size
)
4341 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4342 || XFLOATINT (rehash_size
) <= 1.0)
4343 signal_error ("Invalid hash table rehash size", rehash_size
);
4345 /* Look for `:rehash-threshold THRESHOLD'. */
4346 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4347 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4348 if (!FLOATP (rehash_threshold
)
4349 || XFLOATINT (rehash_threshold
) <= 0.0
4350 || XFLOATINT (rehash_threshold
) > 1.0)
4351 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4353 /* Look for `:weakness WEAK'. */
4354 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4355 weak
= i
< 0 ? Qnil
: args
[i
];
4357 weak
= Qkey_and_value
;
4360 && !EQ (weak
, Qvalue
)
4361 && !EQ (weak
, Qkey_or_value
)
4362 && !EQ (weak
, Qkey_and_value
))
4363 signal_error ("Invalid hash table weakness", weak
);
4365 /* Now, all args should have been used up, or there's a problem. */
4366 for (i
= 0; i
< nargs
; ++i
)
4368 signal_error ("Invalid argument list", args
[i
]);
4370 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4371 user_test
, user_hash
);
4375 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4376 doc
: /* Return a copy of hash table TABLE. */)
4379 return copy_hash_table (check_hash_table (table
));
4383 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4384 doc
: /* Return the number of elements in TABLE. */)
4387 return make_number (check_hash_table (table
)->count
);
4391 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4392 Shash_table_rehash_size
, 1, 1, 0,
4393 doc
: /* Return the current rehash size of TABLE. */)
4396 return check_hash_table (table
)->rehash_size
;
4400 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4401 Shash_table_rehash_threshold
, 1, 1, 0,
4402 doc
: /* Return the current rehash threshold of TABLE. */)
4405 return check_hash_table (table
)->rehash_threshold
;
4409 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4410 doc
: /* Return the size of TABLE.
4411 The size can be used as an argument to `make-hash-table' to create
4412 a hash table than can hold as many elements as TABLE holds
4413 without need for resizing. */)
4416 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4417 return make_number (HASH_TABLE_SIZE (h
));
4421 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4422 doc
: /* Return the test TABLE uses. */)
4425 return check_hash_table (table
)->test
;
4429 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4431 doc
: /* Return the weakness of TABLE. */)
4434 return check_hash_table (table
)->weak
;
4438 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4439 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4442 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4446 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4447 doc
: /* Clear hash table TABLE and return it. */)
4450 hash_clear (check_hash_table (table
));
4451 /* Be compatible with XEmacs. */
4456 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4457 doc
: /* Look up KEY in TABLE and return its associated value.
4458 If KEY is not found, return DFLT which defaults to nil. */)
4459 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4461 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4462 int i
= hash_lookup (h
, key
, NULL
);
4463 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4467 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4468 doc
: /* Associate KEY with VALUE in hash table TABLE.
4469 If KEY is already present in table, replace its current value with
4471 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4473 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4477 i
= hash_lookup (h
, key
, &hash
);
4479 HASH_VALUE (h
, i
) = value
;
4481 hash_put (h
, key
, value
, hash
);
4487 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4488 doc
: /* Remove KEY from TABLE. */)
4489 (Lisp_Object key
, Lisp_Object table
)
4491 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4492 hash_remove_from_table (h
, key
);
4497 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4498 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4499 FUNCTION is called with two arguments, KEY and VALUE. */)
4500 (Lisp_Object function
, Lisp_Object table
)
4502 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4503 Lisp_Object args
[3];
4506 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4507 if (!NILP (HASH_HASH (h
, i
)))
4510 args
[1] = HASH_KEY (h
, i
);
4511 args
[2] = HASH_VALUE (h
, i
);
4519 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4520 Sdefine_hash_table_test
, 3, 3, 0,
4521 doc
: /* Define a new hash table test with name NAME, a symbol.
4523 In hash tables created with NAME specified as test, use TEST to
4524 compare keys, and HASH for computing hash codes of keys.
4526 TEST must be a function taking two arguments and returning non-nil if
4527 both arguments are the same. HASH must be a function taking one
4528 argument and return an integer that is the hash code of the argument.
4529 Hash code computation should use the whole value range of integers,
4530 including negative integers. */)
4531 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4533 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4538 /************************************************************************
4540 ************************************************************************/
4544 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4545 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4547 A message digest is a cryptographic checksum of a document, and the
4548 algorithm to calculate it is defined in RFC 1321.
4550 The two optional arguments START and END are character positions
4551 specifying for which part of OBJECT the message digest should be
4552 computed. If nil or omitted, the digest is computed for the whole
4555 The MD5 message digest is computed from the result of encoding the
4556 text in a coding system, not directly from the internal Emacs form of
4557 the text. The optional fourth argument CODING-SYSTEM specifies which
4558 coding system to encode the text with. It should be the same coding
4559 system that you used or will use when actually writing the text into a
4562 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4563 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4564 system would be chosen by default for writing this text into a file.
4566 If OBJECT is a string, the most preferred coding system (see the
4567 command `prefer-coding-system') is used.
4569 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4570 guesswork fails. Normally, an error is signaled in such case. */)
4571 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4573 unsigned char digest
[16];
4574 unsigned char value
[33];
4577 EMACS_INT size_byte
= 0;
4578 EMACS_INT start_char
= 0, end_char
= 0;
4579 EMACS_INT start_byte
= 0, end_byte
= 0;
4580 register EMACS_INT b
, e
;
4581 register struct buffer
*bp
;
4584 if (STRINGP (object
))
4586 if (NILP (coding_system
))
4588 /* Decide the coding-system to encode the data with. */
4590 if (STRING_MULTIBYTE (object
))
4591 /* use default, we can't guess correct value */
4592 coding_system
= preferred_coding_system ();
4594 coding_system
= Qraw_text
;
4597 if (NILP (Fcoding_system_p (coding_system
)))
4599 /* Invalid coding system. */
4601 if (!NILP (noerror
))
4602 coding_system
= Qraw_text
;
4604 xsignal1 (Qcoding_system_error
, coding_system
);
4607 if (STRING_MULTIBYTE (object
))
4608 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4610 size
= SCHARS (object
);
4611 size_byte
= SBYTES (object
);
4615 CHECK_NUMBER (start
);
4617 start_char
= XINT (start
);
4622 start_byte
= string_char_to_byte (object
, start_char
);
4628 end_byte
= size_byte
;
4634 end_char
= XINT (end
);
4639 end_byte
= string_char_to_byte (object
, end_char
);
4642 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4643 args_out_of_range_3 (object
, make_number (start_char
),
4644 make_number (end_char
));
4648 struct buffer
*prev
= current_buffer
;
4650 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4652 CHECK_BUFFER (object
);
4654 bp
= XBUFFER (object
);
4655 if (bp
!= current_buffer
)
4656 set_buffer_internal (bp
);
4662 CHECK_NUMBER_COERCE_MARKER (start
);
4670 CHECK_NUMBER_COERCE_MARKER (end
);
4675 temp
= b
, b
= e
, e
= temp
;
4677 if (!(BEGV
<= b
&& e
<= ZV
))
4678 args_out_of_range (start
, end
);
4680 if (NILP (coding_system
))
4682 /* Decide the coding-system to encode the data with.
4683 See fileio.c:Fwrite-region */
4685 if (!NILP (Vcoding_system_for_write
))
4686 coding_system
= Vcoding_system_for_write
;
4689 int force_raw_text
= 0;
4691 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4692 if (NILP (coding_system
)
4693 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4695 coding_system
= Qnil
;
4696 if (NILP (current_buffer
->enable_multibyte_characters
))
4700 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4702 /* Check file-coding-system-alist. */
4703 Lisp_Object args
[4], val
;
4705 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4706 args
[3] = Fbuffer_file_name(object
);
4707 val
= Ffind_operation_coding_system (4, args
);
4708 if (CONSP (val
) && !NILP (XCDR (val
)))
4709 coding_system
= XCDR (val
);
4712 if (NILP (coding_system
)
4713 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4715 /* If we still have not decided a coding system, use the
4716 default value of buffer-file-coding-system. */
4717 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4721 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4722 /* Confirm that VAL can surely encode the current region. */
4723 coding_system
= call4 (Vselect_safe_coding_system_function
,
4724 make_number (b
), make_number (e
),
4725 coding_system
, Qnil
);
4728 coding_system
= Qraw_text
;
4731 if (NILP (Fcoding_system_p (coding_system
)))
4733 /* Invalid coding system. */
4735 if (!NILP (noerror
))
4736 coding_system
= Qraw_text
;
4738 xsignal1 (Qcoding_system_error
, coding_system
);
4742 object
= make_buffer_string (b
, e
, 0);
4743 if (prev
!= current_buffer
)
4744 set_buffer_internal (prev
);
4745 /* Discard the unwind protect for recovering the current
4749 if (STRING_MULTIBYTE (object
))
4750 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4753 md5_buffer (SDATA (object
) + start_byte
,
4754 SBYTES (object
) - (size_byte
- end_byte
),
4757 for (i
= 0; i
< 16; i
++)
4758 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4761 return make_string (value
, 32);
4768 /* Hash table stuff. */
4769 Qhash_table_p
= intern_c_string ("hash-table-p");
4770 staticpro (&Qhash_table_p
);
4771 Qeq
= intern_c_string ("eq");
4773 Qeql
= intern_c_string ("eql");
4775 Qequal
= intern_c_string ("equal");
4776 staticpro (&Qequal
);
4777 QCtest
= intern_c_string (":test");
4778 staticpro (&QCtest
);
4779 QCsize
= intern_c_string (":size");
4780 staticpro (&QCsize
);
4781 QCrehash_size
= intern_c_string (":rehash-size");
4782 staticpro (&QCrehash_size
);
4783 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4784 staticpro (&QCrehash_threshold
);
4785 QCweakness
= intern_c_string (":weakness");
4786 staticpro (&QCweakness
);
4787 Qkey
= intern_c_string ("key");
4789 Qvalue
= intern_c_string ("value");
4790 staticpro (&Qvalue
);
4791 Qhash_table_test
= intern_c_string ("hash-table-test");
4792 staticpro (&Qhash_table_test
);
4793 Qkey_or_value
= intern_c_string ("key-or-value");
4794 staticpro (&Qkey_or_value
);
4795 Qkey_and_value
= intern_c_string ("key-and-value");
4796 staticpro (&Qkey_and_value
);
4799 defsubr (&Smake_hash_table
);
4800 defsubr (&Scopy_hash_table
);
4801 defsubr (&Shash_table_count
);
4802 defsubr (&Shash_table_rehash_size
);
4803 defsubr (&Shash_table_rehash_threshold
);
4804 defsubr (&Shash_table_size
);
4805 defsubr (&Shash_table_test
);
4806 defsubr (&Shash_table_weakness
);
4807 defsubr (&Shash_table_p
);
4808 defsubr (&Sclrhash
);
4809 defsubr (&Sgethash
);
4810 defsubr (&Sputhash
);
4811 defsubr (&Sremhash
);
4812 defsubr (&Smaphash
);
4813 defsubr (&Sdefine_hash_table_test
);
4815 Qstring_lessp
= intern_c_string ("string-lessp");
4816 staticpro (&Qstring_lessp
);
4817 Qprovide
= intern_c_string ("provide");
4818 staticpro (&Qprovide
);
4819 Qrequire
= intern_c_string ("require");
4820 staticpro (&Qrequire
);
4821 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4822 staticpro (&Qyes_or_no_p_history
);
4823 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4824 staticpro (&Qcursor_in_echo_area
);
4825 Qwidget_type
= intern_c_string ("widget-type");
4826 staticpro (&Qwidget_type
);
4828 staticpro (&string_char_byte_cache_string
);
4829 string_char_byte_cache_string
= Qnil
;
4831 require_nesting_list
= Qnil
;
4832 staticpro (&require_nesting_list
);
4834 Fset (Qyes_or_no_p_history
, Qnil
);
4836 DEFVAR_LISP ("features", &Vfeatures
,
4837 doc
: /* A list of symbols which are the features of the executing Emacs.
4838 Used by `featurep' and `require', and altered by `provide'. */);
4839 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4840 Qsubfeatures
= intern_c_string ("subfeatures");
4841 staticpro (&Qsubfeatures
);
4843 #ifdef HAVE_LANGINFO_CODESET
4844 Qcodeset
= intern_c_string ("codeset");
4845 staticpro (&Qcodeset
);
4846 Qdays
= intern_c_string ("days");
4848 Qmonths
= intern_c_string ("months");
4849 staticpro (&Qmonths
);
4850 Qpaper
= intern_c_string ("paper");
4851 staticpro (&Qpaper
);
4852 #endif /* HAVE_LANGINFO_CODESET */
4854 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4855 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4856 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4857 invoked by mouse clicks and mouse menu items.
4859 On some platforms, file selection dialogs are also enabled if this is
4863 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
4864 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4865 This applies to commands from menus and tool bar buttons even when
4866 they are initiated from the keyboard. If `use-dialog-box' is nil,
4867 that disables the use of a file dialog, regardless of the value of
4869 use_file_dialog
= 1;
4871 defsubr (&Sidentity
);
4874 defsubr (&Ssafe_length
);
4875 defsubr (&Sstring_bytes
);
4876 defsubr (&Sstring_equal
);
4877 defsubr (&Scompare_strings
);
4878 defsubr (&Sstring_lessp
);
4881 defsubr (&Svconcat
);
4882 defsubr (&Scopy_sequence
);
4883 defsubr (&Sstring_make_multibyte
);
4884 defsubr (&Sstring_make_unibyte
);
4885 defsubr (&Sstring_as_multibyte
);
4886 defsubr (&Sstring_as_unibyte
);
4887 defsubr (&Sstring_to_multibyte
);
4888 defsubr (&Sstring_to_unibyte
);
4889 defsubr (&Scopy_alist
);
4890 defsubr (&Ssubstring
);
4891 defsubr (&Ssubstring_no_properties
);
4904 defsubr (&Snreverse
);
4905 defsubr (&Sreverse
);
4907 defsubr (&Splist_get
);
4909 defsubr (&Splist_put
);
4911 defsubr (&Slax_plist_get
);
4912 defsubr (&Slax_plist_put
);
4915 defsubr (&Sequal_including_properties
);
4916 defsubr (&Sfillarray
);
4917 defsubr (&Sclear_string
);
4921 defsubr (&Smapconcat
);
4922 defsubr (&Syes_or_no_p
);
4923 defsubr (&Sload_average
);
4924 defsubr (&Sfeaturep
);
4925 defsubr (&Srequire
);
4926 defsubr (&Sprovide
);
4927 defsubr (&Splist_member
);
4928 defsubr (&Swidget_put
);
4929 defsubr (&Swidget_get
);
4930 defsubr (&Swidget_apply
);
4931 defsubr (&Sbase64_encode_region
);
4932 defsubr (&Sbase64_decode_region
);
4933 defsubr (&Sbase64_encode_string
);
4934 defsubr (&Sbase64_decode_string
);
4936 defsubr (&Slocale_info
);
4945 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
4946 (do not change this comment) */