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/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
68 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
70 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
72 extern long get_random (void);
73 extern void seed_random (long);
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 doc
: /* Return the argument unchanged. */)
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 doc
: /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 29 bits' worth.
90 With positive integer LIMIT, return random number in interval [0,LIMIT).
91 With argument t, set the random number seed from the current time and pid.
92 Other values of LIMIT are ignored. */)
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (limit
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 doc
: /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */)
129 (register Lisp_Object sequence
)
131 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, SCHARS (sequence
));
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, ASIZE (sequence
));
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 CHECK_LIST_END (sequence
, sequence
);
162 val
= make_number (i
);
164 else if (NILP (sequence
))
165 XSETFASTINT (val
, 0);
167 wrong_type_argument (Qsequencep
, sequence
);
172 /* This does not check for quits. That is safe since it must terminate. */
174 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
175 doc
: /* Return the length of a list, but avoid error or infinite loop.
176 This function never gets an error. If LIST is not really a list,
177 it returns 0. If LIST is circular, it returns a finite value
178 which is at least the number of distinct elements. */)
181 Lisp_Object tail
, halftail
, length
;
184 /* halftail is used to detect circular lists. */
186 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
188 if (EQ (tail
, halftail
) && len
!= 0)
192 halftail
= XCDR (halftail
);
195 XSETINT (length
, len
);
199 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
200 doc
: /* Return the number of bytes in STRING.
201 If STRING is multibyte, this may be greater than the length of STRING. */)
204 CHECK_STRING (string
);
205 return make_number (SBYTES (string
));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 doc
: /* Return t if two strings have identical contents.
210 Case is significant, but text properties are ignored.
211 Symbols are also allowed; their print names are used instead. */)
212 (register Lisp_Object s1
, Lisp_Object s2
)
215 s1
= SYMBOL_NAME (s1
);
217 s2
= SYMBOL_NAME (s2
);
221 if (SCHARS (s1
) != SCHARS (s2
)
222 || SBYTES (s1
) != SBYTES (s2
)
223 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
228 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
229 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
230 In string STR1, skip the first START1 characters and stop at END1.
231 In string STR2, skip the first START2 characters and stop at END2.
232 END1 and END2 default to the full lengths of the respective strings.
234 Case is significant in this comparison if IGNORE-CASE is nil.
235 Unibyte strings are converted to multibyte for comparison.
237 The value is t if the strings (or specified portions) match.
238 If string STR1 is less, the value is a negative number N;
239 - 1 - N is the number of characters that match at the beginning.
240 If string STR1 is greater, the value is a positive number N;
241 N - 1 is the number of characters that match at the beginning. */)
242 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
244 register EMACS_INT end1_char
, end2_char
;
245 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
250 start1
= make_number (0);
252 start2
= make_number (0);
253 CHECK_NATNUM (start1
);
254 CHECK_NATNUM (start2
);
263 i1_byte
= string_char_to_byte (str1
, i1
);
264 i2_byte
= string_char_to_byte (str2
, i2
);
266 end1_char
= SCHARS (str1
);
267 if (! NILP (end1
) && end1_char
> XINT (end1
))
268 end1_char
= XINT (end1
);
270 end2_char
= SCHARS (str2
);
271 if (! NILP (end2
) && end2_char
> XINT (end2
))
272 end2_char
= XINT (end2
);
274 while (i1
< end1_char
&& i2
< end2_char
)
276 /* When we find a mismatch, we must compare the
277 characters, not just the bytes. */
280 if (STRING_MULTIBYTE (str1
))
281 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
284 c1
= SREF (str1
, i1
++);
285 MAKE_CHAR_MULTIBYTE (c1
);
288 if (STRING_MULTIBYTE (str2
))
289 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
292 c2
= SREF (str2
, i2
++);
293 MAKE_CHAR_MULTIBYTE (c2
);
299 if (! NILP (ignore_case
))
303 tem
= Fupcase (make_number (c1
));
305 tem
= Fupcase (make_number (c2
));
312 /* Note that I1 has already been incremented
313 past the character that we are comparing;
314 hence we don't add or subtract 1 here. */
316 return make_number (- i1
+ XINT (start1
));
318 return make_number (i1
- XINT (start1
));
322 return make_number (i1
- XINT (start1
) + 1);
324 return make_number (- i1
+ XINT (start1
) - 1);
329 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
330 doc
: /* Return t if first arg string is less than second in lexicographic order.
332 Symbols are also allowed; their print names are used instead. */)
333 (register Lisp_Object s1
, Lisp_Object s2
)
335 register EMACS_INT end
;
336 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
339 s1
= SYMBOL_NAME (s1
);
341 s2
= SYMBOL_NAME (s2
);
345 i1
= i1_byte
= i2
= i2_byte
= 0;
348 if (end
> SCHARS (s2
))
353 /* When we find a mismatch, we must compare the
354 characters, not just the bytes. */
357 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
358 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
361 return c1
< c2
? Qt
: Qnil
;
363 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
366 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
367 enum Lisp_Type target_type
, int last_special
);
371 concat2 (Lisp_Object s1
, Lisp_Object s2
)
376 return concat (2, args
, Lisp_String
, 0);
381 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
387 return concat (3, args
, Lisp_String
, 0);
390 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
391 doc
: /* Concatenate all the arguments and make the result a list.
392 The result is a list whose elements are the elements of all the arguments.
393 Each argument may be a list, vector or string.
394 The last argument is not copied, just used as the tail of the new list.
395 usage: (append &rest SEQUENCES) */)
396 (int nargs
, Lisp_Object
*args
)
398 return concat (nargs
, args
, Lisp_Cons
, 1);
401 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
402 doc
: /* Concatenate all the arguments and make the result a string.
403 The result is a string whose elements are the elements of all the arguments.
404 Each argument may be a string or a list or vector of characters (integers).
405 usage: (concat &rest SEQUENCES) */)
406 (int nargs
, Lisp_Object
*args
)
408 return concat (nargs
, args
, Lisp_String
, 0);
411 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
412 doc
: /* Concatenate all the arguments and make the result a vector.
413 The result is a vector whose elements are the elements of all the arguments.
414 Each argument may be a list, vector or string.
415 usage: (vconcat &rest SEQUENCES) */)
416 (int nargs
, Lisp_Object
*args
)
418 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
422 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
423 doc
: /* Return a copy of a list, vector, string or char-table.
424 The elements of a list or vector are not copied; they are shared
425 with the original. */)
428 if (NILP (arg
)) return arg
;
430 if (CHAR_TABLE_P (arg
))
432 return copy_char_table (arg
);
435 if (BOOL_VECTOR_P (arg
))
439 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
440 / BOOL_VECTOR_BITS_PER_CHAR
);
442 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
443 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
448 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
449 wrong_type_argument (Qsequencep
, arg
);
451 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
454 /* This structure holds information of an argument of `concat' that is
455 a string and has text properties to be copied. */
458 int argnum
; /* refer to ARGS (arguments of `concat') */
459 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
460 EMACS_INT to
; /* refer to VAL (the target string) */
464 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
467 register Lisp_Object tail
;
468 register Lisp_Object
this;
470 EMACS_INT toindex_byte
= 0;
471 register EMACS_INT result_len
;
472 register EMACS_INT result_len_byte
;
474 Lisp_Object last_tail
;
477 /* When we make a multibyte string, we can't copy text properties
478 while concatinating each string because the length of resulting
479 string can't be decided until we finish the whole concatination.
480 So, we record strings that have text properties to be copied
481 here, and copy the text properties after the concatination. */
482 struct textprop_rec
*textprops
= NULL
;
483 /* Number of elements in textprops. */
484 int num_textprops
= 0;
489 /* In append, the last arg isn't treated like the others */
490 if (last_special
&& nargs
> 0)
493 last_tail
= args
[nargs
];
498 /* Check each argument. */
499 for (argnum
= 0; argnum
< nargs
; argnum
++)
502 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
503 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
504 wrong_type_argument (Qsequencep
, this);
507 /* Compute total length in chars of arguments in RESULT_LEN.
508 If desired output is a string, also compute length in bytes
509 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
510 whether the result should be a multibyte string. */
514 for (argnum
= 0; argnum
< nargs
; argnum
++)
518 len
= XFASTINT (Flength (this));
519 if (target_type
== Lisp_String
)
521 /* We must count the number of bytes needed in the string
522 as well as the number of characters. */
525 EMACS_INT this_len_byte
;
528 for (i
= 0; i
< len
; i
++)
531 CHECK_CHARACTER (ch
);
532 this_len_byte
= CHAR_BYTES (XINT (ch
));
533 result_len_byte
+= this_len_byte
;
534 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
537 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
538 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
539 else if (CONSP (this))
540 for (; CONSP (this); this = XCDR (this))
543 CHECK_CHARACTER (ch
);
544 this_len_byte
= CHAR_BYTES (XINT (ch
));
545 result_len_byte
+= this_len_byte
;
546 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
549 else if (STRINGP (this))
551 if (STRING_MULTIBYTE (this))
554 result_len_byte
+= SBYTES (this);
557 result_len_byte
+= count_size_as_multibyte (SDATA (this),
564 error ("String overflow");
567 if (! some_multibyte
)
568 result_len_byte
= result_len
;
570 /* Create the output object. */
571 if (target_type
== Lisp_Cons
)
572 val
= Fmake_list (make_number (result_len
), Qnil
);
573 else if (target_type
== Lisp_Vectorlike
)
574 val
= Fmake_vector (make_number (result_len
), Qnil
);
575 else if (some_multibyte
)
576 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
578 val
= make_uninit_string (result_len
);
580 /* In `append', if all but last arg are nil, return last arg. */
581 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
584 /* Copy the contents of the args into the result. */
586 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
588 toindex
= 0, toindex_byte
= 0;
592 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
594 for (argnum
= 0; argnum
< nargs
; argnum
++)
597 EMACS_INT thisleni
= 0;
598 register EMACS_INT thisindex
= 0;
599 register EMACS_INT thisindex_byte
= 0;
603 thislen
= Flength (this), thisleni
= XINT (thislen
);
605 /* Between strings of the same kind, copy fast. */
606 if (STRINGP (this) && STRINGP (val
)
607 && STRING_MULTIBYTE (this) == some_multibyte
)
609 EMACS_INT thislen_byte
= SBYTES (this);
611 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
612 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
614 textprops
[num_textprops
].argnum
= argnum
;
615 textprops
[num_textprops
].from
= 0;
616 textprops
[num_textprops
++].to
= toindex
;
618 toindex_byte
+= thislen_byte
;
621 /* Copy a single-byte string to a multibyte string. */
622 else if (STRINGP (this) && STRINGP (val
))
624 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
626 textprops
[num_textprops
].argnum
= argnum
;
627 textprops
[num_textprops
].from
= 0;
628 textprops
[num_textprops
++].to
= toindex
;
630 toindex_byte
+= copy_text (SDATA (this),
631 SDATA (val
) + toindex_byte
,
632 SCHARS (this), 0, 1);
636 /* Copy element by element. */
639 register Lisp_Object elt
;
641 /* Fetch next element of `this' arg into `elt', or break if
642 `this' is exhausted. */
643 if (NILP (this)) break;
645 elt
= XCAR (this), this = XCDR (this);
646 else if (thisindex
>= thisleni
)
648 else if (STRINGP (this))
651 if (STRING_MULTIBYTE (this))
653 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
656 XSETFASTINT (elt
, c
);
660 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
662 && !ASCII_CHAR_P (XINT (elt
))
663 && XINT (elt
) < 0400)
665 c
= BYTE8_TO_CHAR (XINT (elt
));
670 else if (BOOL_VECTOR_P (this))
673 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
674 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
682 elt
= AREF (this, thisindex
);
686 /* Store this element into the result. */
693 else if (VECTORP (val
))
695 ASET (val
, toindex
, elt
);
702 toindex_byte
+= CHAR_STRING (XINT (elt
),
703 SDATA (val
) + toindex_byte
);
705 SSET (val
, toindex_byte
++, XINT (elt
));
711 XSETCDR (prev
, last_tail
);
713 if (num_textprops
> 0)
716 EMACS_INT last_to_end
= -1;
718 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
720 this = args
[textprops
[argnum
].argnum
];
721 props
= text_property_list (this,
723 make_number (SCHARS (this)),
725 /* If successive arguments have properites, be sure that the
726 value of `composition' property be the copy. */
727 if (last_to_end
== textprops
[argnum
].to
)
728 make_composition_value_copy (props
);
729 add_text_properties_from_list (val
, props
,
730 make_number (textprops
[argnum
].to
));
731 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
739 static Lisp_Object string_char_byte_cache_string
;
740 static EMACS_INT string_char_byte_cache_charpos
;
741 static EMACS_INT string_char_byte_cache_bytepos
;
744 clear_string_char_byte_cache (void)
746 string_char_byte_cache_string
= Qnil
;
749 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
752 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
755 EMACS_INT best_below
, best_below_byte
;
756 EMACS_INT best_above
, best_above_byte
;
758 best_below
= best_below_byte
= 0;
759 best_above
= SCHARS (string
);
760 best_above_byte
= SBYTES (string
);
761 if (best_above
== best_above_byte
)
764 if (EQ (string
, string_char_byte_cache_string
))
766 if (string_char_byte_cache_charpos
< char_index
)
768 best_below
= string_char_byte_cache_charpos
;
769 best_below_byte
= string_char_byte_cache_bytepos
;
773 best_above
= string_char_byte_cache_charpos
;
774 best_above_byte
= string_char_byte_cache_bytepos
;
778 if (char_index
- best_below
< best_above
- char_index
)
780 unsigned char *p
= SDATA (string
) + best_below_byte
;
782 while (best_below
< char_index
)
784 p
+= BYTES_BY_CHAR_HEAD (*p
);
787 i_byte
= p
- SDATA (string
);
791 unsigned char *p
= SDATA (string
) + best_above_byte
;
793 while (best_above
> char_index
)
796 while (!CHAR_HEAD_P (*p
)) p
--;
799 i_byte
= p
- SDATA (string
);
802 string_char_byte_cache_bytepos
= i_byte
;
803 string_char_byte_cache_charpos
= char_index
;
804 string_char_byte_cache_string
= string
;
809 /* Return the character index corresponding to BYTE_INDEX in STRING. */
812 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
815 EMACS_INT best_below
, best_below_byte
;
816 EMACS_INT best_above
, best_above_byte
;
818 best_below
= best_below_byte
= 0;
819 best_above
= SCHARS (string
);
820 best_above_byte
= SBYTES (string
);
821 if (best_above
== best_above_byte
)
824 if (EQ (string
, string_char_byte_cache_string
))
826 if (string_char_byte_cache_bytepos
< byte_index
)
828 best_below
= string_char_byte_cache_charpos
;
829 best_below_byte
= string_char_byte_cache_bytepos
;
833 best_above
= string_char_byte_cache_charpos
;
834 best_above_byte
= string_char_byte_cache_bytepos
;
838 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
840 unsigned char *p
= SDATA (string
) + best_below_byte
;
841 unsigned char *pend
= SDATA (string
) + byte_index
;
845 p
+= BYTES_BY_CHAR_HEAD (*p
);
849 i_byte
= p
- SDATA (string
);
853 unsigned char *p
= SDATA (string
) + best_above_byte
;
854 unsigned char *pbeg
= SDATA (string
) + byte_index
;
859 while (!CHAR_HEAD_P (*p
)) p
--;
863 i_byte
= p
- SDATA (string
);
866 string_char_byte_cache_bytepos
= i_byte
;
867 string_char_byte_cache_charpos
= i
;
868 string_char_byte_cache_string
= string
;
873 /* Convert STRING to a multibyte string. */
876 string_make_multibyte (Lisp_Object string
)
883 if (STRING_MULTIBYTE (string
))
886 nbytes
= count_size_as_multibyte (SDATA (string
),
888 /* If all the chars are ASCII, they won't need any more bytes
889 once converted. In that case, we can return STRING itself. */
890 if (nbytes
== SBYTES (string
))
893 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
894 copy_text (SDATA (string
), buf
, SBYTES (string
),
897 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
904 /* Convert STRING (if unibyte) to a multibyte string without changing
905 the number of characters. Characters 0200 trough 0237 are
906 converted to eight-bit characters. */
909 string_to_multibyte (Lisp_Object string
)
916 if (STRING_MULTIBYTE (string
))
919 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
920 /* If all the chars are ASCII, they won't need any more bytes once
922 if (nbytes
== SBYTES (string
))
923 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
925 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
926 memcpy (buf
, SDATA (string
), SBYTES (string
));
927 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
929 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
936 /* Convert STRING to a single-byte string. */
939 string_make_unibyte (Lisp_Object string
)
946 if (! STRING_MULTIBYTE (string
))
949 nchars
= SCHARS (string
);
951 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
952 copy_text (SDATA (string
), buf
, SBYTES (string
),
955 ret
= make_unibyte_string (buf
, nchars
);
961 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
963 doc
: /* Return the multibyte equivalent of STRING.
964 If STRING is unibyte and contains non-ASCII characters, the function
965 `unibyte-char-to-multibyte' is used to convert each unibyte character
966 to a multibyte character. In this case, the returned string is a
967 newly created string with no text properties. If STRING is multibyte
968 or entirely ASCII, it is returned unchanged. In particular, when
969 STRING is unibyte and entirely ASCII, the returned string is unibyte.
970 \(When the characters are all ASCII, Emacs primitives will treat the
971 string the same way whether it is unibyte or multibyte.) */)
974 CHECK_STRING (string
);
976 return string_make_multibyte (string
);
979 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
981 doc
: /* Return the unibyte equivalent of STRING.
982 Multibyte character codes are converted to unibyte according to
983 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
984 If the lookup in the translation table fails, this function takes just
985 the low 8 bits of each character. */)
988 CHECK_STRING (string
);
990 return string_make_unibyte (string
);
993 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
995 doc
: /* Return a unibyte string with the same individual bytes as STRING.
996 If STRING is unibyte, the result is STRING itself.
997 Otherwise it is a newly created string, with no text properties.
998 If STRING is multibyte and contains a character of charset
999 `eight-bit', it is converted to the corresponding single byte. */)
1000 (Lisp_Object string
)
1002 CHECK_STRING (string
);
1004 if (STRING_MULTIBYTE (string
))
1006 EMACS_INT bytes
= SBYTES (string
);
1007 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1009 memcpy (str
, SDATA (string
), bytes
);
1010 bytes
= str_as_unibyte (str
, bytes
);
1011 string
= make_unibyte_string (str
, bytes
);
1017 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1019 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1020 If STRING is multibyte, the result is STRING itself.
1021 Otherwise it is a newly created string, with no text properties.
1023 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1024 part of a correct utf-8 sequence), it is converted to the corresponding
1025 multibyte character of charset `eight-bit'.
1026 See also `string-to-multibyte'.
1028 Beware, this often doesn't really do what you think it does.
1029 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1030 If you're not sure, whether to use `string-as-multibyte' or
1031 `string-to-multibyte', use `string-to-multibyte'. */)
1032 (Lisp_Object string
)
1034 CHECK_STRING (string
);
1036 if (! STRING_MULTIBYTE (string
))
1038 Lisp_Object new_string
;
1039 EMACS_INT nchars
, nbytes
;
1041 parse_str_as_multibyte (SDATA (string
),
1044 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1045 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1046 if (nbytes
!= SBYTES (string
))
1047 str_as_multibyte (SDATA (new_string
), nbytes
,
1048 SBYTES (string
), NULL
);
1049 string
= new_string
;
1050 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1055 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1057 doc
: /* Return a multibyte string with the same individual chars as STRING.
1058 If STRING is multibyte, the result is STRING itself.
1059 Otherwise it is a newly created string, with no text properties.
1061 If STRING is unibyte and contains an 8-bit byte, it is converted to
1062 the corresponding multibyte character of charset `eight-bit'.
1064 This differs from `string-as-multibyte' by converting each byte of a correct
1065 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1066 correct sequence. */)
1067 (Lisp_Object string
)
1069 CHECK_STRING (string
);
1071 return string_to_multibyte (string
);
1074 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1076 doc
: /* Return a unibyte string with the same individual chars as STRING.
1077 If STRING is unibyte, the result is STRING itself.
1078 Otherwise it is a newly created string, with no text properties,
1079 where each `eight-bit' character is converted to the corresponding byte.
1080 If STRING contains a non-ASCII, non-`eight-bit' character,
1081 an error is signaled. */)
1082 (Lisp_Object string
)
1084 CHECK_STRING (string
);
1086 if (STRING_MULTIBYTE (string
))
1088 EMACS_INT chars
= SCHARS (string
);
1089 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1090 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1092 if (converted
< chars
)
1093 error ("Can't convert the %dth character to unibyte", converted
);
1094 string
= make_unibyte_string (str
, chars
);
1101 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1102 doc
: /* Return a copy of ALIST.
1103 This is an alist which represents the same mapping from objects to objects,
1104 but does not share the alist structure with ALIST.
1105 The objects mapped (cars and cdrs of elements of the alist)
1106 are shared, however.
1107 Elements of ALIST that are not conses are also shared. */)
1110 register Lisp_Object tem
;
1115 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1116 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1118 register Lisp_Object car
;
1122 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1127 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1128 doc
: /* Return a new string whose contents are a substring of STRING.
1129 The returned string consists of the characters between index FROM
1130 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1131 zero-indexed: 0 means the first character of STRING. Negative values
1132 are counted from the end of STRING. If TO is nil, the substring runs
1133 to the end of STRING.
1135 The STRING argument may also be a vector. In that case, the return
1136 value is a new vector that contains the elements between index FROM
1137 \(inclusive) and index TO (exclusive) of that vector argument. */)
1138 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1142 EMACS_INT size_byte
= 0;
1143 EMACS_INT from_char
, to_char
;
1144 EMACS_INT from_byte
= 0, to_byte
= 0;
1146 CHECK_VECTOR_OR_STRING (string
);
1147 CHECK_NUMBER (from
);
1149 if (STRINGP (string
))
1151 size
= SCHARS (string
);
1152 size_byte
= SBYTES (string
);
1155 size
= ASIZE (string
);
1160 to_byte
= size_byte
;
1166 to_char
= XINT (to
);
1170 if (STRINGP (string
))
1171 to_byte
= string_char_to_byte (string
, to_char
);
1174 from_char
= XINT (from
);
1177 if (STRINGP (string
))
1178 from_byte
= string_char_to_byte (string
, from_char
);
1180 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1181 args_out_of_range_3 (string
, make_number (from_char
),
1182 make_number (to_char
));
1184 if (STRINGP (string
))
1186 res
= make_specified_string (SDATA (string
) + from_byte
,
1187 to_char
- from_char
, to_byte
- from_byte
,
1188 STRING_MULTIBYTE (string
));
1189 copy_text_properties (make_number (from_char
), make_number (to_char
),
1190 string
, make_number (0), res
, Qnil
);
1193 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1199 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1200 doc
: /* Return a substring of STRING, without text properties.
1201 It starts at index FROM and ends before TO.
1202 TO may be nil or omitted; then the substring runs to the end of STRING.
1203 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1204 If FROM or TO is negative, it counts from the end.
1206 With one argument, just copy STRING without its properties. */)
1207 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1209 EMACS_INT size
, size_byte
;
1210 EMACS_INT from_char
, to_char
;
1211 EMACS_INT from_byte
, to_byte
;
1213 CHECK_STRING (string
);
1215 size
= SCHARS (string
);
1216 size_byte
= SBYTES (string
);
1219 from_char
= from_byte
= 0;
1222 CHECK_NUMBER (from
);
1223 from_char
= XINT (from
);
1227 from_byte
= string_char_to_byte (string
, from_char
);
1233 to_byte
= size_byte
;
1239 to_char
= XINT (to
);
1243 to_byte
= string_char_to_byte (string
, to_char
);
1246 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1247 args_out_of_range_3 (string
, make_number (from_char
),
1248 make_number (to_char
));
1250 return make_specified_string (SDATA (string
) + from_byte
,
1251 to_char
- from_char
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1255 /* Extract a substring of STRING, giving start and end positions
1256 both in characters and in bytes. */
1259 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1260 EMACS_INT to
, EMACS_INT to_byte
)
1264 EMACS_INT size_byte
;
1266 CHECK_VECTOR_OR_STRING (string
);
1268 if (STRINGP (string
))
1270 size
= SCHARS (string
);
1271 size_byte
= SBYTES (string
);
1274 size
= ASIZE (string
);
1276 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1277 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1279 if (STRINGP (string
))
1281 res
= make_specified_string (SDATA (string
) + from_byte
,
1282 to
- from
, to_byte
- from_byte
,
1283 STRING_MULTIBYTE (string
));
1284 copy_text_properties (make_number (from
), make_number (to
),
1285 string
, make_number (0), res
, Qnil
);
1288 res
= Fvector (to
- from
, &AREF (string
, from
));
1293 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1294 doc
: /* Take cdr N times on LIST, return the result. */)
1295 (Lisp_Object n
, Lisp_Object list
)
1297 register int i
, num
;
1300 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1303 CHECK_LIST_CONS (list
, list
);
1309 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1310 doc
: /* Return the Nth element of LIST.
1311 N counts from zero. If LIST is not that long, nil is returned. */)
1312 (Lisp_Object n
, Lisp_Object list
)
1314 return Fcar (Fnthcdr (n
, list
));
1317 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1318 doc
: /* Return element of SEQUENCE at index N. */)
1319 (register Lisp_Object sequence
, Lisp_Object n
)
1322 if (CONSP (sequence
) || NILP (sequence
))
1323 return Fcar (Fnthcdr (n
, sequence
));
1325 /* Faref signals a "not array" error, so check here. */
1326 CHECK_ARRAY (sequence
, Qsequencep
);
1327 return Faref (sequence
, n
);
1330 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1331 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1332 The value is actually the tail of LIST whose car is ELT. */)
1333 (register Lisp_Object elt
, Lisp_Object list
)
1335 register Lisp_Object tail
;
1336 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1338 register Lisp_Object tem
;
1339 CHECK_LIST_CONS (tail
, list
);
1341 if (! NILP (Fequal (elt
, tem
)))
1348 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1349 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1350 The value is actually the tail of LIST whose car is ELT. */)
1351 (register Lisp_Object elt
, Lisp_Object list
)
1355 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1359 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1363 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1374 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1375 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1376 The value is actually the tail of LIST whose car is ELT. */)
1377 (register Lisp_Object elt
, Lisp_Object list
)
1379 register Lisp_Object tail
;
1382 return Fmemq (elt
, list
);
1384 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1386 register Lisp_Object tem
;
1387 CHECK_LIST_CONS (tail
, list
);
1389 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1396 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1397 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1398 The value is actually the first element of LIST whose car is KEY.
1399 Elements of LIST that are not conses are ignored. */)
1400 (Lisp_Object key
, Lisp_Object list
)
1405 || (CONSP (XCAR (list
))
1406 && EQ (XCAR (XCAR (list
)), key
)))
1411 || (CONSP (XCAR (list
))
1412 && EQ (XCAR (XCAR (list
)), key
)))
1417 || (CONSP (XCAR (list
))
1418 && EQ (XCAR (XCAR (list
)), key
)))
1428 /* Like Fassq but never report an error and do not allow quits.
1429 Use only on lists known never to be circular. */
1432 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1435 && (!CONSP (XCAR (list
))
1436 || !EQ (XCAR (XCAR (list
)), key
)))
1439 return CAR_SAFE (list
);
1442 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1443 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1444 The value is actually the first element of LIST whose car equals KEY. */)
1445 (Lisp_Object key
, Lisp_Object list
)
1452 || (CONSP (XCAR (list
))
1453 && (car
= XCAR (XCAR (list
)),
1454 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1459 || (CONSP (XCAR (list
))
1460 && (car
= XCAR (XCAR (list
)),
1461 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1466 || (CONSP (XCAR (list
))
1467 && (car
= XCAR (XCAR (list
)),
1468 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1478 /* Like Fassoc but never report an error and do not allow quits.
1479 Use only on lists known never to be circular. */
1482 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1485 && (!CONSP (XCAR (list
))
1486 || (!EQ (XCAR (XCAR (list
)), key
)
1487 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1490 return CONSP (list
) ? XCAR (list
) : Qnil
;
1493 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1495 The value is actually the first element of LIST whose cdr is KEY. */)
1496 (register Lisp_Object key
, Lisp_Object list
)
1501 || (CONSP (XCAR (list
))
1502 && EQ (XCDR (XCAR (list
)), key
)))
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCDR (XCAR (list
)), key
)))
1513 || (CONSP (XCAR (list
))
1514 && EQ (XCDR (XCAR (list
)), key
)))
1524 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1525 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1526 The value is actually the first element of LIST whose cdr equals KEY. */)
1527 (Lisp_Object key
, Lisp_Object list
)
1534 || (CONSP (XCAR (list
))
1535 && (cdr
= XCDR (XCAR (list
)),
1536 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (cdr
= XCDR (XCAR (list
)),
1543 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1548 || (CONSP (XCAR (list
))
1549 && (cdr
= XCDR (XCAR (list
)),
1550 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1560 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1561 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1562 The modified LIST is returned. Comparison is done with `eq'.
1563 If the first member of LIST is ELT, there is no way to remove it by side effect;
1564 therefore, write `(setq foo (delq element foo))'
1565 to be sure of changing the value of `foo'. */)
1566 (register Lisp_Object elt
, Lisp_Object list
)
1568 register Lisp_Object tail
, prev
;
1569 register Lisp_Object tem
;
1573 while (!NILP (tail
))
1575 CHECK_LIST_CONS (tail
, list
);
1582 Fsetcdr (prev
, XCDR (tail
));
1592 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1593 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1594 SEQ must be a list, a vector, or a string.
1595 The modified SEQ is returned. Comparison is done with `equal'.
1596 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1597 is not a side effect; it is simply using a different sequence.
1598 Therefore, write `(setq foo (delete element foo))'
1599 to be sure of changing the value of `foo'. */)
1600 (Lisp_Object elt
, Lisp_Object seq
)
1606 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1607 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1610 if (n
!= ASIZE (seq
))
1612 struct Lisp_Vector
*p
= allocate_vector (n
);
1614 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1615 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1616 p
->contents
[n
++] = AREF (seq
, i
);
1618 XSETVECTOR (seq
, p
);
1621 else if (STRINGP (seq
))
1623 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1626 for (i
= nchars
= nbytes
= ibyte
= 0;
1628 ++i
, ibyte
+= cbytes
)
1630 if (STRING_MULTIBYTE (seq
))
1632 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1633 cbytes
= CHAR_BYTES (c
);
1641 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1648 if (nchars
!= SCHARS (seq
))
1652 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1653 if (!STRING_MULTIBYTE (seq
))
1654 STRING_SET_UNIBYTE (tem
);
1656 for (i
= nchars
= nbytes
= ibyte
= 0;
1658 ++i
, ibyte
+= cbytes
)
1660 if (STRING_MULTIBYTE (seq
))
1662 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1663 cbytes
= CHAR_BYTES (c
);
1671 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1673 unsigned char *from
= SDATA (seq
) + ibyte
;
1674 unsigned char *to
= SDATA (tem
) + nbytes
;
1680 for (n
= cbytes
; n
--; )
1690 Lisp_Object tail
, prev
;
1692 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1694 CHECK_LIST_CONS (tail
, seq
);
1696 if (!NILP (Fequal (elt
, XCAR (tail
))))
1701 Fsetcdr (prev
, XCDR (tail
));
1712 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1713 doc
: /* Reverse LIST by modifying cdr pointers.
1714 Return the reversed list. */)
1717 register Lisp_Object prev
, tail
, next
;
1719 if (NILP (list
)) return list
;
1722 while (!NILP (tail
))
1725 CHECK_LIST_CONS (tail
, list
);
1727 Fsetcdr (tail
, prev
);
1734 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1735 doc
: /* Reverse LIST, copying. Return the reversed list.
1736 See also the function `nreverse', which is used more often. */)
1741 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1744 new = Fcons (XCAR (list
), new);
1746 CHECK_LIST_END (list
, list
);
1750 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1752 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1753 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1754 Returns the sorted list. LIST is modified by side effects.
1755 PREDICATE is called with two elements of LIST, and should return non-nil
1756 if the first element should sort before the second. */)
1757 (Lisp_Object list
, Lisp_Object predicate
)
1759 Lisp_Object front
, back
;
1760 register Lisp_Object len
, tem
;
1761 struct gcpro gcpro1
, gcpro2
;
1762 register int length
;
1765 len
= Flength (list
);
1766 length
= XINT (len
);
1770 XSETINT (len
, (length
/ 2) - 1);
1771 tem
= Fnthcdr (len
, list
);
1773 Fsetcdr (tem
, Qnil
);
1775 GCPRO2 (front
, back
);
1776 front
= Fsort (front
, predicate
);
1777 back
= Fsort (back
, predicate
);
1779 return merge (front
, back
, predicate
);
1783 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1786 register Lisp_Object tail
;
1788 register Lisp_Object l1
, l2
;
1789 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1796 /* It is sufficient to protect org_l1 and org_l2.
1797 When l1 and l2 are updated, we copy the new values
1798 back into the org_ vars. */
1799 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1819 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1835 Fsetcdr (tail
, tem
);
1841 /* This does not check for quits. That is safe since it must terminate. */
1843 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1844 doc
: /* Extract a value from a property list.
1845 PLIST is a property list, which is a list of the form
1846 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1847 corresponding to the given PROP, or nil if PROP is not one of the
1848 properties on the list. This function never signals an error. */)
1849 (Lisp_Object plist
, Lisp_Object prop
)
1851 Lisp_Object tail
, halftail
;
1853 /* halftail is used to detect circular lists. */
1854 tail
= halftail
= plist
;
1855 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1857 if (EQ (prop
, XCAR (tail
)))
1858 return XCAR (XCDR (tail
));
1860 tail
= XCDR (XCDR (tail
));
1861 halftail
= XCDR (halftail
);
1862 if (EQ (tail
, halftail
))
1865 #if 0 /* Unsafe version. */
1866 /* This function can be called asynchronously
1867 (setup_coding_system). Don't QUIT in that case. */
1868 if (!interrupt_input_blocked
)
1876 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1877 doc
: /* Return the value of SYMBOL's PROPNAME property.
1878 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1879 (Lisp_Object symbol
, Lisp_Object propname
)
1881 CHECK_SYMBOL (symbol
);
1882 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1885 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1886 doc
: /* Change value in PLIST of PROP to VAL.
1887 PLIST is a property list, which is a list of the form
1888 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1889 If PROP is already a property on the list, its value is set to VAL,
1890 otherwise the new PROP VAL pair is added. The new plist is returned;
1891 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1892 The PLIST is modified by side effects. */)
1893 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1895 register Lisp_Object tail
, prev
;
1896 Lisp_Object newcell
;
1898 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1899 tail
= XCDR (XCDR (tail
)))
1901 if (EQ (prop
, XCAR (tail
)))
1903 Fsetcar (XCDR (tail
), val
);
1910 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1914 Fsetcdr (XCDR (prev
), newcell
);
1918 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1919 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1920 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1921 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1923 CHECK_SYMBOL (symbol
);
1924 XSYMBOL (symbol
)->plist
1925 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1929 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1930 doc
: /* Extract a value from a property list, comparing with `equal'.
1931 PLIST is a property list, which is a list of the form
1932 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1933 corresponding to the given PROP, or nil if PROP is not
1934 one of the properties on the list. */)
1935 (Lisp_Object plist
, Lisp_Object prop
)
1940 CONSP (tail
) && CONSP (XCDR (tail
));
1941 tail
= XCDR (XCDR (tail
)))
1943 if (! NILP (Fequal (prop
, XCAR (tail
))))
1944 return XCAR (XCDR (tail
));
1949 CHECK_LIST_END (tail
, prop
);
1954 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1955 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1956 PLIST is a property list, which is a list of the form
1957 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1958 If PROP is already a property on the list, its value is set to VAL,
1959 otherwise the new PROP VAL pair is added. The new plist is returned;
1960 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1961 The PLIST is modified by side effects. */)
1962 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1964 register Lisp_Object tail
, prev
;
1965 Lisp_Object newcell
;
1967 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1968 tail
= XCDR (XCDR (tail
)))
1970 if (! NILP (Fequal (prop
, XCAR (tail
))))
1972 Fsetcar (XCDR (tail
), val
);
1979 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1983 Fsetcdr (XCDR (prev
), newcell
);
1987 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1988 doc
: /* Return t if the two args are the same Lisp object.
1989 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1990 (Lisp_Object obj1
, Lisp_Object obj2
)
1993 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1995 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1998 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1999 doc
: /* Return t if two Lisp objects have similar structure and contents.
2000 They must have the same data type.
2001 Conses are compared by comparing the cars and the cdrs.
2002 Vectors and strings are compared element by element.
2003 Numbers are compared by value, but integers cannot equal floats.
2004 (Use `=' if you want integers and floats to be able to be equal.)
2005 Symbols must match exactly. */)
2006 (register Lisp_Object o1
, Lisp_Object o2
)
2008 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2011 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2012 doc
: /* Return t if two Lisp objects have similar structure and contents.
2013 This is like `equal' except that it compares the text properties
2014 of strings. (`equal' ignores text properties.) */)
2015 (register Lisp_Object o1
, Lisp_Object o2
)
2017 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2020 /* DEPTH is current depth of recursion. Signal an error if it
2022 PROPS, if non-nil, means compare string text properties too. */
2025 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2028 error ("Stack overflow in equal");
2034 if (XTYPE (o1
) != XTYPE (o2
))
2043 d1
= extract_float (o1
);
2044 d2
= extract_float (o2
);
2045 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2046 though they are not =. */
2047 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2051 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2058 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2062 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2064 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2067 o1
= XOVERLAY (o1
)->plist
;
2068 o2
= XOVERLAY (o2
)->plist
;
2073 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2074 && (XMARKER (o1
)->buffer
== 0
2075 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2079 case Lisp_Vectorlike
:
2082 EMACS_INT size
= ASIZE (o1
);
2083 /* Pseudovectors have the type encoded in the size field, so this test
2084 actually checks that the objects have the same type as well as the
2086 if (ASIZE (o2
) != size
)
2088 /* Boolvectors are compared much like strings. */
2089 if (BOOL_VECTOR_P (o1
))
2092 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2093 / BOOL_VECTOR_BITS_PER_CHAR
);
2095 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2097 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2102 if (WINDOW_CONFIGURATIONP (o1
))
2103 return compare_window_configurations (o1
, o2
, 0);
2105 /* Aside from them, only true vectors, char-tables, compiled
2106 functions, and fonts (font-spec, font-entity, font-ojbect)
2107 are sensible to compare, so eliminate the others now. */
2108 if (size
& PSEUDOVECTOR_FLAG
)
2110 if (!(size
& (PVEC_COMPILED
2111 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2113 size
&= PSEUDOVECTOR_SIZE_MASK
;
2115 for (i
= 0; i
< size
; i
++)
2120 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2128 if (SCHARS (o1
) != SCHARS (o2
))
2130 if (SBYTES (o1
) != SBYTES (o2
))
2132 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2134 if (props
&& !compare_string_intervals (o1
, o2
))
2146 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2147 doc
: /* Store each element of ARRAY with ITEM.
2148 ARRAY is a vector, string, char-table, or bool-vector. */)
2149 (Lisp_Object array
, Lisp_Object item
)
2151 register EMACS_INT size
, index
;
2154 if (VECTORP (array
))
2156 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2157 size
= ASIZE (array
);
2158 for (index
= 0; index
< size
; index
++)
2161 else if (CHAR_TABLE_P (array
))
2165 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2166 XCHAR_TABLE (array
)->contents
[i
] = item
;
2167 XCHAR_TABLE (array
)->defalt
= item
;
2169 else if (STRINGP (array
))
2171 register unsigned char *p
= SDATA (array
);
2172 CHECK_NUMBER (item
);
2173 charval
= XINT (item
);
2174 size
= SCHARS (array
);
2175 if (STRING_MULTIBYTE (array
))
2177 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2178 int len
= CHAR_STRING (charval
, str
);
2179 EMACS_INT size_byte
= SBYTES (array
);
2180 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2183 if (size
!= size_byte
)
2186 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2187 if (len
!= this_len
)
2188 error ("Attempt to change byte length of a string");
2191 for (i
= 0; i
< size_byte
; i
++)
2192 *p
++ = str
[i
% len
];
2195 for (index
= 0; index
< size
; index
++)
2198 else if (BOOL_VECTOR_P (array
))
2200 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2202 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2203 / BOOL_VECTOR_BITS_PER_CHAR
);
2205 charval
= (! NILP (item
) ? -1 : 0);
2206 for (index
= 0; index
< size_in_chars
- 1; index
++)
2208 if (index
< size_in_chars
)
2210 /* Mask out bits beyond the vector size. */
2211 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2212 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2217 wrong_type_argument (Qarrayp
, array
);
2221 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2223 doc
: /* Clear the contents of STRING.
2224 This makes STRING unibyte and may change its length. */)
2225 (Lisp_Object string
)
2228 CHECK_STRING (string
);
2229 len
= SBYTES (string
);
2230 memset (SDATA (string
), 0, len
);
2231 STRING_SET_CHARS (string
, len
);
2232 STRING_SET_UNIBYTE (string
);
2238 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2240 Lisp_Object args
[2];
2243 return Fnconc (2, args
);
2246 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2247 doc
: /* Concatenate any number of lists by altering them.
2248 Only the last argument is not altered, and need not be a list.
2249 usage: (nconc &rest LISTS) */)
2250 (int nargs
, Lisp_Object
*args
)
2252 register int argnum
;
2253 register Lisp_Object tail
, tem
, val
;
2257 for (argnum
= 0; argnum
< nargs
; argnum
++)
2260 if (NILP (tem
)) continue;
2265 if (argnum
+ 1 == nargs
) break;
2267 CHECK_LIST_CONS (tem
, tem
);
2276 tem
= args
[argnum
+ 1];
2277 Fsetcdr (tail
, tem
);
2279 args
[argnum
+ 1] = tail
;
2285 /* This is the guts of all mapping functions.
2286 Apply FN to each element of SEQ, one by one,
2287 storing the results into elements of VALS, a C vector of Lisp_Objects.
2288 LENI is the length of VALS, which should also be the length of SEQ. */
2291 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2293 register Lisp_Object tail
;
2295 register EMACS_INT i
;
2296 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2300 /* Don't let vals contain any garbage when GC happens. */
2301 for (i
= 0; i
< leni
; i
++)
2304 GCPRO3 (dummy
, fn
, seq
);
2306 gcpro1
.nvars
= leni
;
2310 /* We need not explicitly protect `tail' because it is used only on lists, and
2311 1) lists are not relocated and 2) the list is marked via `seq' so will not
2316 for (i
= 0; i
< leni
; i
++)
2318 dummy
= call1 (fn
, AREF (seq
, i
));
2323 else if (BOOL_VECTOR_P (seq
))
2325 for (i
= 0; i
< leni
; i
++)
2328 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2329 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2330 dummy
= call1 (fn
, dummy
);
2335 else if (STRINGP (seq
))
2339 for (i
= 0, i_byte
= 0; i
< leni
;)
2342 EMACS_INT i_before
= i
;
2344 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2345 XSETFASTINT (dummy
, c
);
2346 dummy
= call1 (fn
, dummy
);
2348 vals
[i_before
] = dummy
;
2351 else /* Must be a list, since Flength did not get an error */
2354 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2356 dummy
= call1 (fn
, XCAR (tail
));
2366 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2367 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2368 In between each pair of results, stick in SEPARATOR. Thus, " " as
2369 SEPARATOR results in spaces between the values returned by FUNCTION.
2370 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2371 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2374 register EMACS_INT leni
;
2376 register Lisp_Object
*args
;
2377 register EMACS_INT i
;
2378 struct gcpro gcpro1
;
2382 len
= Flength (sequence
);
2383 if (CHAR_TABLE_P (sequence
))
2384 wrong_type_argument (Qlistp
, sequence
);
2386 nargs
= leni
+ leni
- 1;
2387 if (nargs
< 0) return empty_unibyte_string
;
2389 SAFE_ALLOCA_LISP (args
, nargs
);
2392 mapcar1 (leni
, args
, function
, sequence
);
2395 for (i
= leni
- 1; i
> 0; i
--)
2396 args
[i
+ i
] = args
[i
];
2398 for (i
= 1; i
< nargs
; i
+= 2)
2399 args
[i
] = separator
;
2401 ret
= Fconcat (nargs
, args
);
2407 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2408 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2409 The result is a list just as long as SEQUENCE.
2410 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2411 (Lisp_Object function
, Lisp_Object sequence
)
2413 register Lisp_Object len
;
2414 register EMACS_INT leni
;
2415 register Lisp_Object
*args
;
2419 len
= Flength (sequence
);
2420 if (CHAR_TABLE_P (sequence
))
2421 wrong_type_argument (Qlistp
, sequence
);
2422 leni
= XFASTINT (len
);
2424 SAFE_ALLOCA_LISP (args
, leni
);
2426 mapcar1 (leni
, args
, function
, sequence
);
2428 ret
= Flist (leni
, args
);
2434 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2435 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2436 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2437 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2438 (Lisp_Object function
, Lisp_Object sequence
)
2440 register EMACS_INT leni
;
2442 leni
= XFASTINT (Flength (sequence
));
2443 if (CHAR_TABLE_P (sequence
))
2444 wrong_type_argument (Qlistp
, sequence
);
2445 mapcar1 (leni
, 0, function
, sequence
);
2450 /* This is how C code calls `yes-or-no-p' and allows the user
2453 Anything that calls this function must protect from GC! */
2456 do_yes_or_no_p (Lisp_Object prompt
)
2458 return call1 (intern ("yes-or-no-p"), prompt
);
2461 /* Anything that calls this function must protect from GC! */
2463 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, MANY
, 0,
2464 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2465 The string to display to ask the question is obtained by
2466 formatting the string PROMPT with arguments ARGS (see `format').
2467 The result should end in a space; `yes-or-no-p' adds
2468 \"(yes or no) \" to it.
2470 The user must confirm the answer with RET, and can edit it until it
2473 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2474 is nil, and `use-dialog-box' is non-nil.
2475 usage: (yes-or-no-p PROMPT &rest ARGS) */)
2476 (int nargs
, Lisp_Object
*args
)
2478 register Lisp_Object ans
;
2479 struct gcpro gcpro1
;
2480 Lisp_Object prompt
= Fformat (nargs
, args
);
2483 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2484 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2488 Lisp_Object pane
, menu
, obj
;
2489 redisplay_preserve_echo_area (4);
2490 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2491 Fcons (Fcons (build_string ("No"), Qnil
),
2494 menu
= Fcons (prompt
, pane
);
2495 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2499 #endif /* HAVE_MENUS */
2501 prompt
= concat2 (prompt
, build_string ("(yes or no) "));
2506 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2507 Qyes_or_no_p_history
, Qnil
,
2509 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2514 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2522 message ("Please answer yes or no.");
2523 Fsleep_for (make_number (2), Qnil
);
2527 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2528 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2530 Each of the three load averages is multiplied by 100, then converted
2533 When USE-FLOATS is non-nil, floats will be used instead of integers.
2534 These floats are not multiplied by 100.
2536 If the 5-minute or 15-minute load averages are not available, return a
2537 shortened list, containing only those averages which are available.
2539 An error is thrown if the load average can't be obtained. In some
2540 cases making it work would require Emacs being installed setuid or
2541 setgid so that it can read kernel information, and that usually isn't
2543 (Lisp_Object use_floats
)
2546 int loads
= getloadavg (load_ave
, 3);
2547 Lisp_Object ret
= Qnil
;
2550 error ("load-average not implemented for this operating system");
2554 Lisp_Object load
= (NILP (use_floats
) ?
2555 make_number ((int) (100.0 * load_ave
[loads
]))
2556 : make_float (load_ave
[loads
]));
2557 ret
= Fcons (load
, ret
);
2563 Lisp_Object Vfeatures
, Qsubfeatures
;
2565 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2566 doc
: /* Return t if FEATURE is present in this Emacs.
2568 Use this to conditionalize execution of lisp code based on the
2569 presence or absence of Emacs or environment extensions.
2570 Use `provide' to declare that a feature is available. This function
2571 looks at the value of the variable `features'. The optional argument
2572 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2573 (Lisp_Object feature
, Lisp_Object subfeature
)
2575 register Lisp_Object tem
;
2576 CHECK_SYMBOL (feature
);
2577 tem
= Fmemq (feature
, Vfeatures
);
2578 if (!NILP (tem
) && !NILP (subfeature
))
2579 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2580 return (NILP (tem
)) ? Qnil
: Qt
;
2583 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2584 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2585 The optional argument SUBFEATURES should be a list of symbols listing
2586 particular subfeatures supported in this version of FEATURE. */)
2587 (Lisp_Object feature
, Lisp_Object subfeatures
)
2589 register Lisp_Object tem
;
2590 CHECK_SYMBOL (feature
);
2591 CHECK_LIST (subfeatures
);
2592 if (!NILP (Vautoload_queue
))
2593 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2595 tem
= Fmemq (feature
, Vfeatures
);
2597 Vfeatures
= Fcons (feature
, Vfeatures
);
2598 if (!NILP (subfeatures
))
2599 Fput (feature
, Qsubfeatures
, subfeatures
);
2600 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2602 /* Run any load-hooks for this file. */
2603 tem
= Fassq (feature
, Vafter_load_alist
);
2605 Fprogn (XCDR (tem
));
2610 /* `require' and its subroutines. */
2612 /* List of features currently being require'd, innermost first. */
2614 Lisp_Object require_nesting_list
;
2617 require_unwind (Lisp_Object old_value
)
2619 return require_nesting_list
= old_value
;
2622 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2623 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2624 If FEATURE is not a member of the list `features', then the feature
2625 is not loaded; so load the file FILENAME.
2626 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2627 and `load' will try to load this name appended with the suffix `.elc' or
2628 `.el', in that order. The name without appended suffix will not be used.
2629 If the optional third argument NOERROR is non-nil,
2630 then return nil if the file is not found instead of signaling an error.
2631 Normally the return value is FEATURE.
2632 The normal messages at start and end of loading FILENAME are suppressed. */)
2633 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2635 register Lisp_Object tem
;
2636 struct gcpro gcpro1
, gcpro2
;
2637 int from_file
= load_in_progress
;
2639 CHECK_SYMBOL (feature
);
2641 /* Record the presence of `require' in this file
2642 even if the feature specified is already loaded.
2643 But not more than once in any file,
2644 and not when we aren't loading or reading from a file. */
2646 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2647 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2652 tem
= Fcons (Qrequire
, feature
);
2653 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2654 LOADHIST_ATTACH (tem
);
2656 tem
= Fmemq (feature
, Vfeatures
);
2660 int count
= SPECPDL_INDEX ();
2663 /* This is to make sure that loadup.el gives a clear picture
2664 of what files are preloaded and when. */
2665 if (! NILP (Vpurify_flag
))
2666 error ("(require %s) while preparing to dump",
2667 SDATA (SYMBOL_NAME (feature
)));
2669 /* A certain amount of recursive `require' is legitimate,
2670 but if we require the same feature recursively 3 times,
2672 tem
= require_nesting_list
;
2673 while (! NILP (tem
))
2675 if (! NILP (Fequal (feature
, XCAR (tem
))))
2680 error ("Recursive `require' for feature `%s'",
2681 SDATA (SYMBOL_NAME (feature
)));
2683 /* Update the list for any nested `require's that occur. */
2684 record_unwind_protect (require_unwind
, require_nesting_list
);
2685 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2687 /* Value saved here is to be restored into Vautoload_queue */
2688 record_unwind_protect (un_autoload
, Vautoload_queue
);
2689 Vautoload_queue
= Qt
;
2691 /* Load the file. */
2692 GCPRO2 (feature
, filename
);
2693 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2694 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2697 /* If load failed entirely, return nil. */
2699 return unbind_to (count
, Qnil
);
2701 tem
= Fmemq (feature
, Vfeatures
);
2703 error ("Required feature `%s' was not provided",
2704 SDATA (SYMBOL_NAME (feature
)));
2706 /* Once loading finishes, don't undo it. */
2707 Vautoload_queue
= Qt
;
2708 feature
= unbind_to (count
, feature
);
2714 /* Primitives for work of the "widget" library.
2715 In an ideal world, this section would not have been necessary.
2716 However, lisp function calls being as slow as they are, it turns
2717 out that some functions in the widget library (wid-edit.el) are the
2718 bottleneck of Widget operation. Here is their translation to C,
2719 for the sole reason of efficiency. */
2721 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2722 doc
: /* Return non-nil if PLIST has the property PROP.
2723 PLIST is a property list, which is a list of the form
2724 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2725 Unlike `plist-get', this allows you to distinguish between a missing
2726 property and a property with the value nil.
2727 The value is actually the tail of PLIST whose car is PROP. */)
2728 (Lisp_Object plist
, Lisp_Object prop
)
2730 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2733 plist
= XCDR (plist
);
2734 plist
= CDR (plist
);
2739 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2740 doc
: /* In WIDGET, set PROPERTY to VALUE.
2741 The value can later be retrieved with `widget-get'. */)
2742 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2744 CHECK_CONS (widget
);
2745 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2749 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2750 doc
: /* In WIDGET, get the value of PROPERTY.
2751 The value could either be specified when the widget was created, or
2752 later with `widget-put'. */)
2753 (Lisp_Object widget
, Lisp_Object property
)
2761 CHECK_CONS (widget
);
2762 tmp
= Fplist_member (XCDR (widget
), property
);
2768 tmp
= XCAR (widget
);
2771 widget
= Fget (tmp
, Qwidget_type
);
2775 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2776 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2777 ARGS are passed as extra arguments to the function.
2778 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2779 (int nargs
, Lisp_Object
*args
)
2781 /* This function can GC. */
2782 Lisp_Object newargs
[3];
2783 struct gcpro gcpro1
, gcpro2
;
2786 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2787 newargs
[1] = args
[0];
2788 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2789 GCPRO2 (newargs
[0], newargs
[2]);
2790 result
= Fapply (3, newargs
);
2795 #ifdef HAVE_LANGINFO_CODESET
2796 #include <langinfo.h>
2799 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2800 doc
: /* Access locale data ITEM for the current C locale, if available.
2801 ITEM should be one of the following:
2803 `codeset', returning the character set as a string (locale item CODESET);
2805 `days', returning a 7-element vector of day names (locale items DAY_n);
2807 `months', returning a 12-element vector of month names (locale items MON_n);
2809 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2810 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2812 If the system can't provide such information through a call to
2813 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2815 See also Info node `(libc)Locales'.
2817 The data read from the system are decoded using `locale-coding-system'. */)
2821 #ifdef HAVE_LANGINFO_CODESET
2823 if (EQ (item
, Qcodeset
))
2825 str
= nl_langinfo (CODESET
);
2826 return build_string (str
);
2829 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2831 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2832 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2834 struct gcpro gcpro1
;
2836 synchronize_system_time_locale ();
2837 for (i
= 0; i
< 7; i
++)
2839 str
= nl_langinfo (days
[i
]);
2840 val
= make_unibyte_string (str
, strlen (str
));
2841 /* Fixme: Is this coding system necessarily right, even if
2842 it is consistent with CODESET? If not, what to do? */
2843 Faset (v
, make_number (i
),
2844 code_convert_string_norecord (val
, Vlocale_coding_system
,
2852 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2854 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2855 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2856 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2858 struct gcpro gcpro1
;
2860 synchronize_system_time_locale ();
2861 for (i
= 0; i
< 12; i
++)
2863 str
= nl_langinfo (months
[i
]);
2864 val
= make_unibyte_string (str
, strlen (str
));
2865 Faset (v
, make_number (i
),
2866 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2872 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2873 but is in the locale files. This could be used by ps-print. */
2875 else if (EQ (item
, Qpaper
))
2877 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2878 make_number (nl_langinfo (PAPER_HEIGHT
)));
2880 #endif /* PAPER_WIDTH */
2881 #endif /* HAVE_LANGINFO_CODESET*/
2885 /* base64 encode/decode functions (RFC 2045).
2886 Based on code from GNU recode. */
2888 #define MIME_LINE_LENGTH 76
2890 #define IS_ASCII(Character) \
2892 #define IS_BASE64(Character) \
2893 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2894 #define IS_BASE64_IGNORABLE(Character) \
2895 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2896 || (Character) == '\f' || (Character) == '\r')
2898 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2899 character or return retval if there are no characters left to
2901 #define READ_QUADRUPLET_BYTE(retval) \
2906 if (nchars_return) \
2907 *nchars_return = nchars; \
2912 while (IS_BASE64_IGNORABLE (c))
2914 /* Table of characters coding the 64 values. */
2915 static const char base64_value_to_char
[64] =
2917 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2918 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2919 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2920 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2921 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2922 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2923 '8', '9', '+', '/' /* 60-63 */
2926 /* Table of base64 values for first 128 characters. */
2927 static const short base64_char_to_value
[128] =
2929 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2930 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2931 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2932 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2933 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2934 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2935 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2936 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2937 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2938 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2939 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2940 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2941 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2944 /* The following diagram shows the logical steps by which three octets
2945 get transformed into four base64 characters.
2947 .--------. .--------. .--------.
2948 |aaaaaabb| |bbbbcccc| |ccdddddd|
2949 `--------' `--------' `--------'
2951 .--------+--------+--------+--------.
2952 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2953 `--------+--------+--------+--------'
2955 .--------+--------+--------+--------.
2956 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2957 `--------+--------+--------+--------'
2959 The octets are divided into 6 bit chunks, which are then encoded into
2960 base64 characters. */
2963 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2964 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2967 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2969 doc
: /* Base64-encode the region between BEG and END.
2970 Return the length of the encoded text.
2971 Optional third argument NO-LINE-BREAK means do not break long lines
2972 into shorter lines. */)
2973 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2976 EMACS_INT allength
, length
;
2977 EMACS_INT ibeg
, iend
, encoded_length
;
2978 EMACS_INT old_pos
= PT
;
2981 validate_region (&beg
, &end
);
2983 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2984 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2985 move_gap_both (XFASTINT (beg
), ibeg
);
2987 /* We need to allocate enough room for encoding the text.
2988 We need 33 1/3% more space, plus a newline every 76
2989 characters, and then we round up. */
2990 length
= iend
- ibeg
;
2991 allength
= length
+ length
/3 + 1;
2992 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2994 SAFE_ALLOCA (encoded
, char *, allength
);
2995 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2996 NILP (no_line_break
),
2997 !NILP (current_buffer
->enable_multibyte_characters
));
2998 if (encoded_length
> allength
)
3001 if (encoded_length
< 0)
3003 /* The encoding wasn't possible. */
3005 error ("Multibyte character in data for base64 encoding");
3008 /* Now we have encoded the region, so we insert the new contents
3009 and delete the old. (Insert first in order to preserve markers.) */
3010 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3011 insert (encoded
, encoded_length
);
3013 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3015 /* If point was outside of the region, restore it exactly; else just
3016 move to the beginning of the region. */
3017 if (old_pos
>= XFASTINT (end
))
3018 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3019 else if (old_pos
> XFASTINT (beg
))
3020 old_pos
= XFASTINT (beg
);
3023 /* We return the length of the encoded text. */
3024 return make_number (encoded_length
);
3027 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3029 doc
: /* Base64-encode STRING and return the result.
3030 Optional second argument NO-LINE-BREAK means do not break long lines
3031 into shorter lines. */)
3032 (Lisp_Object string
, Lisp_Object no_line_break
)
3034 EMACS_INT allength
, length
, encoded_length
;
3036 Lisp_Object encoded_string
;
3039 CHECK_STRING (string
);
3041 /* We need to allocate enough room for encoding the text.
3042 We need 33 1/3% more space, plus a newline every 76
3043 characters, and then we round up. */
3044 length
= SBYTES (string
);
3045 allength
= length
+ length
/3 + 1;
3046 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3048 /* We need to allocate enough room for decoding the text. */
3049 SAFE_ALLOCA (encoded
, char *, allength
);
3051 encoded_length
= base64_encode_1 (SDATA (string
),
3052 encoded
, length
, NILP (no_line_break
),
3053 STRING_MULTIBYTE (string
));
3054 if (encoded_length
> allength
)
3057 if (encoded_length
< 0)
3059 /* The encoding wasn't possible. */
3061 error ("Multibyte character in data for base64 encoding");
3064 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3067 return encoded_string
;
3071 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3072 int line_break
, int multibyte
)
3085 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3086 if (CHAR_BYTE8_P (c
))
3087 c
= CHAR_TO_BYTE8 (c
);
3095 /* Wrap line every 76 characters. */
3099 if (counter
< MIME_LINE_LENGTH
/ 4)
3108 /* Process first byte of a triplet. */
3110 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3111 value
= (0x03 & c
) << 4;
3113 /* Process second byte of a triplet. */
3117 *e
++ = base64_value_to_char
[value
];
3125 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3126 if (CHAR_BYTE8_P (c
))
3127 c
= CHAR_TO_BYTE8 (c
);
3135 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3136 value
= (0x0f & c
) << 2;
3138 /* Process third byte of a triplet. */
3142 *e
++ = base64_value_to_char
[value
];
3149 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3150 if (CHAR_BYTE8_P (c
))
3151 c
= CHAR_TO_BYTE8 (c
);
3159 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3160 *e
++ = base64_value_to_char
[0x3f & c
];
3167 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3169 doc
: /* Base64-decode the region between BEG and END.
3170 Return the length of the decoded text.
3171 If the region can't be decoded, signal an error and don't modify the buffer. */)
3172 (Lisp_Object beg
, Lisp_Object end
)
3174 EMACS_INT ibeg
, iend
, length
, allength
;
3176 EMACS_INT old_pos
= PT
;
3177 EMACS_INT decoded_length
;
3178 EMACS_INT inserted_chars
;
3179 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3182 validate_region (&beg
, &end
);
3184 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3185 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3187 length
= iend
- ibeg
;
3189 /* We need to allocate enough room for decoding the text. If we are
3190 working on a multibyte buffer, each decoded code may occupy at
3192 allength
= multibyte
? length
* 2 : length
;
3193 SAFE_ALLOCA (decoded
, char *, allength
);
3195 move_gap_both (XFASTINT (beg
), ibeg
);
3196 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3197 multibyte
, &inserted_chars
);
3198 if (decoded_length
> allength
)
3201 if (decoded_length
< 0)
3203 /* The decoding wasn't possible. */
3205 error ("Invalid base64 data");
3208 /* Now we have decoded the region, so we insert the new contents
3209 and delete the old. (Insert first in order to preserve markers.) */
3210 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3211 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3214 /* Delete the original text. */
3215 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3216 iend
+ decoded_length
, 1);
3218 /* If point was outside of the region, restore it exactly; else just
3219 move to the beginning of the region. */
3220 if (old_pos
>= XFASTINT (end
))
3221 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3222 else if (old_pos
> XFASTINT (beg
))
3223 old_pos
= XFASTINT (beg
);
3224 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3226 return make_number (inserted_chars
);
3229 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3231 doc
: /* Base64-decode STRING and return the result. */)
3232 (Lisp_Object string
)
3235 EMACS_INT length
, decoded_length
;
3236 Lisp_Object decoded_string
;
3239 CHECK_STRING (string
);
3241 length
= SBYTES (string
);
3242 /* We need to allocate enough room for decoding the text. */
3243 SAFE_ALLOCA (decoded
, char *, length
);
3245 /* The decoded result should be unibyte. */
3246 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3248 if (decoded_length
> length
)
3250 else if (decoded_length
>= 0)
3251 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3253 decoded_string
= Qnil
;
3256 if (!STRINGP (decoded_string
))
3257 error ("Invalid base64 data");
3259 return decoded_string
;
3262 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3263 MULTIBYTE is nonzero, the decoded result should be in multibyte
3264 form. If NCHARS_RETRUN is not NULL, store the number of produced
3265 characters in *NCHARS_RETURN. */
3268 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3269 int multibyte
, EMACS_INT
*nchars_return
)
3271 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3274 unsigned long value
;
3275 EMACS_INT nchars
= 0;
3279 /* Process first byte of a quadruplet. */
3281 READ_QUADRUPLET_BYTE (e
-to
);
3285 value
= base64_char_to_value
[c
] << 18;
3287 /* Process second byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (-1);
3293 value
|= base64_char_to_value
[c
] << 12;
3295 c
= (unsigned char) (value
>> 16);
3296 if (multibyte
&& c
>= 128)
3297 e
+= BYTE8_STRING (c
, e
);
3302 /* Process third byte of a quadruplet. */
3304 READ_QUADRUPLET_BYTE (-1);
3308 READ_QUADRUPLET_BYTE (-1);
3317 value
|= base64_char_to_value
[c
] << 6;
3319 c
= (unsigned char) (0xff & value
>> 8);
3320 if (multibyte
&& c
>= 128)
3321 e
+= BYTE8_STRING (c
, e
);
3326 /* Process fourth byte of a quadruplet. */
3328 READ_QUADRUPLET_BYTE (-1);
3335 value
|= base64_char_to_value
[c
];
3337 c
= (unsigned char) (0xff & value
);
3338 if (multibyte
&& c
>= 128)
3339 e
+= BYTE8_STRING (c
, e
);
3348 /***********************************************************************
3350 ***** Hash Tables *****
3352 ***********************************************************************/
3354 /* Implemented by gerd@gnu.org. This hash table implementation was
3355 inspired by CMUCL hash tables. */
3359 1. For small tables, association lists are probably faster than
3360 hash tables because they have lower overhead.
3362 For uses of hash tables where the O(1) behavior of table
3363 operations is not a requirement, it might therefore be a good idea
3364 not to hash. Instead, we could just do a linear search in the
3365 key_and_value vector of the hash table. This could be done
3366 if a `:linear-search t' argument is given to make-hash-table. */
3369 /* The list of all weak hash tables. Don't staticpro this one. */
3371 struct Lisp_Hash_Table
*weak_hash_tables
;
3373 /* Various symbols. */
3375 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3376 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3377 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3379 /* Function prototypes. */
3381 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3382 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3383 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3384 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3385 Lisp_Object
, unsigned);
3386 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3387 Lisp_Object
, unsigned);
3388 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3389 unsigned, Lisp_Object
, unsigned);
3390 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3391 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3392 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3393 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3395 static unsigned sxhash_string (unsigned char *, int);
3396 static unsigned sxhash_list (Lisp_Object
, int);
3397 static unsigned sxhash_vector (Lisp_Object
, int);
3398 static unsigned sxhash_bool_vector (Lisp_Object
);
3399 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3403 /***********************************************************************
3405 ***********************************************************************/
3407 /* If OBJ is a Lisp hash table, return a pointer to its struct
3408 Lisp_Hash_Table. Otherwise, signal an error. */
3410 static struct Lisp_Hash_Table
*
3411 check_hash_table (Lisp_Object obj
)
3413 CHECK_HASH_TABLE (obj
);
3414 return XHASH_TABLE (obj
);
3418 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3422 next_almost_prime (int n
)
3434 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3435 which USED[I] is non-zero. If found at index I in ARGS, set
3436 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3437 -1. This function is used to extract a keyword/argument pair from
3438 a DEFUN parameter list. */
3441 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3445 for (i
= 0; i
< nargs
- 1; ++i
)
3446 if (!used
[i
] && EQ (args
[i
], key
))
3461 /* Return a Lisp vector which has the same contents as VEC but has
3462 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3463 vector that are not copied from VEC are set to INIT. */
3466 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3468 struct Lisp_Vector
*v
;
3471 xassert (VECTORP (vec
));
3472 old_size
= ASIZE (vec
);
3473 xassert (new_size
>= old_size
);
3475 v
= allocate_vector (new_size
);
3476 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3477 for (i
= old_size
; i
< new_size
; ++i
)
3478 v
->contents
[i
] = init
;
3479 XSETVECTOR (vec
, v
);
3484 /***********************************************************************
3486 ***********************************************************************/
3488 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3489 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3490 KEY2 are the same. */
3493 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3495 return (FLOATP (key1
)
3497 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3501 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3502 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3503 KEY2 are the same. */
3506 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3508 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3512 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3513 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3514 if KEY1 and KEY2 are the same. */
3517 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3521 Lisp_Object args
[3];
3523 args
[0] = h
->user_cmp_function
;
3526 return !NILP (Ffuncall (3, args
));
3533 /* Value is a hash code for KEY for use in hash table H which uses
3534 `eq' to compare keys. The hash code returned is guaranteed to fit
3535 in a Lisp integer. */
3538 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3540 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3541 xassert ((hash
& ~INTMASK
) == 0);
3546 /* Value is a hash code for KEY for use in hash table H which uses
3547 `eql' to compare keys. The hash code returned is guaranteed to fit
3548 in a Lisp integer. */
3551 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3555 hash
= sxhash (key
, 0);
3557 hash
= XUINT (key
) ^ XTYPE (key
);
3558 xassert ((hash
& ~INTMASK
) == 0);
3563 /* Value is a hash code for KEY for use in hash table H which uses
3564 `equal' to compare keys. The hash code returned is guaranteed to fit
3565 in a Lisp integer. */
3568 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3570 unsigned hash
= sxhash (key
, 0);
3571 xassert ((hash
& ~INTMASK
) == 0);
3576 /* Value is a hash code for KEY for use in hash table H which uses as
3577 user-defined function to compare keys. The hash code returned is
3578 guaranteed to fit in a Lisp integer. */
3581 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3583 Lisp_Object args
[2], hash
;
3585 args
[0] = h
->user_hash_function
;
3587 hash
= Ffuncall (2, args
);
3588 if (!INTEGERP (hash
))
3589 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3590 return XUINT (hash
);
3594 /* Create and initialize a new hash table.
3596 TEST specifies the test the hash table will use to compare keys.
3597 It must be either one of the predefined tests `eq', `eql' or
3598 `equal' or a symbol denoting a user-defined test named TEST with
3599 test and hash functions USER_TEST and USER_HASH.
3601 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3603 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3604 new size when it becomes full is computed by adding REHASH_SIZE to
3605 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3606 table's new size is computed by multiplying its old size with
3609 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3610 be resized when the ratio of (number of entries in the table) /
3611 (table size) is >= REHASH_THRESHOLD.
3613 WEAK specifies the weakness of the table. If non-nil, it must be
3614 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3617 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3618 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3619 Lisp_Object user_test
, Lisp_Object user_hash
)
3621 struct Lisp_Hash_Table
*h
;
3623 int index_size
, i
, sz
;
3625 /* Preconditions. */
3626 xassert (SYMBOLP (test
));
3627 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3628 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3629 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3630 xassert (FLOATP (rehash_threshold
)
3631 && XFLOATINT (rehash_threshold
) > 0
3632 && XFLOATINT (rehash_threshold
) <= 1.0);
3634 if (XFASTINT (size
) == 0)
3635 size
= make_number (1);
3637 /* Allocate a table and initialize it. */
3638 h
= allocate_hash_table ();
3640 /* Initialize hash table slots. */
3641 sz
= XFASTINT (size
);
3644 if (EQ (test
, Qeql
))
3646 h
->cmpfn
= cmpfn_eql
;
3647 h
->hashfn
= hashfn_eql
;
3649 else if (EQ (test
, Qeq
))
3652 h
->hashfn
= hashfn_eq
;
3654 else if (EQ (test
, Qequal
))
3656 h
->cmpfn
= cmpfn_equal
;
3657 h
->hashfn
= hashfn_equal
;
3661 h
->user_cmp_function
= user_test
;
3662 h
->user_hash_function
= user_hash
;
3663 h
->cmpfn
= cmpfn_user_defined
;
3664 h
->hashfn
= hashfn_user_defined
;
3668 h
->rehash_threshold
= rehash_threshold
;
3669 h
->rehash_size
= rehash_size
;
3671 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3672 h
->hash
= Fmake_vector (size
, Qnil
);
3673 h
->next
= Fmake_vector (size
, Qnil
);
3674 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3675 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3676 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3678 /* Set up the free list. */
3679 for (i
= 0; i
< sz
- 1; ++i
)
3680 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3681 h
->next_free
= make_number (0);
3683 XSET_HASH_TABLE (table
, h
);
3684 xassert (HASH_TABLE_P (table
));
3685 xassert (XHASH_TABLE (table
) == h
);
3687 /* Maybe add this hash table to the list of all weak hash tables. */
3689 h
->next_weak
= NULL
;
3692 h
->next_weak
= weak_hash_tables
;
3693 weak_hash_tables
= h
;
3700 /* Return a copy of hash table H1. Keys and values are not copied,
3701 only the table itself is. */
3704 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3707 struct Lisp_Hash_Table
*h2
;
3708 struct Lisp_Vector
*next
;
3710 h2
= allocate_hash_table ();
3711 next
= h2
->vec_next
;
3712 memcpy (h2
, h1
, sizeof *h2
);
3713 h2
->vec_next
= next
;
3714 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3715 h2
->hash
= Fcopy_sequence (h1
->hash
);
3716 h2
->next
= Fcopy_sequence (h1
->next
);
3717 h2
->index
= Fcopy_sequence (h1
->index
);
3718 XSET_HASH_TABLE (table
, h2
);
3720 /* Maybe add this hash table to the list of all weak hash tables. */
3721 if (!NILP (h2
->weak
))
3723 h2
->next_weak
= weak_hash_tables
;
3724 weak_hash_tables
= h2
;
3731 /* Resize hash table H if it's too full. If H cannot be resized
3732 because it's already too large, throw an error. */
3735 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3737 if (NILP (h
->next_free
))
3739 int old_size
= HASH_TABLE_SIZE (h
);
3740 int i
, new_size
, index_size
;
3743 if (INTEGERP (h
->rehash_size
))
3744 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3746 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3747 new_size
= max (old_size
+ 1, new_size
);
3748 index_size
= next_almost_prime ((int)
3750 / XFLOATINT (h
->rehash_threshold
)));
3751 /* Assignment to EMACS_INT stops GCC whining about limited range
3753 nsize
= max (index_size
, 2 * new_size
);
3754 if (nsize
> MOST_POSITIVE_FIXNUM
)
3755 error ("Hash table too large to resize");
3757 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3758 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3759 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3760 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3762 /* Update the free list. Do it so that new entries are added at
3763 the end of the free list. This makes some operations like
3765 for (i
= old_size
; i
< new_size
- 1; ++i
)
3766 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3768 if (!NILP (h
->next_free
))
3770 Lisp_Object last
, next
;
3772 last
= h
->next_free
;
3773 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3777 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3780 XSETFASTINT (h
->next_free
, old_size
);
3783 for (i
= 0; i
< old_size
; ++i
)
3784 if (!NILP (HASH_HASH (h
, i
)))
3786 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3787 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3788 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3789 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3795 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3796 the hash code of KEY. Value is the index of the entry in H
3797 matching KEY, or -1 if not found. */
3800 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3803 int start_of_bucket
;
3806 hash_code
= h
->hashfn (h
, key
);
3810 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3811 idx
= HASH_INDEX (h
, start_of_bucket
);
3813 /* We need not gcpro idx since it's either an integer or nil. */
3816 int i
= XFASTINT (idx
);
3817 if (EQ (key
, HASH_KEY (h
, i
))
3819 && h
->cmpfn (h
, key
, hash_code
,
3820 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3822 idx
= HASH_NEXT (h
, i
);
3825 return NILP (idx
) ? -1 : XFASTINT (idx
);
3829 /* Put an entry into hash table H that associates KEY with VALUE.
3830 HASH is a previously computed hash code of KEY.
3831 Value is the index of the entry in H matching KEY. */
3834 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3836 int start_of_bucket
, i
;
3838 xassert ((hash
& ~INTMASK
) == 0);
3840 /* Increment count after resizing because resizing may fail. */
3841 maybe_resize_hash_table (h
);
3844 /* Store key/value in the key_and_value vector. */
3845 i
= XFASTINT (h
->next_free
);
3846 h
->next_free
= HASH_NEXT (h
, i
);
3847 HASH_KEY (h
, i
) = key
;
3848 HASH_VALUE (h
, i
) = value
;
3850 /* Remember its hash code. */
3851 HASH_HASH (h
, i
) = make_number (hash
);
3853 /* Add new entry to its collision chain. */
3854 start_of_bucket
= hash
% ASIZE (h
->index
);
3855 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3856 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3861 /* Remove the entry matching KEY from hash table H, if there is one. */
3864 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3867 int start_of_bucket
;
3868 Lisp_Object idx
, prev
;
3870 hash_code
= h
->hashfn (h
, key
);
3871 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3872 idx
= HASH_INDEX (h
, start_of_bucket
);
3875 /* We need not gcpro idx, prev since they're either integers or nil. */
3878 int i
= XFASTINT (idx
);
3880 if (EQ (key
, HASH_KEY (h
, i
))
3882 && h
->cmpfn (h
, key
, hash_code
,
3883 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3885 /* Take entry out of collision chain. */
3887 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3889 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3891 /* Clear slots in key_and_value and add the slots to
3893 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3894 HASH_NEXT (h
, i
) = h
->next_free
;
3895 h
->next_free
= make_number (i
);
3897 xassert (h
->count
>= 0);
3903 idx
= HASH_NEXT (h
, i
);
3909 /* Clear hash table H. */
3912 hash_clear (struct Lisp_Hash_Table
*h
)
3916 int i
, size
= HASH_TABLE_SIZE (h
);
3918 for (i
= 0; i
< size
; ++i
)
3920 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3921 HASH_KEY (h
, i
) = Qnil
;
3922 HASH_VALUE (h
, i
) = Qnil
;
3923 HASH_HASH (h
, i
) = Qnil
;
3926 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3927 ASET (h
->index
, i
, Qnil
);
3929 h
->next_free
= make_number (0);
3936 /************************************************************************
3938 ************************************************************************/
3941 init_weak_hash_tables (void)
3943 weak_hash_tables
= NULL
;
3946 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3947 entries from the table that don't survive the current GC.
3948 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3949 non-zero if anything was marked. */
3952 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3954 int bucket
, n
, marked
;
3956 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3959 for (bucket
= 0; bucket
< n
; ++bucket
)
3961 Lisp_Object idx
, next
, prev
;
3963 /* Follow collision chain, removing entries that
3964 don't survive this garbage collection. */
3966 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3968 int i
= XFASTINT (idx
);
3969 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3970 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3973 if (EQ (h
->weak
, Qkey
))
3974 remove_p
= !key_known_to_survive_p
;
3975 else if (EQ (h
->weak
, Qvalue
))
3976 remove_p
= !value_known_to_survive_p
;
3977 else if (EQ (h
->weak
, Qkey_or_value
))
3978 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3979 else if (EQ (h
->weak
, Qkey_and_value
))
3980 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3984 next
= HASH_NEXT (h
, i
);
3986 if (remove_entries_p
)
3990 /* Take out of collision chain. */
3992 HASH_INDEX (h
, bucket
) = next
;
3994 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3996 /* Add to free list. */
3997 HASH_NEXT (h
, i
) = h
->next_free
;
4000 /* Clear key, value, and hash. */
4001 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4002 HASH_HASH (h
, i
) = Qnil
;
4015 /* Make sure key and value survive. */
4016 if (!key_known_to_survive_p
)
4018 mark_object (HASH_KEY (h
, i
));
4022 if (!value_known_to_survive_p
)
4024 mark_object (HASH_VALUE (h
, i
));
4035 /* Remove elements from weak hash tables that don't survive the
4036 current garbage collection. Remove weak tables that don't survive
4037 from Vweak_hash_tables. Called from gc_sweep. */
4040 sweep_weak_hash_tables (void)
4042 struct Lisp_Hash_Table
*h
, *used
, *next
;
4045 /* Mark all keys and values that are in use. Keep on marking until
4046 there is no more change. This is necessary for cases like
4047 value-weak table A containing an entry X -> Y, where Y is used in a
4048 key-weak table B, Z -> Y. If B comes after A in the list of weak
4049 tables, X -> Y might be removed from A, although when looking at B
4050 one finds that it shouldn't. */
4054 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4056 if (h
->size
& ARRAY_MARK_FLAG
)
4057 marked
|= sweep_weak_table (h
, 0);
4062 /* Remove tables and entries that aren't used. */
4063 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4065 next
= h
->next_weak
;
4067 if (h
->size
& ARRAY_MARK_FLAG
)
4069 /* TABLE is marked as used. Sweep its contents. */
4071 sweep_weak_table (h
, 1);
4073 /* Add table to the list of used weak hash tables. */
4074 h
->next_weak
= used
;
4079 weak_hash_tables
= used
;
4084 /***********************************************************************
4085 Hash Code Computation
4086 ***********************************************************************/
4088 /* Maximum depth up to which to dive into Lisp structures. */
4090 #define SXHASH_MAX_DEPTH 3
4092 /* Maximum length up to which to take list and vector elements into
4095 #define SXHASH_MAX_LEN 7
4097 /* Combine two integers X and Y for hashing. */
4099 #define SXHASH_COMBINE(X, Y) \
4100 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4104 /* Return a hash for string PTR which has length LEN. The hash
4105 code returned is guaranteed to fit in a Lisp integer. */
4108 sxhash_string (unsigned char *ptr
, int len
)
4110 unsigned char *p
= ptr
;
4111 unsigned char *end
= p
+ len
;
4120 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4123 return hash
& INTMASK
;
4127 /* Return a hash for list LIST. DEPTH is the current depth in the
4128 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4131 sxhash_list (Lisp_Object list
, int depth
)
4136 if (depth
< SXHASH_MAX_DEPTH
)
4138 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4139 list
= XCDR (list
), ++i
)
4141 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4142 hash
= SXHASH_COMBINE (hash
, hash2
);
4147 unsigned hash2
= sxhash (list
, depth
+ 1);
4148 hash
= SXHASH_COMBINE (hash
, hash2
);
4155 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4156 the Lisp structure. */
4159 sxhash_vector (Lisp_Object vec
, int depth
)
4161 unsigned hash
= ASIZE (vec
);
4164 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4165 for (i
= 0; i
< n
; ++i
)
4167 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4168 hash
= SXHASH_COMBINE (hash
, hash2
);
4175 /* Return a hash for bool-vector VECTOR. */
4178 sxhash_bool_vector (Lisp_Object vec
)
4180 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4183 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4184 for (i
= 0; i
< n
; ++i
)
4185 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4191 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4192 structure. Value is an unsigned integer clipped to INTMASK. */
4195 sxhash (Lisp_Object obj
, int depth
)
4199 if (depth
> SXHASH_MAX_DEPTH
)
4202 switch (XTYPE (obj
))
4213 obj
= SYMBOL_NAME (obj
);
4217 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4220 /* This can be everything from a vector to an overlay. */
4221 case Lisp_Vectorlike
:
4223 /* According to the CL HyperSpec, two arrays are equal only if
4224 they are `eq', except for strings and bit-vectors. In
4225 Emacs, this works differently. We have to compare element
4227 hash
= sxhash_vector (obj
, depth
);
4228 else if (BOOL_VECTOR_P (obj
))
4229 hash
= sxhash_bool_vector (obj
);
4231 /* Others are `equal' if they are `eq', so let's take their
4237 hash
= sxhash_list (obj
, depth
);
4242 double val
= XFLOAT_DATA (obj
);
4243 unsigned char *p
= (unsigned char *) &val
;
4244 unsigned char *e
= p
+ sizeof val
;
4245 for (hash
= 0; p
< e
; ++p
)
4246 hash
= SXHASH_COMBINE (hash
, *p
);
4254 return hash
& INTMASK
;
4259 /***********************************************************************
4261 ***********************************************************************/
4264 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4265 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4268 unsigned hash
= sxhash (obj
, 0);
4269 return make_number (hash
);
4273 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4274 doc
: /* Create and return a new hash table.
4276 Arguments are specified as keyword/argument pairs. The following
4277 arguments are defined:
4279 :test TEST -- TEST must be a symbol that specifies how to compare
4280 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4281 `equal'. User-supplied test and hash functions can be specified via
4282 `define-hash-table-test'.
4284 :size SIZE -- A hint as to how many elements will be put in the table.
4287 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4288 fills up. If REHASH-SIZE is an integer, increase the size by that
4289 amount. If it is a float, it must be > 1.0, and the new size is the
4290 old size multiplied by that factor. Default is 1.5.
4292 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4293 Resize the hash table when the ratio (number of entries / table size)
4294 is greater than or equal to THRESHOLD. Default is 0.8.
4296 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4297 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4298 returned is a weak table. Key/value pairs are removed from a weak
4299 hash table when there are no non-weak references pointing to their
4300 key, value, one of key or value, or both key and value, depending on
4301 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4304 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4305 (int nargs
, Lisp_Object
*args
)
4307 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4308 Lisp_Object user_test
, user_hash
;
4312 /* The vector `used' is used to keep track of arguments that
4313 have been consumed. */
4314 used
= (char *) alloca (nargs
* sizeof *used
);
4315 memset (used
, 0, nargs
* sizeof *used
);
4317 /* See if there's a `:test TEST' among the arguments. */
4318 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4319 test
= i
< 0 ? Qeql
: args
[i
];
4320 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4322 /* See if it is a user-defined test. */
4325 prop
= Fget (test
, Qhash_table_test
);
4326 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4327 signal_error ("Invalid hash table test", test
);
4328 user_test
= XCAR (prop
);
4329 user_hash
= XCAR (XCDR (prop
));
4332 user_test
= user_hash
= Qnil
;
4334 /* See if there's a `:size SIZE' argument. */
4335 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4336 size
= i
< 0 ? Qnil
: args
[i
];
4338 size
= make_number (DEFAULT_HASH_SIZE
);
4339 else if (!INTEGERP (size
) || XINT (size
) < 0)
4340 signal_error ("Invalid hash table size", size
);
4342 /* Look for `:rehash-size SIZE'. */
4343 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4344 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4345 if (!NUMBERP (rehash_size
)
4346 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4347 || XFLOATINT (rehash_size
) <= 1.0)
4348 signal_error ("Invalid hash table rehash size", rehash_size
);
4350 /* Look for `:rehash-threshold THRESHOLD'. */
4351 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4352 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4353 if (!FLOATP (rehash_threshold
)
4354 || XFLOATINT (rehash_threshold
) <= 0.0
4355 || XFLOATINT (rehash_threshold
) > 1.0)
4356 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4358 /* Look for `:weakness WEAK'. */
4359 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4360 weak
= i
< 0 ? Qnil
: args
[i
];
4362 weak
= Qkey_and_value
;
4365 && !EQ (weak
, Qvalue
)
4366 && !EQ (weak
, Qkey_or_value
)
4367 && !EQ (weak
, Qkey_and_value
))
4368 signal_error ("Invalid hash table weakness", weak
);
4370 /* Now, all args should have been used up, or there's a problem. */
4371 for (i
= 0; i
< nargs
; ++i
)
4373 signal_error ("Invalid argument list", args
[i
]);
4375 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4376 user_test
, user_hash
);
4380 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4381 doc
: /* Return a copy of hash table TABLE. */)
4384 return copy_hash_table (check_hash_table (table
));
4388 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4389 doc
: /* Return the number of elements in TABLE. */)
4392 return make_number (check_hash_table (table
)->count
);
4396 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4397 Shash_table_rehash_size
, 1, 1, 0,
4398 doc
: /* Return the current rehash size of TABLE. */)
4401 return check_hash_table (table
)->rehash_size
;
4405 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4406 Shash_table_rehash_threshold
, 1, 1, 0,
4407 doc
: /* Return the current rehash threshold of TABLE. */)
4410 return check_hash_table (table
)->rehash_threshold
;
4414 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4415 doc
: /* Return the size of TABLE.
4416 The size can be used as an argument to `make-hash-table' to create
4417 a hash table than can hold as many elements as TABLE holds
4418 without need for resizing. */)
4421 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4422 return make_number (HASH_TABLE_SIZE (h
));
4426 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4427 doc
: /* Return the test TABLE uses. */)
4430 return check_hash_table (table
)->test
;
4434 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4436 doc
: /* Return the weakness of TABLE. */)
4439 return check_hash_table (table
)->weak
;
4443 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4444 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4447 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4451 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4452 doc
: /* Clear hash table TABLE and return it. */)
4455 hash_clear (check_hash_table (table
));
4456 /* Be compatible with XEmacs. */
4461 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4462 doc
: /* Look up KEY in TABLE and return its associated value.
4463 If KEY is not found, return DFLT which defaults to nil. */)
4464 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4466 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4467 int i
= hash_lookup (h
, key
, NULL
);
4468 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4472 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4473 doc
: /* Associate KEY with VALUE in hash table TABLE.
4474 If KEY is already present in table, replace its current value with
4476 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4478 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4482 i
= hash_lookup (h
, key
, &hash
);
4484 HASH_VALUE (h
, i
) = value
;
4486 hash_put (h
, key
, value
, hash
);
4492 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4493 doc
: /* Remove KEY from TABLE. */)
4494 (Lisp_Object key
, Lisp_Object table
)
4496 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4497 hash_remove_from_table (h
, key
);
4502 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4503 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4504 FUNCTION is called with two arguments, KEY and VALUE. */)
4505 (Lisp_Object function
, Lisp_Object table
)
4507 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4508 Lisp_Object args
[3];
4511 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4512 if (!NILP (HASH_HASH (h
, i
)))
4515 args
[1] = HASH_KEY (h
, i
);
4516 args
[2] = HASH_VALUE (h
, i
);
4524 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4525 Sdefine_hash_table_test
, 3, 3, 0,
4526 doc
: /* Define a new hash table test with name NAME, a symbol.
4528 In hash tables created with NAME specified as test, use TEST to
4529 compare keys, and HASH for computing hash codes of keys.
4531 TEST must be a function taking two arguments and returning non-nil if
4532 both arguments are the same. HASH must be a function taking one
4533 argument and return an integer that is the hash code of the argument.
4534 Hash code computation should use the whole value range of integers,
4535 including negative integers. */)
4536 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4538 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4543 /************************************************************************
4545 ************************************************************************/
4549 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4550 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4552 A message digest is a cryptographic checksum of a document, and the
4553 algorithm to calculate it is defined in RFC 1321.
4555 The two optional arguments START and END are character positions
4556 specifying for which part of OBJECT the message digest should be
4557 computed. If nil or omitted, the digest is computed for the whole
4560 The MD5 message digest is computed from the result of encoding the
4561 text in a coding system, not directly from the internal Emacs form of
4562 the text. The optional fourth argument CODING-SYSTEM specifies which
4563 coding system to encode the text with. It should be the same coding
4564 system that you used or will use when actually writing the text into a
4567 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4568 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4569 system would be chosen by default for writing this text into a file.
4571 If OBJECT is a string, the most preferred coding system (see the
4572 command `prefer-coding-system') is used.
4574 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4575 guesswork fails. Normally, an error is signaled in such case. */)
4576 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4578 unsigned char digest
[16];
4579 unsigned char value
[33];
4582 EMACS_INT size_byte
= 0;
4583 EMACS_INT start_char
= 0, end_char
= 0;
4584 EMACS_INT start_byte
= 0, end_byte
= 0;
4585 register EMACS_INT b
, e
;
4586 register struct buffer
*bp
;
4589 if (STRINGP (object
))
4591 if (NILP (coding_system
))
4593 /* Decide the coding-system to encode the data with. */
4595 if (STRING_MULTIBYTE (object
))
4596 /* use default, we can't guess correct value */
4597 coding_system
= preferred_coding_system ();
4599 coding_system
= Qraw_text
;
4602 if (NILP (Fcoding_system_p (coding_system
)))
4604 /* Invalid coding system. */
4606 if (!NILP (noerror
))
4607 coding_system
= Qraw_text
;
4609 xsignal1 (Qcoding_system_error
, coding_system
);
4612 if (STRING_MULTIBYTE (object
))
4613 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4615 size
= SCHARS (object
);
4616 size_byte
= SBYTES (object
);
4620 CHECK_NUMBER (start
);
4622 start_char
= XINT (start
);
4627 start_byte
= string_char_to_byte (object
, start_char
);
4633 end_byte
= size_byte
;
4639 end_char
= XINT (end
);
4644 end_byte
= string_char_to_byte (object
, end_char
);
4647 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4648 args_out_of_range_3 (object
, make_number (start_char
),
4649 make_number (end_char
));
4653 struct buffer
*prev
= current_buffer
;
4655 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4657 CHECK_BUFFER (object
);
4659 bp
= XBUFFER (object
);
4660 if (bp
!= current_buffer
)
4661 set_buffer_internal (bp
);
4667 CHECK_NUMBER_COERCE_MARKER (start
);
4675 CHECK_NUMBER_COERCE_MARKER (end
);
4680 temp
= b
, b
= e
, e
= temp
;
4682 if (!(BEGV
<= b
&& e
<= ZV
))
4683 args_out_of_range (start
, end
);
4685 if (NILP (coding_system
))
4687 /* Decide the coding-system to encode the data with.
4688 See fileio.c:Fwrite-region */
4690 if (!NILP (Vcoding_system_for_write
))
4691 coding_system
= Vcoding_system_for_write
;
4694 int force_raw_text
= 0;
4696 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4697 if (NILP (coding_system
)
4698 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4700 coding_system
= Qnil
;
4701 if (NILP (current_buffer
->enable_multibyte_characters
))
4705 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4707 /* Check file-coding-system-alist. */
4708 Lisp_Object args
[4], val
;
4710 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4711 args
[3] = Fbuffer_file_name(object
);
4712 val
= Ffind_operation_coding_system (4, args
);
4713 if (CONSP (val
) && !NILP (XCDR (val
)))
4714 coding_system
= XCDR (val
);
4717 if (NILP (coding_system
)
4718 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4720 /* If we still have not decided a coding system, use the
4721 default value of buffer-file-coding-system. */
4722 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4726 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4727 /* Confirm that VAL can surely encode the current region. */
4728 coding_system
= call4 (Vselect_safe_coding_system_function
,
4729 make_number (b
), make_number (e
),
4730 coding_system
, Qnil
);
4733 coding_system
= Qraw_text
;
4736 if (NILP (Fcoding_system_p (coding_system
)))
4738 /* Invalid coding system. */
4740 if (!NILP (noerror
))
4741 coding_system
= Qraw_text
;
4743 xsignal1 (Qcoding_system_error
, coding_system
);
4747 object
= make_buffer_string (b
, e
, 0);
4748 if (prev
!= current_buffer
)
4749 set_buffer_internal (prev
);
4750 /* Discard the unwind protect for recovering the current
4754 if (STRING_MULTIBYTE (object
))
4755 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4758 md5_buffer (SDATA (object
) + start_byte
,
4759 SBYTES (object
) - (size_byte
- end_byte
),
4762 for (i
= 0; i
< 16; i
++)
4763 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4766 return make_string (value
, 32);
4773 /* Hash table stuff. */
4774 Qhash_table_p
= intern_c_string ("hash-table-p");
4775 staticpro (&Qhash_table_p
);
4776 Qeq
= intern_c_string ("eq");
4778 Qeql
= intern_c_string ("eql");
4780 Qequal
= intern_c_string ("equal");
4781 staticpro (&Qequal
);
4782 QCtest
= intern_c_string (":test");
4783 staticpro (&QCtest
);
4784 QCsize
= intern_c_string (":size");
4785 staticpro (&QCsize
);
4786 QCrehash_size
= intern_c_string (":rehash-size");
4787 staticpro (&QCrehash_size
);
4788 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4789 staticpro (&QCrehash_threshold
);
4790 QCweakness
= intern_c_string (":weakness");
4791 staticpro (&QCweakness
);
4792 Qkey
= intern_c_string ("key");
4794 Qvalue
= intern_c_string ("value");
4795 staticpro (&Qvalue
);
4796 Qhash_table_test
= intern_c_string ("hash-table-test");
4797 staticpro (&Qhash_table_test
);
4798 Qkey_or_value
= intern_c_string ("key-or-value");
4799 staticpro (&Qkey_or_value
);
4800 Qkey_and_value
= intern_c_string ("key-and-value");
4801 staticpro (&Qkey_and_value
);
4804 defsubr (&Smake_hash_table
);
4805 defsubr (&Scopy_hash_table
);
4806 defsubr (&Shash_table_count
);
4807 defsubr (&Shash_table_rehash_size
);
4808 defsubr (&Shash_table_rehash_threshold
);
4809 defsubr (&Shash_table_size
);
4810 defsubr (&Shash_table_test
);
4811 defsubr (&Shash_table_weakness
);
4812 defsubr (&Shash_table_p
);
4813 defsubr (&Sclrhash
);
4814 defsubr (&Sgethash
);
4815 defsubr (&Sputhash
);
4816 defsubr (&Sremhash
);
4817 defsubr (&Smaphash
);
4818 defsubr (&Sdefine_hash_table_test
);
4820 Qstring_lessp
= intern_c_string ("string-lessp");
4821 staticpro (&Qstring_lessp
);
4822 Qprovide
= intern_c_string ("provide");
4823 staticpro (&Qprovide
);
4824 Qrequire
= intern_c_string ("require");
4825 staticpro (&Qrequire
);
4826 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4827 staticpro (&Qyes_or_no_p_history
);
4828 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4829 staticpro (&Qcursor_in_echo_area
);
4830 Qwidget_type
= intern_c_string ("widget-type");
4831 staticpro (&Qwidget_type
);
4833 staticpro (&string_char_byte_cache_string
);
4834 string_char_byte_cache_string
= Qnil
;
4836 require_nesting_list
= Qnil
;
4837 staticpro (&require_nesting_list
);
4839 Fset (Qyes_or_no_p_history
, Qnil
);
4841 DEFVAR_LISP ("features", &Vfeatures
,
4842 doc
: /* A list of symbols which are the features of the executing Emacs.
4843 Used by `featurep' and `require', and altered by `provide'. */);
4844 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4845 Qsubfeatures
= intern_c_string ("subfeatures");
4846 staticpro (&Qsubfeatures
);
4848 #ifdef HAVE_LANGINFO_CODESET
4849 Qcodeset
= intern_c_string ("codeset");
4850 staticpro (&Qcodeset
);
4851 Qdays
= intern_c_string ("days");
4853 Qmonths
= intern_c_string ("months");
4854 staticpro (&Qmonths
);
4855 Qpaper
= intern_c_string ("paper");
4856 staticpro (&Qpaper
);
4857 #endif /* HAVE_LANGINFO_CODESET */
4859 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4860 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4861 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4862 invoked by mouse clicks and mouse menu items.
4864 On some platforms, file selection dialogs are also enabled if this is
4868 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
4869 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4870 This applies to commands from menus and tool bar buttons even when
4871 they are initiated from the keyboard. If `use-dialog-box' is nil,
4872 that disables the use of a file dialog, regardless of the value of
4874 use_file_dialog
= 1;
4876 defsubr (&Sidentity
);
4879 defsubr (&Ssafe_length
);
4880 defsubr (&Sstring_bytes
);
4881 defsubr (&Sstring_equal
);
4882 defsubr (&Scompare_strings
);
4883 defsubr (&Sstring_lessp
);
4886 defsubr (&Svconcat
);
4887 defsubr (&Scopy_sequence
);
4888 defsubr (&Sstring_make_multibyte
);
4889 defsubr (&Sstring_make_unibyte
);
4890 defsubr (&Sstring_as_multibyte
);
4891 defsubr (&Sstring_as_unibyte
);
4892 defsubr (&Sstring_to_multibyte
);
4893 defsubr (&Sstring_to_unibyte
);
4894 defsubr (&Scopy_alist
);
4895 defsubr (&Ssubstring
);
4896 defsubr (&Ssubstring_no_properties
);
4909 defsubr (&Snreverse
);
4910 defsubr (&Sreverse
);
4912 defsubr (&Splist_get
);
4914 defsubr (&Splist_put
);
4916 defsubr (&Slax_plist_get
);
4917 defsubr (&Slax_plist_put
);
4920 defsubr (&Sequal_including_properties
);
4921 defsubr (&Sfillarray
);
4922 defsubr (&Sclear_string
);
4926 defsubr (&Smapconcat
);
4927 defsubr (&Syes_or_no_p
);
4928 defsubr (&Sload_average
);
4929 defsubr (&Sfeaturep
);
4930 defsubr (&Srequire
);
4931 defsubr (&Sprovide
);
4932 defsubr (&Splist_member
);
4933 defsubr (&Swidget_put
);
4934 defsubr (&Swidget_get
);
4935 defsubr (&Swidget_apply
);
4936 defsubr (&Sbase64_encode_region
);
4937 defsubr (&Sbase64_decode_region
);
4938 defsubr (&Sbase64_encode_string
);
4939 defsubr (&Sbase64_decode_string
);
4941 defsubr (&Slocale_info
);