1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010, 2011
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 /* Note on some machines this defines `vector' as a typedef,
29 so make sure we don't use that name in this file. */
35 #include "character.h"
40 #include "intervals.h"
43 #include "blockinput.h"
45 #if defined (HAVE_X_WINDOWS)
48 #endif /* HAVE_MENUS */
51 #define NULL ((POINTER_TYPE *)0)
54 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
55 Lisp_Object Qyes_or_no_p_history
;
56 Lisp_Object Qcursor_in_echo_area
;
57 Lisp_Object Qwidget_type
;
58 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
60 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
62 extern long get_random (void);
63 extern void seed_random (long);
69 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
70 doc
: /* Return the argument unchanged. */)
76 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
77 doc
: /* Return a pseudo-random number.
78 All integers representable in Lisp are equally likely.
79 On most systems, this is 29 bits' worth.
80 With positive integer LIMIT, return random number in interval [0,LIMIT).
81 With argument t, set the random number seed from the current time and pid.
82 Other values of LIMIT are ignored. */)
86 Lisp_Object lispy_val
;
87 unsigned long denominator
;
90 seed_random (getpid () + time (NULL
));
91 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
93 /* Try to take our random number from the higher bits of VAL,
94 not the lower, since (says Gentzel) the low bits of `random'
95 are less random than the higher ones. We do this by using the
96 quotient rather than the remainder. At the high end of the RNG
97 it's possible to get a quotient larger than n; discarding
98 these values eliminates the bias that would otherwise appear
99 when using a large n. */
100 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
102 val
= get_random () / denominator
;
103 while (val
>= XFASTINT (limit
));
107 XSETINT (lispy_val
, val
);
111 /* Random data-structure functions */
113 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
114 doc
: /* Return the length of vector, list or string SEQUENCE.
115 A byte-code function object is also allowed.
116 If the string contains multibyte characters, this is not necessarily
117 the number of bytes in the string; it is the number of characters.
118 To get the number of bytes, use `string-bytes'. */)
119 (register Lisp_Object sequence
)
121 register Lisp_Object val
;
124 if (STRINGP (sequence
))
125 XSETFASTINT (val
, SCHARS (sequence
));
126 else if (VECTORP (sequence
))
127 XSETFASTINT (val
, ASIZE (sequence
));
128 else if (CHAR_TABLE_P (sequence
))
129 XSETFASTINT (val
, MAX_CHAR
);
130 else if (BOOL_VECTOR_P (sequence
))
131 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
132 else if (COMPILEDP (sequence
))
133 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
134 else if (CONSP (sequence
))
137 while (CONSP (sequence
))
139 sequence
= XCDR (sequence
);
142 if (!CONSP (sequence
))
145 sequence
= XCDR (sequence
);
150 CHECK_LIST_END (sequence
, sequence
);
152 val
= make_number (i
);
154 else if (NILP (sequence
))
155 XSETFASTINT (val
, 0);
157 wrong_type_argument (Qsequencep
, sequence
);
162 /* This does not check for quits. That is safe since it must terminate. */
164 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
165 doc
: /* Return the length of a list, but avoid error or infinite loop.
166 This function never gets an error. If LIST is not really a list,
167 it returns 0. If LIST is circular, it returns a finite value
168 which is at least the number of distinct elements. */)
171 Lisp_Object tail
, halftail
, length
;
174 /* halftail is used to detect circular lists. */
176 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
178 if (EQ (tail
, halftail
) && len
!= 0)
182 halftail
= XCDR (halftail
);
185 XSETINT (length
, len
);
189 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
190 doc
: /* Return the number of bytes in STRING.
191 If STRING is multibyte, this may be greater than the length of STRING. */)
194 CHECK_STRING (string
);
195 return make_number (SBYTES (string
));
198 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
199 doc
: /* Return t if two strings have identical contents.
200 Case is significant, but text properties are ignored.
201 Symbols are also allowed; their print names are used instead. */)
202 (register Lisp_Object s1
, Lisp_Object s2
)
205 s1
= SYMBOL_NAME (s1
);
207 s2
= SYMBOL_NAME (s2
);
211 if (SCHARS (s1
) != SCHARS (s2
)
212 || SBYTES (s1
) != SBYTES (s2
)
213 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
218 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
219 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
220 In string STR1, skip the first START1 characters and stop at END1.
221 In string STR2, skip the first START2 characters and stop at END2.
222 END1 and END2 default to the full lengths of the respective strings.
224 Case is significant in this comparison if IGNORE-CASE is nil.
225 Unibyte strings are converted to multibyte for comparison.
227 The value is t if the strings (or specified portions) match.
228 If string STR1 is less, the value is a negative number N;
229 - 1 - N is the number of characters that match at the beginning.
230 If string STR1 is greater, the value is a positive number N;
231 N - 1 is the number of characters that match at the beginning. */)
232 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
234 register EMACS_INT end1_char
, end2_char
;
235 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
240 start1
= make_number (0);
242 start2
= make_number (0);
243 CHECK_NATNUM (start1
);
244 CHECK_NATNUM (start2
);
253 i1_byte
= string_char_to_byte (str1
, i1
);
254 i2_byte
= string_char_to_byte (str2
, i2
);
256 end1_char
= SCHARS (str1
);
257 if (! NILP (end1
) && end1_char
> XINT (end1
))
258 end1_char
= XINT (end1
);
260 end2_char
= SCHARS (str2
);
261 if (! NILP (end2
) && end2_char
> XINT (end2
))
262 end2_char
= XINT (end2
);
264 while (i1
< end1_char
&& i2
< end2_char
)
266 /* When we find a mismatch, we must compare the
267 characters, not just the bytes. */
270 if (STRING_MULTIBYTE (str1
))
271 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
274 c1
= SREF (str1
, i1
++);
275 MAKE_CHAR_MULTIBYTE (c1
);
278 if (STRING_MULTIBYTE (str2
))
279 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
282 c2
= SREF (str2
, i2
++);
283 MAKE_CHAR_MULTIBYTE (c2
);
289 if (! NILP (ignore_case
))
293 tem
= Fupcase (make_number (c1
));
295 tem
= Fupcase (make_number (c2
));
302 /* Note that I1 has already been incremented
303 past the character that we are comparing;
304 hence we don't add or subtract 1 here. */
306 return make_number (- i1
+ XINT (start1
));
308 return make_number (i1
- XINT (start1
));
312 return make_number (i1
- XINT (start1
) + 1);
314 return make_number (- i1
+ XINT (start1
) - 1);
319 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
320 doc
: /* Return t if first arg string is less than second in lexicographic order.
322 Symbols are also allowed; their print names are used instead. */)
323 (register Lisp_Object s1
, Lisp_Object s2
)
325 register EMACS_INT end
;
326 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
329 s1
= SYMBOL_NAME (s1
);
331 s2
= SYMBOL_NAME (s2
);
335 i1
= i1_byte
= i2
= i2_byte
= 0;
338 if (end
> SCHARS (s2
))
343 /* When we find a mismatch, we must compare the
344 characters, not just the bytes. */
347 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
348 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
351 return c1
< c2
? Qt
: Qnil
;
353 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
356 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
357 enum Lisp_Type target_type
, int last_special
);
361 concat2 (Lisp_Object s1
, Lisp_Object s2
)
366 return concat (2, args
, Lisp_String
, 0);
371 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
377 return concat (3, args
, Lisp_String
, 0);
380 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
381 doc
: /* Concatenate all the arguments and make the result a list.
382 The result is a list whose elements are the elements of all the arguments.
383 Each argument may be a list, vector or string.
384 The last argument is not copied, just used as the tail of the new list.
385 usage: (append &rest SEQUENCES) */)
386 (int nargs
, Lisp_Object
*args
)
388 return concat (nargs
, args
, Lisp_Cons
, 1);
391 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
392 doc
: /* Concatenate all the arguments and make the result a string.
393 The result is a string whose elements are the elements of all the arguments.
394 Each argument may be a string or a list or vector of characters (integers).
395 usage: (concat &rest SEQUENCES) */)
396 (int nargs
, Lisp_Object
*args
)
398 return concat (nargs
, args
, Lisp_String
, 0);
401 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
402 doc
: /* Concatenate all the arguments and make the result a vector.
403 The result is a vector whose elements are the elements of all the arguments.
404 Each argument may be a list, vector or string.
405 usage: (vconcat &rest SEQUENCES) */)
406 (int nargs
, Lisp_Object
*args
)
408 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
412 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
413 doc
: /* Return a copy of a list, vector, string or char-table.
414 The elements of a list or vector are not copied; they are shared
415 with the original. */)
418 if (NILP (arg
)) return arg
;
420 if (CHAR_TABLE_P (arg
))
422 return copy_char_table (arg
);
425 if (BOOL_VECTOR_P (arg
))
429 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
430 / BOOL_VECTOR_BITS_PER_CHAR
);
432 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
433 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
438 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
439 wrong_type_argument (Qsequencep
, arg
);
441 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
444 /* This structure holds information of an argument of `concat' that is
445 a string and has text properties to be copied. */
448 int argnum
; /* refer to ARGS (arguments of `concat') */
449 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
450 EMACS_INT to
; /* refer to VAL (the target string) */
454 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
457 register Lisp_Object tail
;
458 register Lisp_Object
this;
460 EMACS_INT toindex_byte
= 0;
461 register EMACS_INT result_len
;
462 register EMACS_INT result_len_byte
;
464 Lisp_Object last_tail
;
467 /* When we make a multibyte string, we can't copy text properties
468 while concatinating each string because the length of resulting
469 string can't be decided until we finish the whole concatination.
470 So, we record strings that have text properties to be copied
471 here, and copy the text properties after the concatination. */
472 struct textprop_rec
*textprops
= NULL
;
473 /* Number of elements in textprops. */
474 int num_textprops
= 0;
479 /* In append, the last arg isn't treated like the others */
480 if (last_special
&& nargs
> 0)
483 last_tail
= args
[nargs
];
488 /* Check each argument. */
489 for (argnum
= 0; argnum
< nargs
; argnum
++)
492 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
493 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
494 wrong_type_argument (Qsequencep
, this);
497 /* Compute total length in chars of arguments in RESULT_LEN.
498 If desired output is a string, also compute length in bytes
499 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
500 whether the result should be a multibyte string. */
504 for (argnum
= 0; argnum
< nargs
; argnum
++)
508 len
= XFASTINT (Flength (this));
509 if (target_type
== Lisp_String
)
511 /* We must count the number of bytes needed in the string
512 as well as the number of characters. */
515 EMACS_INT this_len_byte
;
518 for (i
= 0; i
< len
; i
++)
521 CHECK_CHARACTER (ch
);
522 this_len_byte
= CHAR_BYTES (XINT (ch
));
523 result_len_byte
+= this_len_byte
;
524 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
527 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
528 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
529 else if (CONSP (this))
530 for (; CONSP (this); this = XCDR (this))
533 CHECK_CHARACTER (ch
);
534 this_len_byte
= CHAR_BYTES (XINT (ch
));
535 result_len_byte
+= this_len_byte
;
536 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
539 else if (STRINGP (this))
541 if (STRING_MULTIBYTE (this))
544 result_len_byte
+= SBYTES (this);
547 result_len_byte
+= count_size_as_multibyte (SDATA (this),
554 error ("String overflow");
557 if (! some_multibyte
)
558 result_len_byte
= result_len
;
560 /* Create the output object. */
561 if (target_type
== Lisp_Cons
)
562 val
= Fmake_list (make_number (result_len
), Qnil
);
563 else if (target_type
== Lisp_Vectorlike
)
564 val
= Fmake_vector (make_number (result_len
), Qnil
);
565 else if (some_multibyte
)
566 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
568 val
= make_uninit_string (result_len
);
570 /* In `append', if all but last arg are nil, return last arg. */
571 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
574 /* Copy the contents of the args into the result. */
576 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
578 toindex
= 0, toindex_byte
= 0;
582 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
584 for (argnum
= 0; argnum
< nargs
; argnum
++)
587 EMACS_INT thisleni
= 0;
588 register EMACS_INT thisindex
= 0;
589 register EMACS_INT thisindex_byte
= 0;
593 thislen
= Flength (this), thisleni
= XINT (thislen
);
595 /* Between strings of the same kind, copy fast. */
596 if (STRINGP (this) && STRINGP (val
)
597 && STRING_MULTIBYTE (this) == some_multibyte
)
599 EMACS_INT thislen_byte
= SBYTES (this);
601 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
602 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
604 textprops
[num_textprops
].argnum
= argnum
;
605 textprops
[num_textprops
].from
= 0;
606 textprops
[num_textprops
++].to
= toindex
;
608 toindex_byte
+= thislen_byte
;
611 /* Copy a single-byte string to a multibyte string. */
612 else if (STRINGP (this) && STRINGP (val
))
614 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
616 textprops
[num_textprops
].argnum
= argnum
;
617 textprops
[num_textprops
].from
= 0;
618 textprops
[num_textprops
++].to
= toindex
;
620 toindex_byte
+= copy_text (SDATA (this),
621 SDATA (val
) + toindex_byte
,
622 SCHARS (this), 0, 1);
626 /* Copy element by element. */
629 register Lisp_Object elt
;
631 /* Fetch next element of `this' arg into `elt', or break if
632 `this' is exhausted. */
633 if (NILP (this)) break;
635 elt
= XCAR (this), this = XCDR (this);
636 else if (thisindex
>= thisleni
)
638 else if (STRINGP (this))
641 if (STRING_MULTIBYTE (this))
643 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
646 XSETFASTINT (elt
, c
);
650 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
652 && !ASCII_CHAR_P (XINT (elt
))
653 && XINT (elt
) < 0400)
655 c
= BYTE8_TO_CHAR (XINT (elt
));
660 else if (BOOL_VECTOR_P (this))
663 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
664 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
672 elt
= AREF (this, thisindex
);
676 /* Store this element into the result. */
683 else if (VECTORP (val
))
685 ASET (val
, toindex
, elt
);
692 toindex_byte
+= CHAR_STRING (XINT (elt
),
693 SDATA (val
) + toindex_byte
);
695 SSET (val
, toindex_byte
++, XINT (elt
));
701 XSETCDR (prev
, last_tail
);
703 if (num_textprops
> 0)
706 EMACS_INT last_to_end
= -1;
708 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
710 this = args
[textprops
[argnum
].argnum
];
711 props
= text_property_list (this,
713 make_number (SCHARS (this)),
715 /* If successive arguments have properites, be sure that the
716 value of `composition' property be the copy. */
717 if (last_to_end
== textprops
[argnum
].to
)
718 make_composition_value_copy (props
);
719 add_text_properties_from_list (val
, props
,
720 make_number (textprops
[argnum
].to
));
721 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
729 static Lisp_Object string_char_byte_cache_string
;
730 static EMACS_INT string_char_byte_cache_charpos
;
731 static EMACS_INT string_char_byte_cache_bytepos
;
734 clear_string_char_byte_cache (void)
736 string_char_byte_cache_string
= Qnil
;
739 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
742 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
745 EMACS_INT best_below
, best_below_byte
;
746 EMACS_INT best_above
, best_above_byte
;
748 best_below
= best_below_byte
= 0;
749 best_above
= SCHARS (string
);
750 best_above_byte
= SBYTES (string
);
751 if (best_above
== best_above_byte
)
754 if (EQ (string
, string_char_byte_cache_string
))
756 if (string_char_byte_cache_charpos
< char_index
)
758 best_below
= string_char_byte_cache_charpos
;
759 best_below_byte
= string_char_byte_cache_bytepos
;
763 best_above
= string_char_byte_cache_charpos
;
764 best_above_byte
= string_char_byte_cache_bytepos
;
768 if (char_index
- best_below
< best_above
- char_index
)
770 unsigned char *p
= SDATA (string
) + best_below_byte
;
772 while (best_below
< char_index
)
774 p
+= BYTES_BY_CHAR_HEAD (*p
);
777 i_byte
= p
- SDATA (string
);
781 unsigned char *p
= SDATA (string
) + best_above_byte
;
783 while (best_above
> char_index
)
786 while (!CHAR_HEAD_P (*p
)) p
--;
789 i_byte
= p
- SDATA (string
);
792 string_char_byte_cache_bytepos
= i_byte
;
793 string_char_byte_cache_charpos
= char_index
;
794 string_char_byte_cache_string
= string
;
799 /* Return the character index corresponding to BYTE_INDEX in STRING. */
802 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
805 EMACS_INT best_below
, best_below_byte
;
806 EMACS_INT best_above
, best_above_byte
;
808 best_below
= best_below_byte
= 0;
809 best_above
= SCHARS (string
);
810 best_above_byte
= SBYTES (string
);
811 if (best_above
== best_above_byte
)
814 if (EQ (string
, string_char_byte_cache_string
))
816 if (string_char_byte_cache_bytepos
< byte_index
)
818 best_below
= string_char_byte_cache_charpos
;
819 best_below_byte
= string_char_byte_cache_bytepos
;
823 best_above
= string_char_byte_cache_charpos
;
824 best_above_byte
= string_char_byte_cache_bytepos
;
828 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
830 unsigned char *p
= SDATA (string
) + best_below_byte
;
831 unsigned char *pend
= SDATA (string
) + byte_index
;
835 p
+= BYTES_BY_CHAR_HEAD (*p
);
839 i_byte
= p
- SDATA (string
);
843 unsigned char *p
= SDATA (string
) + best_above_byte
;
844 unsigned char *pbeg
= SDATA (string
) + byte_index
;
849 while (!CHAR_HEAD_P (*p
)) p
--;
853 i_byte
= p
- SDATA (string
);
856 string_char_byte_cache_bytepos
= i_byte
;
857 string_char_byte_cache_charpos
= i
;
858 string_char_byte_cache_string
= string
;
863 /* Convert STRING to a multibyte string. */
866 string_make_multibyte (Lisp_Object string
)
873 if (STRING_MULTIBYTE (string
))
876 nbytes
= count_size_as_multibyte (SDATA (string
),
878 /* If all the chars are ASCII, they won't need any more bytes
879 once converted. In that case, we can return STRING itself. */
880 if (nbytes
== SBYTES (string
))
883 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
884 copy_text (SDATA (string
), buf
, SBYTES (string
),
887 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
894 /* Convert STRING (if unibyte) to a multibyte string without changing
895 the number of characters. Characters 0200 trough 0237 are
896 converted to eight-bit characters. */
899 string_to_multibyte (Lisp_Object string
)
906 if (STRING_MULTIBYTE (string
))
909 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
910 /* If all the chars are ASCII, they won't need any more bytes once
912 if (nbytes
== SBYTES (string
))
913 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
915 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
916 memcpy (buf
, SDATA (string
), SBYTES (string
));
917 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
919 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
926 /* Convert STRING to a single-byte string. */
929 string_make_unibyte (Lisp_Object string
)
936 if (! STRING_MULTIBYTE (string
))
939 nchars
= SCHARS (string
);
941 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
942 copy_text (SDATA (string
), buf
, SBYTES (string
),
945 ret
= make_unibyte_string (buf
, nchars
);
951 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
953 doc
: /* Return the multibyte equivalent of STRING.
954 If STRING is unibyte and contains non-ASCII characters, the function
955 `unibyte-char-to-multibyte' is used to convert each unibyte character
956 to a multibyte character. In this case, the returned string is a
957 newly created string with no text properties. If STRING is multibyte
958 or entirely ASCII, it is returned unchanged. In particular, when
959 STRING is unibyte and entirely ASCII, the returned string is unibyte.
960 \(When the characters are all ASCII, Emacs primitives will treat the
961 string the same way whether it is unibyte or multibyte.) */)
964 CHECK_STRING (string
);
966 return string_make_multibyte (string
);
969 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
971 doc
: /* Return the unibyte equivalent of STRING.
972 Multibyte character codes are converted to unibyte according to
973 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
974 If the lookup in the translation table fails, this function takes just
975 the low 8 bits of each character. */)
978 CHECK_STRING (string
);
980 return string_make_unibyte (string
);
983 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
985 doc
: /* Return a unibyte string with the same individual bytes as STRING.
986 If STRING is unibyte, the result is STRING itself.
987 Otherwise it is a newly created string, with no text properties.
988 If STRING is multibyte and contains a character of charset
989 `eight-bit', it is converted to the corresponding single byte. */)
992 CHECK_STRING (string
);
994 if (STRING_MULTIBYTE (string
))
996 EMACS_INT bytes
= SBYTES (string
);
997 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
999 memcpy (str
, SDATA (string
), bytes
);
1000 bytes
= str_as_unibyte (str
, bytes
);
1001 string
= make_unibyte_string (str
, bytes
);
1007 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1009 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1010 If STRING is multibyte, the result is STRING itself.
1011 Otherwise it is a newly created string, with no text properties.
1013 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1014 part of a correct utf-8 sequence), it is converted to the corresponding
1015 multibyte character of charset `eight-bit'.
1016 See also `string-to-multibyte'.
1018 Beware, this often doesn't really do what you think it does.
1019 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1020 If you're not sure, whether to use `string-as-multibyte' or
1021 `string-to-multibyte', use `string-to-multibyte'. */)
1022 (Lisp_Object string
)
1024 CHECK_STRING (string
);
1026 if (! STRING_MULTIBYTE (string
))
1028 Lisp_Object new_string
;
1029 EMACS_INT nchars
, nbytes
;
1031 parse_str_as_multibyte (SDATA (string
),
1034 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1035 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1036 if (nbytes
!= SBYTES (string
))
1037 str_as_multibyte (SDATA (new_string
), nbytes
,
1038 SBYTES (string
), NULL
);
1039 string
= new_string
;
1040 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1045 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1047 doc
: /* Return a multibyte string with the same individual chars as STRING.
1048 If STRING is multibyte, the result is STRING itself.
1049 Otherwise it is a newly created string, with no text properties.
1051 If STRING is unibyte and contains an 8-bit byte, it is converted to
1052 the corresponding multibyte character of charset `eight-bit'.
1054 This differs from `string-as-multibyte' by converting each byte of a correct
1055 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1056 correct sequence. */)
1057 (Lisp_Object string
)
1059 CHECK_STRING (string
);
1061 return string_to_multibyte (string
);
1064 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1066 doc
: /* Return a unibyte string with the same individual chars as STRING.
1067 If STRING is unibyte, the result is STRING itself.
1068 Otherwise it is a newly created string, with no text properties,
1069 where each `eight-bit' character is converted to the corresponding byte.
1070 If STRING contains a non-ASCII, non-`eight-bit' character,
1071 an error is signaled. */)
1072 (Lisp_Object string
)
1074 CHECK_STRING (string
);
1076 if (STRING_MULTIBYTE (string
))
1078 EMACS_INT chars
= SCHARS (string
);
1079 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1080 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1082 if (converted
< chars
)
1083 error ("Can't convert the %dth character to unibyte", converted
);
1084 string
= make_unibyte_string (str
, chars
);
1091 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1092 doc
: /* Return a copy of ALIST.
1093 This is an alist which represents the same mapping from objects to objects,
1094 but does not share the alist structure with ALIST.
1095 The objects mapped (cars and cdrs of elements of the alist)
1096 are shared, however.
1097 Elements of ALIST that are not conses are also shared. */)
1100 register Lisp_Object tem
;
1105 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1106 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1108 register Lisp_Object car
;
1112 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1117 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1118 doc
: /* Return a new string whose contents are a substring of STRING.
1119 The returned string consists of the characters between index FROM
1120 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1121 zero-indexed: 0 means the first character of STRING. Negative values
1122 are counted from the end of STRING. If TO is nil, the substring runs
1123 to the end of STRING.
1125 The STRING argument may also be a vector. In that case, the return
1126 value is a new vector that contains the elements between index FROM
1127 \(inclusive) and index TO (exclusive) of that vector argument. */)
1128 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1132 EMACS_INT size_byte
= 0;
1133 EMACS_INT from_char
, to_char
;
1134 EMACS_INT from_byte
= 0, to_byte
= 0;
1136 CHECK_VECTOR_OR_STRING (string
);
1137 CHECK_NUMBER (from
);
1139 if (STRINGP (string
))
1141 size
= SCHARS (string
);
1142 size_byte
= SBYTES (string
);
1145 size
= ASIZE (string
);
1150 to_byte
= size_byte
;
1156 to_char
= XINT (to
);
1160 if (STRINGP (string
))
1161 to_byte
= string_char_to_byte (string
, to_char
);
1164 from_char
= XINT (from
);
1167 if (STRINGP (string
))
1168 from_byte
= string_char_to_byte (string
, from_char
);
1170 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1171 args_out_of_range_3 (string
, make_number (from_char
),
1172 make_number (to_char
));
1174 if (STRINGP (string
))
1176 res
= make_specified_string (SDATA (string
) + from_byte
,
1177 to_char
- from_char
, to_byte
- from_byte
,
1178 STRING_MULTIBYTE (string
));
1179 copy_text_properties (make_number (from_char
), make_number (to_char
),
1180 string
, make_number (0), res
, Qnil
);
1183 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1189 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1190 doc
: /* Return a substring of STRING, without text properties.
1191 It starts at index FROM and ends before TO.
1192 TO may be nil or omitted; then the substring runs to the end of STRING.
1193 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1194 If FROM or TO is negative, it counts from the end.
1196 With one argument, just copy STRING without its properties. */)
1197 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1199 EMACS_INT size
, size_byte
;
1200 EMACS_INT from_char
, to_char
;
1201 EMACS_INT from_byte
, to_byte
;
1203 CHECK_STRING (string
);
1205 size
= SCHARS (string
);
1206 size_byte
= SBYTES (string
);
1209 from_char
= from_byte
= 0;
1212 CHECK_NUMBER (from
);
1213 from_char
= XINT (from
);
1217 from_byte
= string_char_to_byte (string
, from_char
);
1223 to_byte
= size_byte
;
1229 to_char
= XINT (to
);
1233 to_byte
= string_char_to_byte (string
, to_char
);
1236 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1237 args_out_of_range_3 (string
, make_number (from_char
),
1238 make_number (to_char
));
1240 return make_specified_string (SDATA (string
) + from_byte
,
1241 to_char
- from_char
, to_byte
- from_byte
,
1242 STRING_MULTIBYTE (string
));
1245 /* Extract a substring of STRING, giving start and end positions
1246 both in characters and in bytes. */
1249 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1250 EMACS_INT to
, EMACS_INT to_byte
)
1254 EMACS_INT size_byte
;
1256 CHECK_VECTOR_OR_STRING (string
);
1258 if (STRINGP (string
))
1260 size
= SCHARS (string
);
1261 size_byte
= SBYTES (string
);
1264 size
= ASIZE (string
);
1266 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1267 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1269 if (STRINGP (string
))
1271 res
= make_specified_string (SDATA (string
) + from_byte
,
1272 to
- from
, to_byte
- from_byte
,
1273 STRING_MULTIBYTE (string
));
1274 copy_text_properties (make_number (from
), make_number (to
),
1275 string
, make_number (0), res
, Qnil
);
1278 res
= Fvector (to
- from
, &AREF (string
, from
));
1283 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1284 doc
: /* Take cdr N times on LIST, return the result. */)
1285 (Lisp_Object n
, Lisp_Object list
)
1287 register int i
, num
;
1290 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1293 CHECK_LIST_CONS (list
, list
);
1299 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1300 doc
: /* Return the Nth element of LIST.
1301 N counts from zero. If LIST is not that long, nil is returned. */)
1302 (Lisp_Object n
, Lisp_Object list
)
1304 return Fcar (Fnthcdr (n
, list
));
1307 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1308 doc
: /* Return element of SEQUENCE at index N. */)
1309 (register Lisp_Object sequence
, Lisp_Object n
)
1312 if (CONSP (sequence
) || NILP (sequence
))
1313 return Fcar (Fnthcdr (n
, sequence
));
1315 /* Faref signals a "not array" error, so check here. */
1316 CHECK_ARRAY (sequence
, Qsequencep
);
1317 return Faref (sequence
, n
);
1320 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1321 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1322 The value is actually the tail of LIST whose car is ELT. */)
1323 (register Lisp_Object elt
, Lisp_Object list
)
1325 register Lisp_Object tail
;
1326 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1328 register Lisp_Object tem
;
1329 CHECK_LIST_CONS (tail
, list
);
1331 if (! NILP (Fequal (elt
, tem
)))
1338 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1339 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1340 The value is actually the tail of LIST whose car is ELT. */)
1341 (register Lisp_Object elt
, Lisp_Object list
)
1345 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1349 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1353 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1364 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1365 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1366 The value is actually the tail of LIST whose car is ELT. */)
1367 (register Lisp_Object elt
, Lisp_Object list
)
1369 register Lisp_Object tail
;
1372 return Fmemq (elt
, list
);
1374 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1376 register Lisp_Object tem
;
1377 CHECK_LIST_CONS (tail
, list
);
1379 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1386 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1387 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1388 The value is actually the first element of LIST whose car is KEY.
1389 Elements of LIST that are not conses are ignored. */)
1390 (Lisp_Object key
, Lisp_Object list
)
1395 || (CONSP (XCAR (list
))
1396 && EQ (XCAR (XCAR (list
)), key
)))
1401 || (CONSP (XCAR (list
))
1402 && EQ (XCAR (XCAR (list
)), key
)))
1407 || (CONSP (XCAR (list
))
1408 && EQ (XCAR (XCAR (list
)), key
)))
1418 /* Like Fassq but never report an error and do not allow quits.
1419 Use only on lists known never to be circular. */
1422 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1425 && (!CONSP (XCAR (list
))
1426 || !EQ (XCAR (XCAR (list
)), key
)))
1429 return CAR_SAFE (list
);
1432 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1433 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1434 The value is actually the first element of LIST whose car equals KEY. */)
1435 (Lisp_Object key
, Lisp_Object list
)
1442 || (CONSP (XCAR (list
))
1443 && (car
= XCAR (XCAR (list
)),
1444 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1449 || (CONSP (XCAR (list
))
1450 && (car
= XCAR (XCAR (list
)),
1451 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1456 || (CONSP (XCAR (list
))
1457 && (car
= XCAR (XCAR (list
)),
1458 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1468 /* Like Fassoc but never report an error and do not allow quits.
1469 Use only on lists known never to be circular. */
1472 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1475 && (!CONSP (XCAR (list
))
1476 || (!EQ (XCAR (XCAR (list
)), key
)
1477 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1480 return CONSP (list
) ? XCAR (list
) : Qnil
;
1483 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1484 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1485 The value is actually the first element of LIST whose cdr is KEY. */)
1486 (register Lisp_Object key
, Lisp_Object list
)
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCDR (XCAR (list
)), key
)))
1497 || (CONSP (XCAR (list
))
1498 && EQ (XCDR (XCAR (list
)), key
)))
1503 || (CONSP (XCAR (list
))
1504 && EQ (XCDR (XCAR (list
)), key
)))
1514 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1515 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1516 The value is actually the first element of LIST whose cdr equals KEY. */)
1517 (Lisp_Object key
, Lisp_Object list
)
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1531 || (CONSP (XCAR (list
))
1532 && (cdr
= XCDR (XCAR (list
)),
1533 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1538 || (CONSP (XCAR (list
))
1539 && (cdr
= XCDR (XCAR (list
)),
1540 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1550 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1551 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1552 The modified LIST is returned. Comparison is done with `eq'.
1553 If the first member of LIST is ELT, there is no way to remove it by side effect;
1554 therefore, write `(setq foo (delq element foo))'
1555 to be sure of changing the value of `foo'. */)
1556 (register Lisp_Object elt
, Lisp_Object list
)
1558 register Lisp_Object tail
, prev
;
1559 register Lisp_Object tem
;
1563 while (!NILP (tail
))
1565 CHECK_LIST_CONS (tail
, list
);
1572 Fsetcdr (prev
, XCDR (tail
));
1582 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1583 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1584 SEQ must be a list, a vector, or a string.
1585 The modified SEQ is returned. Comparison is done with `equal'.
1586 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1587 is not a side effect; it is simply using a different sequence.
1588 Therefore, write `(setq foo (delete element foo))'
1589 to be sure of changing the value of `foo'. */)
1590 (Lisp_Object elt
, Lisp_Object seq
)
1596 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1597 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1600 if (n
!= ASIZE (seq
))
1602 struct Lisp_Vector
*p
= allocate_vector (n
);
1604 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1605 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1606 p
->contents
[n
++] = AREF (seq
, i
);
1608 XSETVECTOR (seq
, p
);
1611 else if (STRINGP (seq
))
1613 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1616 for (i
= nchars
= nbytes
= ibyte
= 0;
1618 ++i
, ibyte
+= cbytes
)
1620 if (STRING_MULTIBYTE (seq
))
1622 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1623 cbytes
= CHAR_BYTES (c
);
1631 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1638 if (nchars
!= SCHARS (seq
))
1642 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1643 if (!STRING_MULTIBYTE (seq
))
1644 STRING_SET_UNIBYTE (tem
);
1646 for (i
= nchars
= nbytes
= ibyte
= 0;
1648 ++i
, ibyte
+= cbytes
)
1650 if (STRING_MULTIBYTE (seq
))
1652 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1653 cbytes
= CHAR_BYTES (c
);
1661 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1663 unsigned char *from
= SDATA (seq
) + ibyte
;
1664 unsigned char *to
= SDATA (tem
) + nbytes
;
1670 for (n
= cbytes
; n
--; )
1680 Lisp_Object tail
, prev
;
1682 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1684 CHECK_LIST_CONS (tail
, seq
);
1686 if (!NILP (Fequal (elt
, XCAR (tail
))))
1691 Fsetcdr (prev
, XCDR (tail
));
1702 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1703 doc
: /* Reverse LIST by modifying cdr pointers.
1704 Return the reversed list. */)
1707 register Lisp_Object prev
, tail
, next
;
1709 if (NILP (list
)) return list
;
1712 while (!NILP (tail
))
1715 CHECK_LIST_CONS (tail
, list
);
1717 Fsetcdr (tail
, prev
);
1724 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1725 doc
: /* Reverse LIST, copying. Return the reversed list.
1726 See also the function `nreverse', which is used more often. */)
1731 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1734 new = Fcons (XCAR (list
), new);
1736 CHECK_LIST_END (list
, list
);
1740 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1742 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1743 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1744 Returns the sorted list. LIST is modified by side effects.
1745 PREDICATE is called with two elements of LIST, and should return non-nil
1746 if the first element should sort before the second. */)
1747 (Lisp_Object list
, Lisp_Object predicate
)
1749 Lisp_Object front
, back
;
1750 register Lisp_Object len
, tem
;
1751 struct gcpro gcpro1
, gcpro2
;
1752 register int length
;
1755 len
= Flength (list
);
1756 length
= XINT (len
);
1760 XSETINT (len
, (length
/ 2) - 1);
1761 tem
= Fnthcdr (len
, list
);
1763 Fsetcdr (tem
, Qnil
);
1765 GCPRO2 (front
, back
);
1766 front
= Fsort (front
, predicate
);
1767 back
= Fsort (back
, predicate
);
1769 return merge (front
, back
, predicate
);
1773 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1776 register Lisp_Object tail
;
1778 register Lisp_Object l1
, l2
;
1779 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1786 /* It is sufficient to protect org_l1 and org_l2.
1787 When l1 and l2 are updated, we copy the new values
1788 back into the org_ vars. */
1789 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1809 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1825 Fsetcdr (tail
, tem
);
1831 /* This does not check for quits. That is safe since it must terminate. */
1833 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1834 doc
: /* Extract a value from a property list.
1835 PLIST is a property list, which is a list of the form
1836 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1837 corresponding to the given PROP, or nil if PROP is not one of the
1838 properties on the list. This function never signals an error. */)
1839 (Lisp_Object plist
, Lisp_Object prop
)
1841 Lisp_Object tail
, halftail
;
1843 /* halftail is used to detect circular lists. */
1844 tail
= halftail
= plist
;
1845 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1847 if (EQ (prop
, XCAR (tail
)))
1848 return XCAR (XCDR (tail
));
1850 tail
= XCDR (XCDR (tail
));
1851 halftail
= XCDR (halftail
);
1852 if (EQ (tail
, halftail
))
1855 #if 0 /* Unsafe version. */
1856 /* This function can be called asynchronously
1857 (setup_coding_system). Don't QUIT in that case. */
1858 if (!interrupt_input_blocked
)
1866 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1867 doc
: /* Return the value of SYMBOL's PROPNAME property.
1868 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1869 (Lisp_Object symbol
, Lisp_Object propname
)
1871 CHECK_SYMBOL (symbol
);
1872 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1875 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1876 doc
: /* Change value in PLIST of PROP to VAL.
1877 PLIST is a property list, which is a list of the form
1878 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1879 If PROP is already a property on the list, its value is set to VAL,
1880 otherwise the new PROP VAL pair is added. The new plist is returned;
1881 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1882 The PLIST is modified by side effects. */)
1883 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1885 register Lisp_Object tail
, prev
;
1886 Lisp_Object newcell
;
1888 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1889 tail
= XCDR (XCDR (tail
)))
1891 if (EQ (prop
, XCAR (tail
)))
1893 Fsetcar (XCDR (tail
), val
);
1900 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1904 Fsetcdr (XCDR (prev
), newcell
);
1908 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1909 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1910 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1911 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1913 CHECK_SYMBOL (symbol
);
1914 XSYMBOL (symbol
)->plist
1915 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1919 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1920 doc
: /* Extract a value from a property list, comparing with `equal'.
1921 PLIST is a property list, which is a list of the form
1922 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1923 corresponding to the given PROP, or nil if PROP is not
1924 one of the properties on the list. */)
1925 (Lisp_Object plist
, Lisp_Object prop
)
1930 CONSP (tail
) && CONSP (XCDR (tail
));
1931 tail
= XCDR (XCDR (tail
)))
1933 if (! NILP (Fequal (prop
, XCAR (tail
))))
1934 return XCAR (XCDR (tail
));
1939 CHECK_LIST_END (tail
, prop
);
1944 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1945 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1946 PLIST is a property list, which is a list of the form
1947 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1948 If PROP is already a property on the list, its value is set to VAL,
1949 otherwise the new PROP VAL pair is added. The new plist is returned;
1950 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1951 The PLIST is modified by side effects. */)
1952 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1954 register Lisp_Object tail
, prev
;
1955 Lisp_Object newcell
;
1957 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1958 tail
= XCDR (XCDR (tail
)))
1960 if (! NILP (Fequal (prop
, XCAR (tail
))))
1962 Fsetcar (XCDR (tail
), val
);
1969 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1973 Fsetcdr (XCDR (prev
), newcell
);
1977 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1978 doc
: /* Return t if the two args are the same Lisp object.
1979 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1980 (Lisp_Object obj1
, Lisp_Object obj2
)
1983 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1985 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1988 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1989 doc
: /* Return t if two Lisp objects have similar structure and contents.
1990 They must have the same data type.
1991 Conses are compared by comparing the cars and the cdrs.
1992 Vectors and strings are compared element by element.
1993 Numbers are compared by value, but integers cannot equal floats.
1994 (Use `=' if you want integers and floats to be able to be equal.)
1995 Symbols must match exactly. */)
1996 (register Lisp_Object o1
, Lisp_Object o2
)
1998 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2001 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2002 doc
: /* Return t if two Lisp objects have similar structure and contents.
2003 This is like `equal' except that it compares the text properties
2004 of strings. (`equal' ignores text properties.) */)
2005 (register Lisp_Object o1
, Lisp_Object o2
)
2007 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2010 /* DEPTH is current depth of recursion. Signal an error if it
2012 PROPS, if non-nil, means compare string text properties too. */
2015 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2018 error ("Stack overflow in equal");
2024 if (XTYPE (o1
) != XTYPE (o2
))
2033 d1
= extract_float (o1
);
2034 d2
= extract_float (o2
);
2035 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2036 though they are not =. */
2037 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2041 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2048 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2052 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2054 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2057 o1
= XOVERLAY (o1
)->plist
;
2058 o2
= XOVERLAY (o2
)->plist
;
2063 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2064 && (XMARKER (o1
)->buffer
== 0
2065 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2069 case Lisp_Vectorlike
:
2072 EMACS_INT size
= ASIZE (o1
);
2073 /* Pseudovectors have the type encoded in the size field, so this test
2074 actually checks that the objects have the same type as well as the
2076 if (ASIZE (o2
) != size
)
2078 /* Boolvectors are compared much like strings. */
2079 if (BOOL_VECTOR_P (o1
))
2082 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2083 / BOOL_VECTOR_BITS_PER_CHAR
);
2085 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2087 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2092 if (WINDOW_CONFIGURATIONP (o1
))
2093 return compare_window_configurations (o1
, o2
, 0);
2095 /* Aside from them, only true vectors, char-tables, compiled
2096 functions, and fonts (font-spec, font-entity, font-ojbect)
2097 are sensible to compare, so eliminate the others now. */
2098 if (size
& PSEUDOVECTOR_FLAG
)
2100 if (!(size
& (PVEC_COMPILED
2101 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2103 size
&= PSEUDOVECTOR_SIZE_MASK
;
2105 for (i
= 0; i
< size
; i
++)
2110 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2118 if (SCHARS (o1
) != SCHARS (o2
))
2120 if (SBYTES (o1
) != SBYTES (o2
))
2122 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2124 if (props
&& !compare_string_intervals (o1
, o2
))
2136 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2137 doc
: /* Store each element of ARRAY with ITEM.
2138 ARRAY is a vector, string, char-table, or bool-vector. */)
2139 (Lisp_Object array
, Lisp_Object item
)
2141 register EMACS_INT size
, index
;
2144 if (VECTORP (array
))
2146 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2147 size
= ASIZE (array
);
2148 for (index
= 0; index
< size
; index
++)
2151 else if (CHAR_TABLE_P (array
))
2155 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2156 XCHAR_TABLE (array
)->contents
[i
] = item
;
2157 XCHAR_TABLE (array
)->defalt
= item
;
2159 else if (STRINGP (array
))
2161 register unsigned char *p
= SDATA (array
);
2162 CHECK_NUMBER (item
);
2163 charval
= XINT (item
);
2164 size
= SCHARS (array
);
2165 if (STRING_MULTIBYTE (array
))
2167 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2168 int len
= CHAR_STRING (charval
, str
);
2169 EMACS_INT size_byte
= SBYTES (array
);
2170 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2173 if (size
!= size_byte
)
2176 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2177 if (len
!= this_len
)
2178 error ("Attempt to change byte length of a string");
2181 for (i
= 0; i
< size_byte
; i
++)
2182 *p
++ = str
[i
% len
];
2185 for (index
= 0; index
< size
; index
++)
2188 else if (BOOL_VECTOR_P (array
))
2190 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2192 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2193 / BOOL_VECTOR_BITS_PER_CHAR
);
2195 charval
= (! NILP (item
) ? -1 : 0);
2196 for (index
= 0; index
< size_in_chars
- 1; index
++)
2198 if (index
< size_in_chars
)
2200 /* Mask out bits beyond the vector size. */
2201 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2202 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2207 wrong_type_argument (Qarrayp
, array
);
2211 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2213 doc
: /* Clear the contents of STRING.
2214 This makes STRING unibyte and may change its length. */)
2215 (Lisp_Object string
)
2218 CHECK_STRING (string
);
2219 len
= SBYTES (string
);
2220 memset (SDATA (string
), 0, len
);
2221 STRING_SET_CHARS (string
, len
);
2222 STRING_SET_UNIBYTE (string
);
2228 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2230 Lisp_Object args
[2];
2233 return Fnconc (2, args
);
2236 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2237 doc
: /* Concatenate any number of lists by altering them.
2238 Only the last argument is not altered, and need not be a list.
2239 usage: (nconc &rest LISTS) */)
2240 (int nargs
, Lisp_Object
*args
)
2242 register int argnum
;
2243 register Lisp_Object tail
, tem
, val
;
2247 for (argnum
= 0; argnum
< nargs
; argnum
++)
2250 if (NILP (tem
)) continue;
2255 if (argnum
+ 1 == nargs
) break;
2257 CHECK_LIST_CONS (tem
, tem
);
2266 tem
= args
[argnum
+ 1];
2267 Fsetcdr (tail
, tem
);
2269 args
[argnum
+ 1] = tail
;
2275 /* This is the guts of all mapping functions.
2276 Apply FN to each element of SEQ, one by one,
2277 storing the results into elements of VALS, a C vector of Lisp_Objects.
2278 LENI is the length of VALS, which should also be the length of SEQ. */
2281 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2283 register Lisp_Object tail
;
2285 register EMACS_INT i
;
2286 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2290 /* Don't let vals contain any garbage when GC happens. */
2291 for (i
= 0; i
< leni
; i
++)
2294 GCPRO3 (dummy
, fn
, seq
);
2296 gcpro1
.nvars
= leni
;
2300 /* We need not explicitly protect `tail' because it is used only on lists, and
2301 1) lists are not relocated and 2) the list is marked via `seq' so will not
2306 for (i
= 0; i
< leni
; i
++)
2308 dummy
= call1 (fn
, AREF (seq
, i
));
2313 else if (BOOL_VECTOR_P (seq
))
2315 for (i
= 0; i
< leni
; i
++)
2318 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2319 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2320 dummy
= call1 (fn
, dummy
);
2325 else if (STRINGP (seq
))
2329 for (i
= 0, i_byte
= 0; i
< leni
;)
2332 EMACS_INT i_before
= i
;
2334 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2335 XSETFASTINT (dummy
, c
);
2336 dummy
= call1 (fn
, dummy
);
2338 vals
[i_before
] = dummy
;
2341 else /* Must be a list, since Flength did not get an error */
2344 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2346 dummy
= call1 (fn
, XCAR (tail
));
2356 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2357 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2358 In between each pair of results, stick in SEPARATOR. Thus, " " as
2359 SEPARATOR results in spaces between the values returned by FUNCTION.
2360 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2361 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2364 register EMACS_INT leni
;
2366 register Lisp_Object
*args
;
2367 register EMACS_INT i
;
2368 struct gcpro gcpro1
;
2372 len
= Flength (sequence
);
2373 if (CHAR_TABLE_P (sequence
))
2374 wrong_type_argument (Qlistp
, sequence
);
2376 nargs
= leni
+ leni
- 1;
2377 if (nargs
< 0) return empty_unibyte_string
;
2379 SAFE_ALLOCA_LISP (args
, nargs
);
2382 mapcar1 (leni
, args
, function
, sequence
);
2385 for (i
= leni
- 1; i
> 0; i
--)
2386 args
[i
+ i
] = args
[i
];
2388 for (i
= 1; i
< nargs
; i
+= 2)
2389 args
[i
] = separator
;
2391 ret
= Fconcat (nargs
, args
);
2397 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2398 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2399 The result is a list just as long as SEQUENCE.
2400 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2401 (Lisp_Object function
, Lisp_Object sequence
)
2403 register Lisp_Object len
;
2404 register EMACS_INT leni
;
2405 register Lisp_Object
*args
;
2409 len
= Flength (sequence
);
2410 if (CHAR_TABLE_P (sequence
))
2411 wrong_type_argument (Qlistp
, sequence
);
2412 leni
= XFASTINT (len
);
2414 SAFE_ALLOCA_LISP (args
, leni
);
2416 mapcar1 (leni
, args
, function
, sequence
);
2418 ret
= Flist (leni
, args
);
2424 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2425 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2426 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2427 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2428 (Lisp_Object function
, Lisp_Object sequence
)
2430 register EMACS_INT leni
;
2432 leni
= XFASTINT (Flength (sequence
));
2433 if (CHAR_TABLE_P (sequence
))
2434 wrong_type_argument (Qlistp
, sequence
);
2435 mapcar1 (leni
, 0, function
, sequence
);
2440 /* This is how C code calls `yes-or-no-p' and allows the user
2443 Anything that calls this function must protect from GC! */
2446 do_yes_or_no_p (Lisp_Object prompt
)
2448 return call1 (intern ("yes-or-no-p"), prompt
);
2451 /* Anything that calls this function must protect from GC! */
2453 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2454 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2455 PROMPT is the string to display to ask the question. It should end in
2456 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2458 The user must confirm the answer with RET, and can edit it until it
2461 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2462 is nil, and `use-dialog-box' is non-nil. */)
2463 (Lisp_Object prompt
)
2465 register Lisp_Object ans
;
2466 Lisp_Object args
[2];
2467 struct gcpro gcpro1
;
2469 CHECK_STRING (prompt
);
2472 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2473 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2477 Lisp_Object pane
, menu
, obj
;
2478 redisplay_preserve_echo_area (4);
2479 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2480 Fcons (Fcons (build_string ("No"), Qnil
),
2483 menu
= Fcons (prompt
, pane
);
2484 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2488 #endif /* HAVE_MENUS */
2491 args
[1] = build_string ("(yes or no) ");
2492 prompt
= Fconcat (2, args
);
2498 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2499 Qyes_or_no_p_history
, Qnil
,
2501 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2506 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2514 message ("Please answer yes or no.");
2515 Fsleep_for (make_number (2), Qnil
);
2519 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2520 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2522 Each of the three load averages is multiplied by 100, then converted
2525 When USE-FLOATS is non-nil, floats will be used instead of integers.
2526 These floats are not multiplied by 100.
2528 If the 5-minute or 15-minute load averages are not available, return a
2529 shortened list, containing only those averages which are available.
2531 An error is thrown if the load average can't be obtained. In some
2532 cases making it work would require Emacs being installed setuid or
2533 setgid so that it can read kernel information, and that usually isn't
2535 (Lisp_Object use_floats
)
2538 int loads
= getloadavg (load_ave
, 3);
2539 Lisp_Object ret
= Qnil
;
2542 error ("load-average not implemented for this operating system");
2546 Lisp_Object load
= (NILP (use_floats
) ?
2547 make_number ((int) (100.0 * load_ave
[loads
]))
2548 : make_float (load_ave
[loads
]));
2549 ret
= Fcons (load
, ret
);
2555 Lisp_Object Qsubfeatures
;
2557 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2558 doc
: /* Return t if FEATURE is present in this Emacs.
2560 Use this to conditionalize execution of lisp code based on the
2561 presence or absence of Emacs or environment extensions.
2562 Use `provide' to declare that a feature is available. This function
2563 looks at the value of the variable `features'. The optional argument
2564 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2565 (Lisp_Object feature
, Lisp_Object subfeature
)
2567 register Lisp_Object tem
;
2568 CHECK_SYMBOL (feature
);
2569 tem
= Fmemq (feature
, Vfeatures
);
2570 if (!NILP (tem
) && !NILP (subfeature
))
2571 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2572 return (NILP (tem
)) ? Qnil
: Qt
;
2575 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2576 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2577 The optional argument SUBFEATURES should be a list of symbols listing
2578 particular subfeatures supported in this version of FEATURE. */)
2579 (Lisp_Object feature
, Lisp_Object subfeatures
)
2581 register Lisp_Object tem
;
2582 CHECK_SYMBOL (feature
);
2583 CHECK_LIST (subfeatures
);
2584 if (!NILP (Vautoload_queue
))
2585 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2587 tem
= Fmemq (feature
, Vfeatures
);
2589 Vfeatures
= Fcons (feature
, Vfeatures
);
2590 if (!NILP (subfeatures
))
2591 Fput (feature
, Qsubfeatures
, subfeatures
);
2592 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2594 /* Run any load-hooks for this file. */
2595 tem
= Fassq (feature
, Vafter_load_alist
);
2597 Fprogn (XCDR (tem
));
2602 /* `require' and its subroutines. */
2604 /* List of features currently being require'd, innermost first. */
2606 Lisp_Object require_nesting_list
;
2609 require_unwind (Lisp_Object old_value
)
2611 return require_nesting_list
= old_value
;
2614 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2615 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2616 If FEATURE is not a member of the list `features', then the feature
2617 is not loaded; so load the file FILENAME.
2618 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2619 and `load' will try to load this name appended with the suffix `.elc' or
2620 `.el', in that order. The name without appended suffix will not be used.
2621 If the optional third argument NOERROR is non-nil,
2622 then return nil if the file is not found instead of signaling an error.
2623 Normally the return value is FEATURE.
2624 The normal messages at start and end of loading FILENAME are suppressed. */)
2625 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2627 register Lisp_Object tem
;
2628 struct gcpro gcpro1
, gcpro2
;
2629 int from_file
= load_in_progress
;
2631 CHECK_SYMBOL (feature
);
2633 /* Record the presence of `require' in this file
2634 even if the feature specified is already loaded.
2635 But not more than once in any file,
2636 and not when we aren't loading or reading from a file. */
2638 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2639 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2644 tem
= Fcons (Qrequire
, feature
);
2645 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2646 LOADHIST_ATTACH (tem
);
2648 tem
= Fmemq (feature
, Vfeatures
);
2652 int count
= SPECPDL_INDEX ();
2655 /* This is to make sure that loadup.el gives a clear picture
2656 of what files are preloaded and when. */
2657 if (! NILP (Vpurify_flag
))
2658 error ("(require %s) while preparing to dump",
2659 SDATA (SYMBOL_NAME (feature
)));
2661 /* A certain amount of recursive `require' is legitimate,
2662 but if we require the same feature recursively 3 times,
2664 tem
= require_nesting_list
;
2665 while (! NILP (tem
))
2667 if (! NILP (Fequal (feature
, XCAR (tem
))))
2672 error ("Recursive `require' for feature `%s'",
2673 SDATA (SYMBOL_NAME (feature
)));
2675 /* Update the list for any nested `require's that occur. */
2676 record_unwind_protect (require_unwind
, require_nesting_list
);
2677 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2679 /* Value saved here is to be restored into Vautoload_queue */
2680 record_unwind_protect (un_autoload
, Vautoload_queue
);
2681 Vautoload_queue
= Qt
;
2683 /* Load the file. */
2684 GCPRO2 (feature
, filename
);
2685 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2686 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2689 /* If load failed entirely, return nil. */
2691 return unbind_to (count
, Qnil
);
2693 tem
= Fmemq (feature
, Vfeatures
);
2695 error ("Required feature `%s' was not provided",
2696 SDATA (SYMBOL_NAME (feature
)));
2698 /* Once loading finishes, don't undo it. */
2699 Vautoload_queue
= Qt
;
2700 feature
= unbind_to (count
, feature
);
2706 /* Primitives for work of the "widget" library.
2707 In an ideal world, this section would not have been necessary.
2708 However, lisp function calls being as slow as they are, it turns
2709 out that some functions in the widget library (wid-edit.el) are the
2710 bottleneck of Widget operation. Here is their translation to C,
2711 for the sole reason of efficiency. */
2713 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2714 doc
: /* Return non-nil if PLIST has the property PROP.
2715 PLIST is a property list, which is a list of the form
2716 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2717 Unlike `plist-get', this allows you to distinguish between a missing
2718 property and a property with the value nil.
2719 The value is actually the tail of PLIST whose car is PROP. */)
2720 (Lisp_Object plist
, Lisp_Object prop
)
2722 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2725 plist
= XCDR (plist
);
2726 plist
= CDR (plist
);
2731 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2732 doc
: /* In WIDGET, set PROPERTY to VALUE.
2733 The value can later be retrieved with `widget-get'. */)
2734 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2736 CHECK_CONS (widget
);
2737 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2741 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2742 doc
: /* In WIDGET, get the value of PROPERTY.
2743 The value could either be specified when the widget was created, or
2744 later with `widget-put'. */)
2745 (Lisp_Object widget
, Lisp_Object property
)
2753 CHECK_CONS (widget
);
2754 tmp
= Fplist_member (XCDR (widget
), property
);
2760 tmp
= XCAR (widget
);
2763 widget
= Fget (tmp
, Qwidget_type
);
2767 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2768 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2769 ARGS are passed as extra arguments to the function.
2770 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2771 (int nargs
, Lisp_Object
*args
)
2773 /* This function can GC. */
2774 Lisp_Object newargs
[3];
2775 struct gcpro gcpro1
, gcpro2
;
2778 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2779 newargs
[1] = args
[0];
2780 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2781 GCPRO2 (newargs
[0], newargs
[2]);
2782 result
= Fapply (3, newargs
);
2787 #ifdef HAVE_LANGINFO_CODESET
2788 #include <langinfo.h>
2791 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2792 doc
: /* Access locale data ITEM for the current C locale, if available.
2793 ITEM should be one of the following:
2795 `codeset', returning the character set as a string (locale item CODESET);
2797 `days', returning a 7-element vector of day names (locale items DAY_n);
2799 `months', returning a 12-element vector of month names (locale items MON_n);
2801 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2802 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2804 If the system can't provide such information through a call to
2805 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2807 See also Info node `(libc)Locales'.
2809 The data read from the system are decoded using `locale-coding-system'. */)
2813 #ifdef HAVE_LANGINFO_CODESET
2815 if (EQ (item
, Qcodeset
))
2817 str
= nl_langinfo (CODESET
);
2818 return build_string (str
);
2821 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2823 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2824 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2826 struct gcpro gcpro1
;
2828 synchronize_system_time_locale ();
2829 for (i
= 0; i
< 7; i
++)
2831 str
= nl_langinfo (days
[i
]);
2832 val
= make_unibyte_string (str
, strlen (str
));
2833 /* Fixme: Is this coding system necessarily right, even if
2834 it is consistent with CODESET? If not, what to do? */
2835 Faset (v
, make_number (i
),
2836 code_convert_string_norecord (val
, Vlocale_coding_system
,
2844 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2846 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2847 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2848 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2850 struct gcpro gcpro1
;
2852 synchronize_system_time_locale ();
2853 for (i
= 0; i
< 12; i
++)
2855 str
= nl_langinfo (months
[i
]);
2856 val
= make_unibyte_string (str
, strlen (str
));
2857 Faset (v
, make_number (i
),
2858 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2864 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2865 but is in the locale files. This could be used by ps-print. */
2867 else if (EQ (item
, Qpaper
))
2869 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2870 make_number (nl_langinfo (PAPER_HEIGHT
)));
2872 #endif /* PAPER_WIDTH */
2873 #endif /* HAVE_LANGINFO_CODESET*/
2877 /* base64 encode/decode functions (RFC 2045).
2878 Based on code from GNU recode. */
2880 #define MIME_LINE_LENGTH 76
2882 #define IS_ASCII(Character) \
2884 #define IS_BASE64(Character) \
2885 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2886 #define IS_BASE64_IGNORABLE(Character) \
2887 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2888 || (Character) == '\f' || (Character) == '\r')
2890 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2891 character or return retval if there are no characters left to
2893 #define READ_QUADRUPLET_BYTE(retval) \
2898 if (nchars_return) \
2899 *nchars_return = nchars; \
2904 while (IS_BASE64_IGNORABLE (c))
2906 /* Table of characters coding the 64 values. */
2907 static const char base64_value_to_char
[64] =
2909 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2910 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2911 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2912 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2913 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2914 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2915 '8', '9', '+', '/' /* 60-63 */
2918 /* Table of base64 values for first 128 characters. */
2919 static const short base64_char_to_value
[128] =
2921 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2922 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2923 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2924 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2925 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2926 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2927 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2928 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2929 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2930 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2931 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2932 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2933 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2936 /* The following diagram shows the logical steps by which three octets
2937 get transformed into four base64 characters.
2939 .--------. .--------. .--------.
2940 |aaaaaabb| |bbbbcccc| |ccdddddd|
2941 `--------' `--------' `--------'
2943 .--------+--------+--------+--------.
2944 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2945 `--------+--------+--------+--------'
2947 .--------+--------+--------+--------.
2948 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2949 `--------+--------+--------+--------'
2951 The octets are divided into 6 bit chunks, which are then encoded into
2952 base64 characters. */
2955 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2956 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2959 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2961 doc
: /* Base64-encode the region between BEG and END.
2962 Return the length of the encoded text.
2963 Optional third argument NO-LINE-BREAK means do not break long lines
2964 into shorter lines. */)
2965 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2968 EMACS_INT allength
, length
;
2969 EMACS_INT ibeg
, iend
, encoded_length
;
2970 EMACS_INT old_pos
= PT
;
2973 validate_region (&beg
, &end
);
2975 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2976 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2977 move_gap_both (XFASTINT (beg
), ibeg
);
2979 /* We need to allocate enough room for encoding the text.
2980 We need 33 1/3% more space, plus a newline every 76
2981 characters, and then we round up. */
2982 length
= iend
- ibeg
;
2983 allength
= length
+ length
/3 + 1;
2984 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2986 SAFE_ALLOCA (encoded
, char *, allength
);
2987 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2988 NILP (no_line_break
),
2989 !NILP (current_buffer
->enable_multibyte_characters
));
2990 if (encoded_length
> allength
)
2993 if (encoded_length
< 0)
2995 /* The encoding wasn't possible. */
2997 error ("Multibyte character in data for base64 encoding");
3000 /* Now we have encoded the region, so we insert the new contents
3001 and delete the old. (Insert first in order to preserve markers.) */
3002 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3003 insert (encoded
, encoded_length
);
3005 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3007 /* If point was outside of the region, restore it exactly; else just
3008 move to the beginning of the region. */
3009 if (old_pos
>= XFASTINT (end
))
3010 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3011 else if (old_pos
> XFASTINT (beg
))
3012 old_pos
= XFASTINT (beg
);
3015 /* We return the length of the encoded text. */
3016 return make_number (encoded_length
);
3019 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3021 doc
: /* Base64-encode STRING and return the result.
3022 Optional second argument NO-LINE-BREAK means do not break long lines
3023 into shorter lines. */)
3024 (Lisp_Object string
, Lisp_Object no_line_break
)
3026 EMACS_INT allength
, length
, encoded_length
;
3028 Lisp_Object encoded_string
;
3031 CHECK_STRING (string
);
3033 /* We need to allocate enough room for encoding the text.
3034 We need 33 1/3% more space, plus a newline every 76
3035 characters, and then we round up. */
3036 length
= SBYTES (string
);
3037 allength
= length
+ length
/3 + 1;
3038 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3040 /* We need to allocate enough room for decoding the text. */
3041 SAFE_ALLOCA (encoded
, char *, allength
);
3043 encoded_length
= base64_encode_1 (SDATA (string
),
3044 encoded
, length
, NILP (no_line_break
),
3045 STRING_MULTIBYTE (string
));
3046 if (encoded_length
> allength
)
3049 if (encoded_length
< 0)
3051 /* The encoding wasn't possible. */
3053 error ("Multibyte character in data for base64 encoding");
3056 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3059 return encoded_string
;
3063 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3064 int line_break
, int multibyte
)
3077 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3078 if (CHAR_BYTE8_P (c
))
3079 c
= CHAR_TO_BYTE8 (c
);
3087 /* Wrap line every 76 characters. */
3091 if (counter
< MIME_LINE_LENGTH
/ 4)
3100 /* Process first byte of a triplet. */
3102 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3103 value
= (0x03 & c
) << 4;
3105 /* Process second byte of a triplet. */
3109 *e
++ = base64_value_to_char
[value
];
3117 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3118 if (CHAR_BYTE8_P (c
))
3119 c
= CHAR_TO_BYTE8 (c
);
3127 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3128 value
= (0x0f & c
) << 2;
3130 /* Process third byte of a triplet. */
3134 *e
++ = base64_value_to_char
[value
];
3141 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3142 if (CHAR_BYTE8_P (c
))
3143 c
= CHAR_TO_BYTE8 (c
);
3151 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3152 *e
++ = base64_value_to_char
[0x3f & c
];
3159 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3161 doc
: /* Base64-decode the region between BEG and END.
3162 Return the length of the decoded text.
3163 If the region can't be decoded, signal an error and don't modify the buffer. */)
3164 (Lisp_Object beg
, Lisp_Object end
)
3166 EMACS_INT ibeg
, iend
, length
, allength
;
3168 EMACS_INT old_pos
= PT
;
3169 EMACS_INT decoded_length
;
3170 EMACS_INT inserted_chars
;
3171 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3174 validate_region (&beg
, &end
);
3176 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3177 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3179 length
= iend
- ibeg
;
3181 /* We need to allocate enough room for decoding the text. If we are
3182 working on a multibyte buffer, each decoded code may occupy at
3184 allength
= multibyte
? length
* 2 : length
;
3185 SAFE_ALLOCA (decoded
, char *, allength
);
3187 move_gap_both (XFASTINT (beg
), ibeg
);
3188 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3189 multibyte
, &inserted_chars
);
3190 if (decoded_length
> allength
)
3193 if (decoded_length
< 0)
3195 /* The decoding wasn't possible. */
3197 error ("Invalid base64 data");
3200 /* Now we have decoded the region, so we insert the new contents
3201 and delete the old. (Insert first in order to preserve markers.) */
3202 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3203 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3206 /* Delete the original text. */
3207 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3208 iend
+ decoded_length
, 1);
3210 /* If point was outside of the region, restore it exactly; else just
3211 move to the beginning of the region. */
3212 if (old_pos
>= XFASTINT (end
))
3213 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3214 else if (old_pos
> XFASTINT (beg
))
3215 old_pos
= XFASTINT (beg
);
3216 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3218 return make_number (inserted_chars
);
3221 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3223 doc
: /* Base64-decode STRING and return the result. */)
3224 (Lisp_Object string
)
3227 EMACS_INT length
, decoded_length
;
3228 Lisp_Object decoded_string
;
3231 CHECK_STRING (string
);
3233 length
= SBYTES (string
);
3234 /* We need to allocate enough room for decoding the text. */
3235 SAFE_ALLOCA (decoded
, char *, length
);
3237 /* The decoded result should be unibyte. */
3238 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3240 if (decoded_length
> length
)
3242 else if (decoded_length
>= 0)
3243 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3245 decoded_string
= Qnil
;
3248 if (!STRINGP (decoded_string
))
3249 error ("Invalid base64 data");
3251 return decoded_string
;
3254 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3255 MULTIBYTE is nonzero, the decoded result should be in multibyte
3256 form. If NCHARS_RETRUN is not NULL, store the number of produced
3257 characters in *NCHARS_RETURN. */
3260 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3261 int multibyte
, EMACS_INT
*nchars_return
)
3263 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3266 unsigned long value
;
3267 EMACS_INT nchars
= 0;
3271 /* Process first byte of a quadruplet. */
3273 READ_QUADRUPLET_BYTE (e
-to
);
3277 value
= base64_char_to_value
[c
] << 18;
3279 /* Process second byte of a quadruplet. */
3281 READ_QUADRUPLET_BYTE (-1);
3285 value
|= base64_char_to_value
[c
] << 12;
3287 c
= (unsigned char) (value
>> 16);
3288 if (multibyte
&& c
>= 128)
3289 e
+= BYTE8_STRING (c
, e
);
3294 /* Process third byte of a quadruplet. */
3296 READ_QUADRUPLET_BYTE (-1);
3300 READ_QUADRUPLET_BYTE (-1);
3309 value
|= base64_char_to_value
[c
] << 6;
3311 c
= (unsigned char) (0xff & value
>> 8);
3312 if (multibyte
&& c
>= 128)
3313 e
+= BYTE8_STRING (c
, e
);
3318 /* Process fourth byte of a quadruplet. */
3320 READ_QUADRUPLET_BYTE (-1);
3327 value
|= base64_char_to_value
[c
];
3329 c
= (unsigned char) (0xff & value
);
3330 if (multibyte
&& c
>= 128)
3331 e
+= BYTE8_STRING (c
, e
);
3340 /***********************************************************************
3342 ***** Hash Tables *****
3344 ***********************************************************************/
3346 /* Implemented by gerd@gnu.org. This hash table implementation was
3347 inspired by CMUCL hash tables. */
3351 1. For small tables, association lists are probably faster than
3352 hash tables because they have lower overhead.
3354 For uses of hash tables where the O(1) behavior of table
3355 operations is not a requirement, it might therefore be a good idea
3356 not to hash. Instead, we could just do a linear search in the
3357 key_and_value vector of the hash table. This could be done
3358 if a `:linear-search t' argument is given to make-hash-table. */
3361 /* The list of all weak hash tables. Don't staticpro this one. */
3363 struct Lisp_Hash_Table
*weak_hash_tables
;
3365 /* Various symbols. */
3367 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3368 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3369 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3371 /* Function prototypes. */
3373 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3374 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3375 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3376 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3377 Lisp_Object
, unsigned);
3378 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3379 Lisp_Object
, unsigned);
3380 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3381 unsigned, Lisp_Object
, unsigned);
3382 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3383 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3384 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3385 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3387 static unsigned sxhash_string (unsigned char *, int);
3388 static unsigned sxhash_list (Lisp_Object
, int);
3389 static unsigned sxhash_vector (Lisp_Object
, int);
3390 static unsigned sxhash_bool_vector (Lisp_Object
);
3391 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3395 /***********************************************************************
3397 ***********************************************************************/
3399 /* If OBJ is a Lisp hash table, return a pointer to its struct
3400 Lisp_Hash_Table. Otherwise, signal an error. */
3402 static struct Lisp_Hash_Table
*
3403 check_hash_table (Lisp_Object obj
)
3405 CHECK_HASH_TABLE (obj
);
3406 return XHASH_TABLE (obj
);
3410 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3414 next_almost_prime (int n
)
3426 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3427 which USED[I] is non-zero. If found at index I in ARGS, set
3428 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3429 -1. This function is used to extract a keyword/argument pair from
3430 a DEFUN parameter list. */
3433 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3437 for (i
= 0; i
< nargs
- 1; ++i
)
3438 if (!used
[i
] && EQ (args
[i
], key
))
3453 /* Return a Lisp vector which has the same contents as VEC but has
3454 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3455 vector that are not copied from VEC are set to INIT. */
3458 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3460 struct Lisp_Vector
*v
;
3463 xassert (VECTORP (vec
));
3464 old_size
= ASIZE (vec
);
3465 xassert (new_size
>= old_size
);
3467 v
= allocate_vector (new_size
);
3468 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3469 for (i
= old_size
; i
< new_size
; ++i
)
3470 v
->contents
[i
] = init
;
3471 XSETVECTOR (vec
, v
);
3476 /***********************************************************************
3478 ***********************************************************************/
3480 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3481 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3482 KEY2 are the same. */
3485 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3487 return (FLOATP (key1
)
3489 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3493 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3494 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3495 KEY2 are the same. */
3498 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3500 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3504 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3505 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3506 if KEY1 and KEY2 are the same. */
3509 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3513 Lisp_Object args
[3];
3515 args
[0] = h
->user_cmp_function
;
3518 return !NILP (Ffuncall (3, args
));
3525 /* Value is a hash code for KEY for use in hash table H which uses
3526 `eq' to compare keys. The hash code returned is guaranteed to fit
3527 in a Lisp integer. */
3530 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3532 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3533 xassert ((hash
& ~INTMASK
) == 0);
3538 /* Value is a hash code for KEY for use in hash table H which uses
3539 `eql' to compare keys. The hash code returned is guaranteed to fit
3540 in a Lisp integer. */
3543 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3547 hash
= sxhash (key
, 0);
3549 hash
= XUINT (key
) ^ XTYPE (key
);
3550 xassert ((hash
& ~INTMASK
) == 0);
3555 /* Value is a hash code for KEY for use in hash table H which uses
3556 `equal' to compare keys. The hash code returned is guaranteed to fit
3557 in a Lisp integer. */
3560 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3562 unsigned hash
= sxhash (key
, 0);
3563 xassert ((hash
& ~INTMASK
) == 0);
3568 /* Value is a hash code for KEY for use in hash table H which uses as
3569 user-defined function to compare keys. The hash code returned is
3570 guaranteed to fit in a Lisp integer. */
3573 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3575 Lisp_Object args
[2], hash
;
3577 args
[0] = h
->user_hash_function
;
3579 hash
= Ffuncall (2, args
);
3580 if (!INTEGERP (hash
))
3581 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3582 return XUINT (hash
);
3586 /* Create and initialize a new hash table.
3588 TEST specifies the test the hash table will use to compare keys.
3589 It must be either one of the predefined tests `eq', `eql' or
3590 `equal' or a symbol denoting a user-defined test named TEST with
3591 test and hash functions USER_TEST and USER_HASH.
3593 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3595 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3596 new size when it becomes full is computed by adding REHASH_SIZE to
3597 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3598 table's new size is computed by multiplying its old size with
3601 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3602 be resized when the ratio of (number of entries in the table) /
3603 (table size) is >= REHASH_THRESHOLD.
3605 WEAK specifies the weakness of the table. If non-nil, it must be
3606 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3609 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3610 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3611 Lisp_Object user_test
, Lisp_Object user_hash
)
3613 struct Lisp_Hash_Table
*h
;
3615 int index_size
, i
, sz
;
3617 /* Preconditions. */
3618 xassert (SYMBOLP (test
));
3619 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3620 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3621 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3622 xassert (FLOATP (rehash_threshold
)
3623 && XFLOATINT (rehash_threshold
) > 0
3624 && XFLOATINT (rehash_threshold
) <= 1.0);
3626 if (XFASTINT (size
) == 0)
3627 size
= make_number (1);
3629 /* Allocate a table and initialize it. */
3630 h
= allocate_hash_table ();
3632 /* Initialize hash table slots. */
3633 sz
= XFASTINT (size
);
3636 if (EQ (test
, Qeql
))
3638 h
->cmpfn
= cmpfn_eql
;
3639 h
->hashfn
= hashfn_eql
;
3641 else if (EQ (test
, Qeq
))
3644 h
->hashfn
= hashfn_eq
;
3646 else if (EQ (test
, Qequal
))
3648 h
->cmpfn
= cmpfn_equal
;
3649 h
->hashfn
= hashfn_equal
;
3653 h
->user_cmp_function
= user_test
;
3654 h
->user_hash_function
= user_hash
;
3655 h
->cmpfn
= cmpfn_user_defined
;
3656 h
->hashfn
= hashfn_user_defined
;
3660 h
->rehash_threshold
= rehash_threshold
;
3661 h
->rehash_size
= rehash_size
;
3663 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3664 h
->hash
= Fmake_vector (size
, Qnil
);
3665 h
->next
= Fmake_vector (size
, Qnil
);
3666 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3667 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3668 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3670 /* Set up the free list. */
3671 for (i
= 0; i
< sz
- 1; ++i
)
3672 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3673 h
->next_free
= make_number (0);
3675 XSET_HASH_TABLE (table
, h
);
3676 xassert (HASH_TABLE_P (table
));
3677 xassert (XHASH_TABLE (table
) == h
);
3679 /* Maybe add this hash table to the list of all weak hash tables. */
3681 h
->next_weak
= NULL
;
3684 h
->next_weak
= weak_hash_tables
;
3685 weak_hash_tables
= h
;
3692 /* Return a copy of hash table H1. Keys and values are not copied,
3693 only the table itself is. */
3696 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3699 struct Lisp_Hash_Table
*h2
;
3700 struct Lisp_Vector
*next
;
3702 h2
= allocate_hash_table ();
3703 next
= h2
->vec_next
;
3704 memcpy (h2
, h1
, sizeof *h2
);
3705 h2
->vec_next
= next
;
3706 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3707 h2
->hash
= Fcopy_sequence (h1
->hash
);
3708 h2
->next
= Fcopy_sequence (h1
->next
);
3709 h2
->index
= Fcopy_sequence (h1
->index
);
3710 XSET_HASH_TABLE (table
, h2
);
3712 /* Maybe add this hash table to the list of all weak hash tables. */
3713 if (!NILP (h2
->weak
))
3715 h2
->next_weak
= weak_hash_tables
;
3716 weak_hash_tables
= h2
;
3723 /* Resize hash table H if it's too full. If H cannot be resized
3724 because it's already too large, throw an error. */
3727 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3729 if (NILP (h
->next_free
))
3731 int old_size
= HASH_TABLE_SIZE (h
);
3732 int i
, new_size
, index_size
;
3735 if (INTEGERP (h
->rehash_size
))
3736 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3738 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3739 new_size
= max (old_size
+ 1, new_size
);
3740 index_size
= next_almost_prime ((int)
3742 / XFLOATINT (h
->rehash_threshold
)));
3743 /* Assignment to EMACS_INT stops GCC whining about limited range
3745 nsize
= max (index_size
, 2 * new_size
);
3746 if (nsize
> MOST_POSITIVE_FIXNUM
)
3747 error ("Hash table too large to resize");
3749 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3750 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3751 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3752 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3754 /* Update the free list. Do it so that new entries are added at
3755 the end of the free list. This makes some operations like
3757 for (i
= old_size
; i
< new_size
- 1; ++i
)
3758 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3760 if (!NILP (h
->next_free
))
3762 Lisp_Object last
, next
;
3764 last
= h
->next_free
;
3765 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3769 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3772 XSETFASTINT (h
->next_free
, old_size
);
3775 for (i
= 0; i
< old_size
; ++i
)
3776 if (!NILP (HASH_HASH (h
, i
)))
3778 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3779 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3780 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3781 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3787 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3788 the hash code of KEY. Value is the index of the entry in H
3789 matching KEY, or -1 if not found. */
3792 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3795 int start_of_bucket
;
3798 hash_code
= h
->hashfn (h
, key
);
3802 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3803 idx
= HASH_INDEX (h
, start_of_bucket
);
3805 /* We need not gcpro idx since it's either an integer or nil. */
3808 int i
= XFASTINT (idx
);
3809 if (EQ (key
, HASH_KEY (h
, i
))
3811 && h
->cmpfn (h
, key
, hash_code
,
3812 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3814 idx
= HASH_NEXT (h
, i
);
3817 return NILP (idx
) ? -1 : XFASTINT (idx
);
3821 /* Put an entry into hash table H that associates KEY with VALUE.
3822 HASH is a previously computed hash code of KEY.
3823 Value is the index of the entry in H matching KEY. */
3826 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3828 int start_of_bucket
, i
;
3830 xassert ((hash
& ~INTMASK
) == 0);
3832 /* Increment count after resizing because resizing may fail. */
3833 maybe_resize_hash_table (h
);
3836 /* Store key/value in the key_and_value vector. */
3837 i
= XFASTINT (h
->next_free
);
3838 h
->next_free
= HASH_NEXT (h
, i
);
3839 HASH_KEY (h
, i
) = key
;
3840 HASH_VALUE (h
, i
) = value
;
3842 /* Remember its hash code. */
3843 HASH_HASH (h
, i
) = make_number (hash
);
3845 /* Add new entry to its collision chain. */
3846 start_of_bucket
= hash
% ASIZE (h
->index
);
3847 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3848 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3853 /* Remove the entry matching KEY from hash table H, if there is one. */
3856 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3859 int start_of_bucket
;
3860 Lisp_Object idx
, prev
;
3862 hash_code
= h
->hashfn (h
, key
);
3863 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3864 idx
= HASH_INDEX (h
, start_of_bucket
);
3867 /* We need not gcpro idx, prev since they're either integers or nil. */
3870 int i
= XFASTINT (idx
);
3872 if (EQ (key
, HASH_KEY (h
, i
))
3874 && h
->cmpfn (h
, key
, hash_code
,
3875 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3877 /* Take entry out of collision chain. */
3879 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3881 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3883 /* Clear slots in key_and_value and add the slots to
3885 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3886 HASH_NEXT (h
, i
) = h
->next_free
;
3887 h
->next_free
= make_number (i
);
3889 xassert (h
->count
>= 0);
3895 idx
= HASH_NEXT (h
, i
);
3901 /* Clear hash table H. */
3904 hash_clear (struct Lisp_Hash_Table
*h
)
3908 int i
, size
= HASH_TABLE_SIZE (h
);
3910 for (i
= 0; i
< size
; ++i
)
3912 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3913 HASH_KEY (h
, i
) = Qnil
;
3914 HASH_VALUE (h
, i
) = Qnil
;
3915 HASH_HASH (h
, i
) = Qnil
;
3918 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3919 ASET (h
->index
, i
, Qnil
);
3921 h
->next_free
= make_number (0);
3928 /************************************************************************
3930 ************************************************************************/
3933 init_weak_hash_tables (void)
3935 weak_hash_tables
= NULL
;
3938 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3939 entries from the table that don't survive the current GC.
3940 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3941 non-zero if anything was marked. */
3944 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3946 int bucket
, n
, marked
;
3948 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3951 for (bucket
= 0; bucket
< n
; ++bucket
)
3953 Lisp_Object idx
, next
, prev
;
3955 /* Follow collision chain, removing entries that
3956 don't survive this garbage collection. */
3958 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3960 int i
= XFASTINT (idx
);
3961 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3962 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3965 if (EQ (h
->weak
, Qkey
))
3966 remove_p
= !key_known_to_survive_p
;
3967 else if (EQ (h
->weak
, Qvalue
))
3968 remove_p
= !value_known_to_survive_p
;
3969 else if (EQ (h
->weak
, Qkey_or_value
))
3970 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3971 else if (EQ (h
->weak
, Qkey_and_value
))
3972 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3976 next
= HASH_NEXT (h
, i
);
3978 if (remove_entries_p
)
3982 /* Take out of collision chain. */
3984 HASH_INDEX (h
, bucket
) = next
;
3986 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3988 /* Add to free list. */
3989 HASH_NEXT (h
, i
) = h
->next_free
;
3992 /* Clear key, value, and hash. */
3993 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3994 HASH_HASH (h
, i
) = Qnil
;
4007 /* Make sure key and value survive. */
4008 if (!key_known_to_survive_p
)
4010 mark_object (HASH_KEY (h
, i
));
4014 if (!value_known_to_survive_p
)
4016 mark_object (HASH_VALUE (h
, i
));
4027 /* Remove elements from weak hash tables that don't survive the
4028 current garbage collection. Remove weak tables that don't survive
4029 from Vweak_hash_tables. Called from gc_sweep. */
4032 sweep_weak_hash_tables (void)
4034 struct Lisp_Hash_Table
*h
, *used
, *next
;
4037 /* Mark all keys and values that are in use. Keep on marking until
4038 there is no more change. This is necessary for cases like
4039 value-weak table A containing an entry X -> Y, where Y is used in a
4040 key-weak table B, Z -> Y. If B comes after A in the list of weak
4041 tables, X -> Y might be removed from A, although when looking at B
4042 one finds that it shouldn't. */
4046 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4048 if (h
->size
& ARRAY_MARK_FLAG
)
4049 marked
|= sweep_weak_table (h
, 0);
4054 /* Remove tables and entries that aren't used. */
4055 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4057 next
= h
->next_weak
;
4059 if (h
->size
& ARRAY_MARK_FLAG
)
4061 /* TABLE is marked as used. Sweep its contents. */
4063 sweep_weak_table (h
, 1);
4065 /* Add table to the list of used weak hash tables. */
4066 h
->next_weak
= used
;
4071 weak_hash_tables
= used
;
4076 /***********************************************************************
4077 Hash Code Computation
4078 ***********************************************************************/
4080 /* Maximum depth up to which to dive into Lisp structures. */
4082 #define SXHASH_MAX_DEPTH 3
4084 /* Maximum length up to which to take list and vector elements into
4087 #define SXHASH_MAX_LEN 7
4089 /* Combine two integers X and Y for hashing. */
4091 #define SXHASH_COMBINE(X, Y) \
4092 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4096 /* Return a hash for string PTR which has length LEN. The hash
4097 code returned is guaranteed to fit in a Lisp integer. */
4100 sxhash_string (unsigned char *ptr
, int len
)
4102 unsigned char *p
= ptr
;
4103 unsigned char *end
= p
+ len
;
4112 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4115 return hash
& INTMASK
;
4119 /* Return a hash for list LIST. DEPTH is the current depth in the
4120 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4123 sxhash_list (Lisp_Object list
, int depth
)
4128 if (depth
< SXHASH_MAX_DEPTH
)
4130 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4131 list
= XCDR (list
), ++i
)
4133 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4134 hash
= SXHASH_COMBINE (hash
, hash2
);
4139 unsigned hash2
= sxhash (list
, depth
+ 1);
4140 hash
= SXHASH_COMBINE (hash
, hash2
);
4147 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4148 the Lisp structure. */
4151 sxhash_vector (Lisp_Object vec
, int depth
)
4153 unsigned hash
= ASIZE (vec
);
4156 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4157 for (i
= 0; i
< n
; ++i
)
4159 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4160 hash
= SXHASH_COMBINE (hash
, hash2
);
4167 /* Return a hash for bool-vector VECTOR. */
4170 sxhash_bool_vector (Lisp_Object vec
)
4172 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4175 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4176 for (i
= 0; i
< n
; ++i
)
4177 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4183 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4184 structure. Value is an unsigned integer clipped to INTMASK. */
4187 sxhash (Lisp_Object obj
, int depth
)
4191 if (depth
> SXHASH_MAX_DEPTH
)
4194 switch (XTYPE (obj
))
4205 obj
= SYMBOL_NAME (obj
);
4209 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4212 /* This can be everything from a vector to an overlay. */
4213 case Lisp_Vectorlike
:
4215 /* According to the CL HyperSpec, two arrays are equal only if
4216 they are `eq', except for strings and bit-vectors. In
4217 Emacs, this works differently. We have to compare element
4219 hash
= sxhash_vector (obj
, depth
);
4220 else if (BOOL_VECTOR_P (obj
))
4221 hash
= sxhash_bool_vector (obj
);
4223 /* Others are `equal' if they are `eq', so let's take their
4229 hash
= sxhash_list (obj
, depth
);
4234 double val
= XFLOAT_DATA (obj
);
4235 unsigned char *p
= (unsigned char *) &val
;
4236 unsigned char *e
= p
+ sizeof val
;
4237 for (hash
= 0; p
< e
; ++p
)
4238 hash
= SXHASH_COMBINE (hash
, *p
);
4246 return hash
& INTMASK
;
4251 /***********************************************************************
4253 ***********************************************************************/
4256 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4257 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4260 unsigned hash
= sxhash (obj
, 0);
4261 return make_number (hash
);
4265 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4266 doc
: /* Create and return a new hash table.
4268 Arguments are specified as keyword/argument pairs. The following
4269 arguments are defined:
4271 :test TEST -- TEST must be a symbol that specifies how to compare
4272 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4273 `equal'. User-supplied test and hash functions can be specified via
4274 `define-hash-table-test'.
4276 :size SIZE -- A hint as to how many elements will be put in the table.
4279 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4280 fills up. If REHASH-SIZE is an integer, increase the size by that
4281 amount. If it is a float, it must be > 1.0, and the new size is the
4282 old size multiplied by that factor. Default is 1.5.
4284 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4285 Resize the hash table when the ratio (number of entries / table size)
4286 is greater than or equal to THRESHOLD. Default is 0.8.
4288 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4289 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4290 returned is a weak table. Key/value pairs are removed from a weak
4291 hash table when there are no non-weak references pointing to their
4292 key, value, one of key or value, or both key and value, depending on
4293 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4296 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4297 (int nargs
, Lisp_Object
*args
)
4299 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4300 Lisp_Object user_test
, user_hash
;
4304 /* The vector `used' is used to keep track of arguments that
4305 have been consumed. */
4306 used
= (char *) alloca (nargs
* sizeof *used
);
4307 memset (used
, 0, nargs
* sizeof *used
);
4309 /* See if there's a `:test TEST' among the arguments. */
4310 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4311 test
= i
< 0 ? Qeql
: args
[i
];
4312 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4314 /* See if it is a user-defined test. */
4317 prop
= Fget (test
, Qhash_table_test
);
4318 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4319 signal_error ("Invalid hash table test", test
);
4320 user_test
= XCAR (prop
);
4321 user_hash
= XCAR (XCDR (prop
));
4324 user_test
= user_hash
= Qnil
;
4326 /* See if there's a `:size SIZE' argument. */
4327 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4328 size
= i
< 0 ? Qnil
: args
[i
];
4330 size
= make_number (DEFAULT_HASH_SIZE
);
4331 else if (!INTEGERP (size
) || XINT (size
) < 0)
4332 signal_error ("Invalid hash table size", size
);
4334 /* Look for `:rehash-size SIZE'. */
4335 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4336 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4337 if (!NUMBERP (rehash_size
)
4338 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4339 || XFLOATINT (rehash_size
) <= 1.0)
4340 signal_error ("Invalid hash table rehash size", rehash_size
);
4342 /* Look for `:rehash-threshold THRESHOLD'. */
4343 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4344 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4345 if (!FLOATP (rehash_threshold
)
4346 || XFLOATINT (rehash_threshold
) <= 0.0
4347 || XFLOATINT (rehash_threshold
) > 1.0)
4348 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4350 /* Look for `:weakness WEAK'. */
4351 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4352 weak
= i
< 0 ? Qnil
: args
[i
];
4354 weak
= Qkey_and_value
;
4357 && !EQ (weak
, Qvalue
)
4358 && !EQ (weak
, Qkey_or_value
)
4359 && !EQ (weak
, Qkey_and_value
))
4360 signal_error ("Invalid hash table weakness", weak
);
4362 /* Now, all args should have been used up, or there's a problem. */
4363 for (i
= 0; i
< nargs
; ++i
)
4365 signal_error ("Invalid argument list", args
[i
]);
4367 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4368 user_test
, user_hash
);
4372 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4373 doc
: /* Return a copy of hash table TABLE. */)
4376 return copy_hash_table (check_hash_table (table
));
4380 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4381 doc
: /* Return the number of elements in TABLE. */)
4384 return make_number (check_hash_table (table
)->count
);
4388 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4389 Shash_table_rehash_size
, 1, 1, 0,
4390 doc
: /* Return the current rehash size of TABLE. */)
4393 return check_hash_table (table
)->rehash_size
;
4397 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4398 Shash_table_rehash_threshold
, 1, 1, 0,
4399 doc
: /* Return the current rehash threshold of TABLE. */)
4402 return check_hash_table (table
)->rehash_threshold
;
4406 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4407 doc
: /* Return the size of TABLE.
4408 The size can be used as an argument to `make-hash-table' to create
4409 a hash table than can hold as many elements as TABLE holds
4410 without need for resizing. */)
4413 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4414 return make_number (HASH_TABLE_SIZE (h
));
4418 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4419 doc
: /* Return the test TABLE uses. */)
4422 return check_hash_table (table
)->test
;
4426 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4428 doc
: /* Return the weakness of TABLE. */)
4431 return check_hash_table (table
)->weak
;
4435 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4436 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4439 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4443 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4444 doc
: /* Clear hash table TABLE and return it. */)
4447 hash_clear (check_hash_table (table
));
4448 /* Be compatible with XEmacs. */
4453 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4454 doc
: /* Look up KEY in TABLE and return its associated value.
4455 If KEY is not found, return DFLT which defaults to nil. */)
4456 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4458 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4459 int i
= hash_lookup (h
, key
, NULL
);
4460 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4464 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4465 doc
: /* Associate KEY with VALUE in hash table TABLE.
4466 If KEY is already present in table, replace its current value with
4468 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4470 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4474 i
= hash_lookup (h
, key
, &hash
);
4476 HASH_VALUE (h
, i
) = value
;
4478 hash_put (h
, key
, value
, hash
);
4484 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4485 doc
: /* Remove KEY from TABLE. */)
4486 (Lisp_Object key
, Lisp_Object table
)
4488 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4489 hash_remove_from_table (h
, key
);
4494 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4495 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4496 FUNCTION is called with two arguments, KEY and VALUE. */)
4497 (Lisp_Object function
, Lisp_Object table
)
4499 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4500 Lisp_Object args
[3];
4503 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4504 if (!NILP (HASH_HASH (h
, i
)))
4507 args
[1] = HASH_KEY (h
, i
);
4508 args
[2] = HASH_VALUE (h
, i
);
4516 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4517 Sdefine_hash_table_test
, 3, 3, 0,
4518 doc
: /* Define a new hash table test with name NAME, a symbol.
4520 In hash tables created with NAME specified as test, use TEST to
4521 compare keys, and HASH for computing hash codes of keys.
4523 TEST must be a function taking two arguments and returning non-nil if
4524 both arguments are the same. HASH must be a function taking one
4525 argument and return an integer that is the hash code of the argument.
4526 Hash code computation should use the whole value range of integers,
4527 including negative integers. */)
4528 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4530 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4535 /************************************************************************
4537 ************************************************************************/
4541 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4542 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4544 A message digest is a cryptographic checksum of a document, and the
4545 algorithm to calculate it is defined in RFC 1321.
4547 The two optional arguments START and END are character positions
4548 specifying for which part of OBJECT the message digest should be
4549 computed. If nil or omitted, the digest is computed for the whole
4552 The MD5 message digest is computed from the result of encoding the
4553 text in a coding system, not directly from the internal Emacs form of
4554 the text. The optional fourth argument CODING-SYSTEM specifies which
4555 coding system to encode the text with. It should be the same coding
4556 system that you used or will use when actually writing the text into a
4559 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4560 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4561 system would be chosen by default for writing this text into a file.
4563 If OBJECT is a string, the most preferred coding system (see the
4564 command `prefer-coding-system') is used.
4566 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4567 guesswork fails. Normally, an error is signaled in such case. */)
4568 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4570 unsigned char digest
[16];
4571 unsigned char value
[33];
4574 EMACS_INT size_byte
= 0;
4575 EMACS_INT start_char
= 0, end_char
= 0;
4576 EMACS_INT start_byte
= 0, end_byte
= 0;
4577 register EMACS_INT b
, e
;
4578 register struct buffer
*bp
;
4581 if (STRINGP (object
))
4583 if (NILP (coding_system
))
4585 /* Decide the coding-system to encode the data with. */
4587 if (STRING_MULTIBYTE (object
))
4588 /* use default, we can't guess correct value */
4589 coding_system
= preferred_coding_system ();
4591 coding_system
= Qraw_text
;
4594 if (NILP (Fcoding_system_p (coding_system
)))
4596 /* Invalid coding system. */
4598 if (!NILP (noerror
))
4599 coding_system
= Qraw_text
;
4601 xsignal1 (Qcoding_system_error
, coding_system
);
4604 if (STRING_MULTIBYTE (object
))
4605 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4607 size
= SCHARS (object
);
4608 size_byte
= SBYTES (object
);
4612 CHECK_NUMBER (start
);
4614 start_char
= XINT (start
);
4619 start_byte
= string_char_to_byte (object
, start_char
);
4625 end_byte
= size_byte
;
4631 end_char
= XINT (end
);
4636 end_byte
= string_char_to_byte (object
, end_char
);
4639 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4640 args_out_of_range_3 (object
, make_number (start_char
),
4641 make_number (end_char
));
4645 struct buffer
*prev
= current_buffer
;
4647 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4649 CHECK_BUFFER (object
);
4651 bp
= XBUFFER (object
);
4652 if (bp
!= current_buffer
)
4653 set_buffer_internal (bp
);
4659 CHECK_NUMBER_COERCE_MARKER (start
);
4667 CHECK_NUMBER_COERCE_MARKER (end
);
4672 temp
= b
, b
= e
, e
= temp
;
4674 if (!(BEGV
<= b
&& e
<= ZV
))
4675 args_out_of_range (start
, end
);
4677 if (NILP (coding_system
))
4679 /* Decide the coding-system to encode the data with.
4680 See fileio.c:Fwrite-region */
4682 if (!NILP (Vcoding_system_for_write
))
4683 coding_system
= Vcoding_system_for_write
;
4686 int force_raw_text
= 0;
4688 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4689 if (NILP (coding_system
)
4690 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4692 coding_system
= Qnil
;
4693 if (NILP (current_buffer
->enable_multibyte_characters
))
4697 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4699 /* Check file-coding-system-alist. */
4700 Lisp_Object args
[4], val
;
4702 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4703 args
[3] = Fbuffer_file_name(object
);
4704 val
= Ffind_operation_coding_system (4, args
);
4705 if (CONSP (val
) && !NILP (XCDR (val
)))
4706 coding_system
= XCDR (val
);
4709 if (NILP (coding_system
)
4710 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4712 /* If we still have not decided a coding system, use the
4713 default value of buffer-file-coding-system. */
4714 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4718 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4719 /* Confirm that VAL can surely encode the current region. */
4720 coding_system
= call4 (Vselect_safe_coding_system_function
,
4721 make_number (b
), make_number (e
),
4722 coding_system
, Qnil
);
4725 coding_system
= Qraw_text
;
4728 if (NILP (Fcoding_system_p (coding_system
)))
4730 /* Invalid coding system. */
4732 if (!NILP (noerror
))
4733 coding_system
= Qraw_text
;
4735 xsignal1 (Qcoding_system_error
, coding_system
);
4739 object
= make_buffer_string (b
, e
, 0);
4740 if (prev
!= current_buffer
)
4741 set_buffer_internal (prev
);
4742 /* Discard the unwind protect for recovering the current
4746 if (STRING_MULTIBYTE (object
))
4747 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4750 md5_buffer (SDATA (object
) + start_byte
,
4751 SBYTES (object
) - (size_byte
- end_byte
),
4754 for (i
= 0; i
< 16; i
++)
4755 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4758 return make_string (value
, 32);
4765 /* Hash table stuff. */
4766 Qhash_table_p
= intern_c_string ("hash-table-p");
4767 staticpro (&Qhash_table_p
);
4768 Qeq
= intern_c_string ("eq");
4770 Qeql
= intern_c_string ("eql");
4772 Qequal
= intern_c_string ("equal");
4773 staticpro (&Qequal
);
4774 QCtest
= intern_c_string (":test");
4775 staticpro (&QCtest
);
4776 QCsize
= intern_c_string (":size");
4777 staticpro (&QCsize
);
4778 QCrehash_size
= intern_c_string (":rehash-size");
4779 staticpro (&QCrehash_size
);
4780 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4781 staticpro (&QCrehash_threshold
);
4782 QCweakness
= intern_c_string (":weakness");
4783 staticpro (&QCweakness
);
4784 Qkey
= intern_c_string ("key");
4786 Qvalue
= intern_c_string ("value");
4787 staticpro (&Qvalue
);
4788 Qhash_table_test
= intern_c_string ("hash-table-test");
4789 staticpro (&Qhash_table_test
);
4790 Qkey_or_value
= intern_c_string ("key-or-value");
4791 staticpro (&Qkey_or_value
);
4792 Qkey_and_value
= intern_c_string ("key-and-value");
4793 staticpro (&Qkey_and_value
);
4796 defsubr (&Smake_hash_table
);
4797 defsubr (&Scopy_hash_table
);
4798 defsubr (&Shash_table_count
);
4799 defsubr (&Shash_table_rehash_size
);
4800 defsubr (&Shash_table_rehash_threshold
);
4801 defsubr (&Shash_table_size
);
4802 defsubr (&Shash_table_test
);
4803 defsubr (&Shash_table_weakness
);
4804 defsubr (&Shash_table_p
);
4805 defsubr (&Sclrhash
);
4806 defsubr (&Sgethash
);
4807 defsubr (&Sputhash
);
4808 defsubr (&Sremhash
);
4809 defsubr (&Smaphash
);
4810 defsubr (&Sdefine_hash_table_test
);
4812 Qstring_lessp
= intern_c_string ("string-lessp");
4813 staticpro (&Qstring_lessp
);
4814 Qprovide
= intern_c_string ("provide");
4815 staticpro (&Qprovide
);
4816 Qrequire
= intern_c_string ("require");
4817 staticpro (&Qrequire
);
4818 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4819 staticpro (&Qyes_or_no_p_history
);
4820 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4821 staticpro (&Qcursor_in_echo_area
);
4822 Qwidget_type
= intern_c_string ("widget-type");
4823 staticpro (&Qwidget_type
);
4825 staticpro (&string_char_byte_cache_string
);
4826 string_char_byte_cache_string
= Qnil
;
4828 require_nesting_list
= Qnil
;
4829 staticpro (&require_nesting_list
);
4831 Fset (Qyes_or_no_p_history
, Qnil
);
4833 DEFVAR_LISP ("features", Vfeatures
,
4834 doc
: /* A list of symbols which are the features of the executing Emacs.
4835 Used by `featurep' and `require', and altered by `provide'. */);
4836 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4837 Qsubfeatures
= intern_c_string ("subfeatures");
4838 staticpro (&Qsubfeatures
);
4840 #ifdef HAVE_LANGINFO_CODESET
4841 Qcodeset
= intern_c_string ("codeset");
4842 staticpro (&Qcodeset
);
4843 Qdays
= intern_c_string ("days");
4845 Qmonths
= intern_c_string ("months");
4846 staticpro (&Qmonths
);
4847 Qpaper
= intern_c_string ("paper");
4848 staticpro (&Qpaper
);
4849 #endif /* HAVE_LANGINFO_CODESET */
4851 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4852 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4853 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4854 invoked by mouse clicks and mouse menu items.
4856 On some platforms, file selection dialogs are also enabled if this is
4860 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4861 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4862 This applies to commands from menus and tool bar buttons even when
4863 they are initiated from the keyboard. If `use-dialog-box' is nil,
4864 that disables the use of a file dialog, regardless of the value of
4866 use_file_dialog
= 1;
4868 defsubr (&Sidentity
);
4871 defsubr (&Ssafe_length
);
4872 defsubr (&Sstring_bytes
);
4873 defsubr (&Sstring_equal
);
4874 defsubr (&Scompare_strings
);
4875 defsubr (&Sstring_lessp
);
4878 defsubr (&Svconcat
);
4879 defsubr (&Scopy_sequence
);
4880 defsubr (&Sstring_make_multibyte
);
4881 defsubr (&Sstring_make_unibyte
);
4882 defsubr (&Sstring_as_multibyte
);
4883 defsubr (&Sstring_as_unibyte
);
4884 defsubr (&Sstring_to_multibyte
);
4885 defsubr (&Sstring_to_unibyte
);
4886 defsubr (&Scopy_alist
);
4887 defsubr (&Ssubstring
);
4888 defsubr (&Ssubstring_no_properties
);
4901 defsubr (&Snreverse
);
4902 defsubr (&Sreverse
);
4904 defsubr (&Splist_get
);
4906 defsubr (&Splist_put
);
4908 defsubr (&Slax_plist_get
);
4909 defsubr (&Slax_plist_put
);
4912 defsubr (&Sequal_including_properties
);
4913 defsubr (&Sfillarray
);
4914 defsubr (&Sclear_string
);
4918 defsubr (&Smapconcat
);
4919 defsubr (&Syes_or_no_p
);
4920 defsubr (&Sload_average
);
4921 defsubr (&Sfeaturep
);
4922 defsubr (&Srequire
);
4923 defsubr (&Sprovide
);
4924 defsubr (&Splist_member
);
4925 defsubr (&Swidget_put
);
4926 defsubr (&Swidget_get
);
4927 defsubr (&Swidget_apply
);
4928 defsubr (&Sbase64_encode_region
);
4929 defsubr (&Sbase64_decode_region
);
4930 defsubr (&Sbase64_encode_string
);
4931 defsubr (&Sbase64_decode_string
);
4933 defsubr (&Slocale_info
);