1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 /* Note on some machines this defines `vector' as a typedef,
27 so make sure we don't use that name in this file. */
33 #include "character.h"
38 #include "intervals.h"
41 #include "blockinput.h"
43 #if defined (HAVE_X_WINDOWS)
46 #endif /* HAVE_MENUS */
49 #define NULL ((POINTER_TYPE *)0)
52 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
53 Lisp_Object Qyes_or_no_p_history
;
54 Lisp_Object Qcursor_in_echo_area
;
55 Lisp_Object Qwidget_type
;
56 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
58 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
64 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
65 doc
: /* Return the argument unchanged. */)
71 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
72 doc
: /* Return a pseudo-random number.
73 All integers representable in Lisp are equally likely.
74 On most systems, this is 29 bits' worth.
75 With positive integer LIMIT, return random number in interval [0,LIMIT).
76 With argument t, set the random number seed from the current time and pid.
77 Other values of LIMIT are ignored. */)
81 Lisp_Object lispy_val
;
82 unsigned long denominator
;
85 seed_random (getpid () + time (NULL
));
86 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
88 /* Try to take our random number from the higher bits of VAL,
89 not the lower, since (says Gentzel) the low bits of `random'
90 are less random than the higher ones. We do this by using the
91 quotient rather than the remainder. At the high end of the RNG
92 it's possible to get a quotient larger than n; discarding
93 these values eliminates the bias that would otherwise appear
94 when using a large n. */
95 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
97 val
= get_random () / denominator
;
98 while (val
>= XFASTINT (limit
));
102 XSETINT (lispy_val
, val
);
106 /* Random data-structure functions */
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
119 if (STRINGP (sequence
))
120 XSETFASTINT (val
, SCHARS (sequence
));
121 else if (VECTORP (sequence
))
122 XSETFASTINT (val
, ASIZE (sequence
));
123 else if (CHAR_TABLE_P (sequence
))
124 XSETFASTINT (val
, MAX_CHAR
);
125 else if (BOOL_VECTOR_P (sequence
))
126 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
127 else if (COMPILEDP (sequence
))
128 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
129 else if (CONSP (sequence
))
132 while (CONSP (sequence
))
134 sequence
= XCDR (sequence
);
137 if (!CONSP (sequence
))
140 sequence
= XCDR (sequence
);
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 /* This does not check for quits. That is safe since it must terminate. */
159 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
160 doc
: /* Return the length of a list, but avoid error or infinite loop.
161 This function never gets an error. If LIST is not really a list,
162 it returns 0. If LIST is circular, it returns a finite value
163 which is at least the number of distinct elements. */)
166 Lisp_Object tail
, halftail
, length
;
169 /* halftail is used to detect circular lists. */
171 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
173 if (EQ (tail
, halftail
) && len
!= 0)
177 halftail
= XCDR (halftail
);
180 XSETINT (length
, len
);
184 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
185 doc
: /* Return the number of bytes in STRING.
186 If STRING is multibyte, this may be greater than the length of STRING. */)
189 CHECK_STRING (string
);
190 return make_number (SBYTES (string
));
193 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
194 doc
: /* Return t if two strings have identical contents.
195 Case is significant, but text properties are ignored.
196 Symbols are also allowed; their print names are used instead. */)
197 (register Lisp_Object s1
, Lisp_Object s2
)
200 s1
= SYMBOL_NAME (s1
);
202 s2
= SYMBOL_NAME (s2
);
206 if (SCHARS (s1
) != SCHARS (s2
)
207 || SBYTES (s1
) != SBYTES (s2
)
208 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
213 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
214 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
215 In string STR1, skip the first START1 characters and stop at END1.
216 In string STR2, skip the first START2 characters and stop at END2.
217 END1 and END2 default to the full lengths of the respective strings.
219 Case is significant in this comparison if IGNORE-CASE is nil.
220 Unibyte strings are converted to multibyte for comparison.
222 The value is t if the strings (or specified portions) match.
223 If string STR1 is less, the value is a negative number N;
224 - 1 - N is the number of characters that match at the beginning.
225 If string STR1 is greater, the value is a positive number N;
226 N - 1 is the number of characters that match at the beginning. */)
227 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
229 register EMACS_INT end1_char
, end2_char
;
230 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
235 start1
= make_number (0);
237 start2
= make_number (0);
238 CHECK_NATNUM (start1
);
239 CHECK_NATNUM (start2
);
248 i1_byte
= string_char_to_byte (str1
, i1
);
249 i2_byte
= string_char_to_byte (str2
, i2
);
251 end1_char
= SCHARS (str1
);
252 if (! NILP (end1
) && end1_char
> XINT (end1
))
253 end1_char
= XINT (end1
);
255 end2_char
= SCHARS (str2
);
256 if (! NILP (end2
) && end2_char
> XINT (end2
))
257 end2_char
= XINT (end2
);
259 while (i1
< end1_char
&& i2
< end2_char
)
261 /* When we find a mismatch, we must compare the
262 characters, not just the bytes. */
265 if (STRING_MULTIBYTE (str1
))
266 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
269 c1
= SREF (str1
, i1
++);
270 MAKE_CHAR_MULTIBYTE (c1
);
273 if (STRING_MULTIBYTE (str2
))
274 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
277 c2
= SREF (str2
, i2
++);
278 MAKE_CHAR_MULTIBYTE (c2
);
284 if (! NILP (ignore_case
))
288 tem
= Fupcase (make_number (c1
));
290 tem
= Fupcase (make_number (c2
));
297 /* Note that I1 has already been incremented
298 past the character that we are comparing;
299 hence we don't add or subtract 1 here. */
301 return make_number (- i1
+ XINT (start1
));
303 return make_number (i1
- XINT (start1
));
307 return make_number (i1
- XINT (start1
) + 1);
309 return make_number (- i1
+ XINT (start1
) - 1);
314 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
315 doc
: /* Return t if first arg string is less than second in lexicographic order.
317 Symbols are also allowed; their print names are used instead. */)
318 (register Lisp_Object s1
, Lisp_Object s2
)
320 register EMACS_INT end
;
321 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
324 s1
= SYMBOL_NAME (s1
);
326 s2
= SYMBOL_NAME (s2
);
330 i1
= i1_byte
= i2
= i2_byte
= 0;
333 if (end
> SCHARS (s2
))
338 /* When we find a mismatch, we must compare the
339 characters, not just the bytes. */
342 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
343 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
346 return c1
< c2
? Qt
: Qnil
;
348 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
351 static Lisp_Object
concat (size_t nargs
, Lisp_Object
*args
,
352 enum Lisp_Type target_type
, int last_special
);
356 concat2 (Lisp_Object s1
, Lisp_Object s2
)
361 return concat (2, args
, Lisp_String
, 0);
366 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
372 return concat (3, args
, Lisp_String
, 0);
375 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
376 doc
: /* Concatenate all the arguments and make the result a list.
377 The result is a list whose elements are the elements of all the arguments.
378 Each argument may be a list, vector or string.
379 The last argument is not copied, just used as the tail of the new list.
380 usage: (append &rest SEQUENCES) */)
381 (size_t nargs
, Lisp_Object
*args
)
383 return concat (nargs
, args
, Lisp_Cons
, 1);
386 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
387 doc
: /* Concatenate all the arguments and make the result a string.
388 The result is a string whose elements are the elements of all the arguments.
389 Each argument may be a string or a list or vector of characters (integers).
390 usage: (concat &rest SEQUENCES) */)
391 (size_t nargs
, Lisp_Object
*args
)
393 return concat (nargs
, args
, Lisp_String
, 0);
396 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
397 doc
: /* Concatenate all the arguments and make the result a vector.
398 The result is a vector whose elements are the elements of all the arguments.
399 Each argument may be a list, vector or string.
400 usage: (vconcat &rest SEQUENCES) */)
401 (size_t nargs
, Lisp_Object
*args
)
403 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
407 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
408 doc
: /* Return a copy of a list, vector, string or char-table.
409 The elements of a list or vector are not copied; they are shared
410 with the original. */)
413 if (NILP (arg
)) return arg
;
415 if (CHAR_TABLE_P (arg
))
417 return copy_char_table (arg
);
420 if (BOOL_VECTOR_P (arg
))
424 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
425 / BOOL_VECTOR_BITS_PER_CHAR
);
427 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
428 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
433 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
434 wrong_type_argument (Qsequencep
, arg
);
436 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
439 /* This structure holds information of an argument of `concat' that is
440 a string and has text properties to be copied. */
443 int argnum
; /* refer to ARGS (arguments of `concat') */
444 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
445 EMACS_INT to
; /* refer to VAL (the target string) */
449 concat (size_t nargs
, Lisp_Object
*args
,
450 enum Lisp_Type target_type
, int last_special
)
453 register Lisp_Object tail
;
454 register Lisp_Object
this;
456 EMACS_INT toindex_byte
= 0;
457 register EMACS_INT result_len
;
458 register EMACS_INT result_len_byte
;
459 register size_t argnum
;
460 Lisp_Object last_tail
;
463 /* When we make a multibyte string, we can't copy text properties
464 while concatinating each string because the length of resulting
465 string can't be decided until we finish the whole concatination.
466 So, we record strings that have text properties to be copied
467 here, and copy the text properties after the concatination. */
468 struct textprop_rec
*textprops
= NULL
;
469 /* Number of elements in textprops. */
470 int num_textprops
= 0;
475 /* In append, the last arg isn't treated like the others */
476 if (last_special
&& nargs
> 0)
479 last_tail
= args
[nargs
];
484 /* Check each argument. */
485 for (argnum
= 0; argnum
< nargs
; argnum
++)
488 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
489 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
490 wrong_type_argument (Qsequencep
, this);
493 /* Compute total length in chars of arguments in RESULT_LEN.
494 If desired output is a string, also compute length in bytes
495 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
496 whether the result should be a multibyte string. */
500 for (argnum
= 0; argnum
< nargs
; argnum
++)
504 len
= XFASTINT (Flength (this));
505 if (target_type
== Lisp_String
)
507 /* We must count the number of bytes needed in the string
508 as well as the number of characters. */
511 EMACS_INT this_len_byte
;
514 for (i
= 0; i
< len
; i
++)
517 CHECK_CHARACTER (ch
);
518 this_len_byte
= CHAR_BYTES (XINT (ch
));
519 result_len_byte
+= this_len_byte
;
520 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
523 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
524 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
525 else if (CONSP (this))
526 for (; CONSP (this); this = XCDR (this))
529 CHECK_CHARACTER (ch
);
530 this_len_byte
= CHAR_BYTES (XINT (ch
));
531 result_len_byte
+= this_len_byte
;
532 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
535 else if (STRINGP (this))
537 if (STRING_MULTIBYTE (this))
540 result_len_byte
+= SBYTES (this);
543 result_len_byte
+= count_size_as_multibyte (SDATA (this),
550 error ("String overflow");
553 if (! some_multibyte
)
554 result_len_byte
= result_len
;
556 /* Create the output object. */
557 if (target_type
== Lisp_Cons
)
558 val
= Fmake_list (make_number (result_len
), Qnil
);
559 else if (target_type
== Lisp_Vectorlike
)
560 val
= Fmake_vector (make_number (result_len
), Qnil
);
561 else if (some_multibyte
)
562 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
564 val
= make_uninit_string (result_len
);
566 /* In `append', if all but last arg are nil, return last arg. */
567 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
570 /* Copy the contents of the args into the result. */
572 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
574 toindex
= 0, toindex_byte
= 0;
578 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
580 for (argnum
= 0; argnum
< nargs
; argnum
++)
583 EMACS_INT thisleni
= 0;
584 register EMACS_INT thisindex
= 0;
585 register EMACS_INT thisindex_byte
= 0;
589 thislen
= Flength (this), thisleni
= XINT (thislen
);
591 /* Between strings of the same kind, copy fast. */
592 if (STRINGP (this) && STRINGP (val
)
593 && STRING_MULTIBYTE (this) == some_multibyte
)
595 EMACS_INT thislen_byte
= SBYTES (this);
597 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
598 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
600 textprops
[num_textprops
].argnum
= argnum
;
601 textprops
[num_textprops
].from
= 0;
602 textprops
[num_textprops
++].to
= toindex
;
604 toindex_byte
+= thislen_byte
;
607 /* Copy a single-byte string to a multibyte string. */
608 else if (STRINGP (this) && STRINGP (val
))
610 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
612 textprops
[num_textprops
].argnum
= argnum
;
613 textprops
[num_textprops
].from
= 0;
614 textprops
[num_textprops
++].to
= toindex
;
616 toindex_byte
+= copy_text (SDATA (this),
617 SDATA (val
) + toindex_byte
,
618 SCHARS (this), 0, 1);
622 /* Copy element by element. */
625 register Lisp_Object elt
;
627 /* Fetch next element of `this' arg into `elt', or break if
628 `this' is exhausted. */
629 if (NILP (this)) break;
631 elt
= XCAR (this), this = XCDR (this);
632 else if (thisindex
>= thisleni
)
634 else if (STRINGP (this))
637 if (STRING_MULTIBYTE (this))
639 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
642 XSETFASTINT (elt
, c
);
646 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
648 && !ASCII_CHAR_P (XINT (elt
))
649 && XINT (elt
) < 0400)
651 c
= BYTE8_TO_CHAR (XINT (elt
));
656 else if (BOOL_VECTOR_P (this))
659 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
660 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
668 elt
= AREF (this, thisindex
);
672 /* Store this element into the result. */
679 else if (VECTORP (val
))
681 ASET (val
, toindex
, elt
);
688 toindex_byte
+= CHAR_STRING (XINT (elt
),
689 SDATA (val
) + toindex_byte
);
691 SSET (val
, toindex_byte
++, XINT (elt
));
697 XSETCDR (prev
, last_tail
);
699 if (num_textprops
> 0)
702 EMACS_INT last_to_end
= -1;
704 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
706 this = args
[textprops
[argnum
].argnum
];
707 props
= text_property_list (this,
709 make_number (SCHARS (this)),
711 /* If successive arguments have properites, be sure that the
712 value of `composition' property be the copy. */
713 if (last_to_end
== textprops
[argnum
].to
)
714 make_composition_value_copy (props
);
715 add_text_properties_from_list (val
, props
,
716 make_number (textprops
[argnum
].to
));
717 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
725 static Lisp_Object string_char_byte_cache_string
;
726 static EMACS_INT string_char_byte_cache_charpos
;
727 static EMACS_INT string_char_byte_cache_bytepos
;
730 clear_string_char_byte_cache (void)
732 string_char_byte_cache_string
= Qnil
;
735 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
738 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
741 EMACS_INT best_below
, best_below_byte
;
742 EMACS_INT best_above
, best_above_byte
;
744 best_below
= best_below_byte
= 0;
745 best_above
= SCHARS (string
);
746 best_above_byte
= SBYTES (string
);
747 if (best_above
== best_above_byte
)
750 if (EQ (string
, string_char_byte_cache_string
))
752 if (string_char_byte_cache_charpos
< char_index
)
754 best_below
= string_char_byte_cache_charpos
;
755 best_below_byte
= string_char_byte_cache_bytepos
;
759 best_above
= string_char_byte_cache_charpos
;
760 best_above_byte
= string_char_byte_cache_bytepos
;
764 if (char_index
- best_below
< best_above
- char_index
)
766 unsigned char *p
= SDATA (string
) + best_below_byte
;
768 while (best_below
< char_index
)
770 p
+= BYTES_BY_CHAR_HEAD (*p
);
773 i_byte
= p
- SDATA (string
);
777 unsigned char *p
= SDATA (string
) + best_above_byte
;
779 while (best_above
> char_index
)
782 while (!CHAR_HEAD_P (*p
)) p
--;
785 i_byte
= p
- SDATA (string
);
788 string_char_byte_cache_bytepos
= i_byte
;
789 string_char_byte_cache_charpos
= char_index
;
790 string_char_byte_cache_string
= string
;
795 /* Return the character index corresponding to BYTE_INDEX in STRING. */
798 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
801 EMACS_INT best_below
, best_below_byte
;
802 EMACS_INT best_above
, best_above_byte
;
804 best_below
= best_below_byte
= 0;
805 best_above
= SCHARS (string
);
806 best_above_byte
= SBYTES (string
);
807 if (best_above
== best_above_byte
)
810 if (EQ (string
, string_char_byte_cache_string
))
812 if (string_char_byte_cache_bytepos
< byte_index
)
814 best_below
= string_char_byte_cache_charpos
;
815 best_below_byte
= string_char_byte_cache_bytepos
;
819 best_above
= string_char_byte_cache_charpos
;
820 best_above_byte
= string_char_byte_cache_bytepos
;
824 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
826 unsigned char *p
= SDATA (string
) + best_below_byte
;
827 unsigned char *pend
= SDATA (string
) + byte_index
;
831 p
+= BYTES_BY_CHAR_HEAD (*p
);
835 i_byte
= p
- SDATA (string
);
839 unsigned char *p
= SDATA (string
) + best_above_byte
;
840 unsigned char *pbeg
= SDATA (string
) + byte_index
;
845 while (!CHAR_HEAD_P (*p
)) p
--;
849 i_byte
= p
- SDATA (string
);
852 string_char_byte_cache_bytepos
= i_byte
;
853 string_char_byte_cache_charpos
= i
;
854 string_char_byte_cache_string
= string
;
859 /* Convert STRING to a multibyte string. */
862 string_make_multibyte (Lisp_Object string
)
869 if (STRING_MULTIBYTE (string
))
872 nbytes
= count_size_as_multibyte (SDATA (string
),
874 /* If all the chars are ASCII, they won't need any more bytes
875 once converted. In that case, we can return STRING itself. */
876 if (nbytes
== SBYTES (string
))
879 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
880 copy_text (SDATA (string
), buf
, SBYTES (string
),
883 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
890 /* Convert STRING (if unibyte) to a multibyte string without changing
891 the number of characters. Characters 0200 trough 0237 are
892 converted to eight-bit characters. */
895 string_to_multibyte (Lisp_Object string
)
902 if (STRING_MULTIBYTE (string
))
905 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
906 /* If all the chars are ASCII, they won't need any more bytes once
908 if (nbytes
== SBYTES (string
))
909 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
911 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
912 memcpy (buf
, SDATA (string
), SBYTES (string
));
913 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
915 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
922 /* Convert STRING to a single-byte string. */
925 string_make_unibyte (Lisp_Object string
)
932 if (! STRING_MULTIBYTE (string
))
935 nchars
= SCHARS (string
);
937 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
938 copy_text (SDATA (string
), buf
, SBYTES (string
),
941 ret
= make_unibyte_string ((char *) buf
, nchars
);
947 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
949 doc
: /* Return the multibyte equivalent of STRING.
950 If STRING is unibyte and contains non-ASCII characters, the function
951 `unibyte-char-to-multibyte' is used to convert each unibyte character
952 to a multibyte character. In this case, the returned string is a
953 newly created string with no text properties. If STRING is multibyte
954 or entirely ASCII, it is returned unchanged. In particular, when
955 STRING is unibyte and entirely ASCII, the returned string is unibyte.
956 \(When the characters are all ASCII, Emacs primitives will treat the
957 string the same way whether it is unibyte or multibyte.) */)
960 CHECK_STRING (string
);
962 return string_make_multibyte (string
);
965 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
967 doc
: /* Return the unibyte equivalent of STRING.
968 Multibyte character codes are converted to unibyte according to
969 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
970 If the lookup in the translation table fails, this function takes just
971 the low 8 bits of each character. */)
974 CHECK_STRING (string
);
976 return string_make_unibyte (string
);
979 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
981 doc
: /* Return a unibyte string with the same individual bytes as STRING.
982 If STRING is unibyte, the result is STRING itself.
983 Otherwise it is a newly created string, with no text properties.
984 If STRING is multibyte and contains a character of charset
985 `eight-bit', it is converted to the corresponding single byte. */)
988 CHECK_STRING (string
);
990 if (STRING_MULTIBYTE (string
))
992 EMACS_INT bytes
= SBYTES (string
);
993 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
995 memcpy (str
, SDATA (string
), bytes
);
996 bytes
= str_as_unibyte (str
, bytes
);
997 string
= make_unibyte_string ((char *) str
, bytes
);
1003 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1005 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1006 If STRING is multibyte, the result is STRING itself.
1007 Otherwise it is a newly created string, with no text properties.
1009 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1010 part of a correct utf-8 sequence), it is converted to the corresponding
1011 multibyte character of charset `eight-bit'.
1012 See also `string-to-multibyte'.
1014 Beware, this often doesn't really do what you think it does.
1015 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1016 If you're not sure, whether to use `string-as-multibyte' or
1017 `string-to-multibyte', use `string-to-multibyte'. */)
1018 (Lisp_Object string
)
1020 CHECK_STRING (string
);
1022 if (! STRING_MULTIBYTE (string
))
1024 Lisp_Object new_string
;
1025 EMACS_INT nchars
, nbytes
;
1027 parse_str_as_multibyte (SDATA (string
),
1030 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1031 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1032 if (nbytes
!= SBYTES (string
))
1033 str_as_multibyte (SDATA (new_string
), nbytes
,
1034 SBYTES (string
), NULL
);
1035 string
= new_string
;
1036 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1041 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1043 doc
: /* Return a multibyte string with the same individual chars as STRING.
1044 If STRING is multibyte, the result is STRING itself.
1045 Otherwise it is a newly created string, with no text properties.
1047 If STRING is unibyte and contains an 8-bit byte, it is converted to
1048 the corresponding multibyte character of charset `eight-bit'.
1050 This differs from `string-as-multibyte' by converting each byte of a correct
1051 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1052 correct sequence. */)
1053 (Lisp_Object string
)
1055 CHECK_STRING (string
);
1057 return string_to_multibyte (string
);
1060 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1062 doc
: /* Return a unibyte string with the same individual chars as STRING.
1063 If STRING is unibyte, the result is STRING itself.
1064 Otherwise it is a newly created string, with no text properties,
1065 where each `eight-bit' character is converted to the corresponding byte.
1066 If STRING contains a non-ASCII, non-`eight-bit' character,
1067 an error is signaled. */)
1068 (Lisp_Object string
)
1070 CHECK_STRING (string
);
1072 if (STRING_MULTIBYTE (string
))
1074 EMACS_INT chars
= SCHARS (string
);
1075 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1076 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1078 if (converted
< chars
)
1079 error ("Can't convert the %dth character to unibyte", converted
);
1080 string
= make_unibyte_string ((char *) str
, chars
);
1087 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1088 doc
: /* Return a copy of ALIST.
1089 This is an alist which represents the same mapping from objects to objects,
1090 but does not share the alist structure with ALIST.
1091 The objects mapped (cars and cdrs of elements of the alist)
1092 are shared, however.
1093 Elements of ALIST that are not conses are also shared. */)
1096 register Lisp_Object tem
;
1101 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1102 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1104 register Lisp_Object car
;
1108 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1113 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1114 doc
: /* Return a new string whose contents are a substring of STRING.
1115 The returned string consists of the characters between index FROM
1116 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1117 zero-indexed: 0 means the first character of STRING. Negative values
1118 are counted from the end of STRING. If TO is nil, the substring runs
1119 to the end of STRING.
1121 The STRING argument may also be a vector. In that case, the return
1122 value is a new vector that contains the elements between index FROM
1123 \(inclusive) and index TO (exclusive) of that vector argument. */)
1124 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1128 EMACS_INT size_byte
= 0;
1129 EMACS_INT from_char
, to_char
;
1130 EMACS_INT from_byte
= 0, to_byte
= 0;
1132 CHECK_VECTOR_OR_STRING (string
);
1133 CHECK_NUMBER (from
);
1135 if (STRINGP (string
))
1137 size
= SCHARS (string
);
1138 size_byte
= SBYTES (string
);
1141 size
= ASIZE (string
);
1146 to_byte
= size_byte
;
1152 to_char
= XINT (to
);
1156 if (STRINGP (string
))
1157 to_byte
= string_char_to_byte (string
, to_char
);
1160 from_char
= XINT (from
);
1163 if (STRINGP (string
))
1164 from_byte
= string_char_to_byte (string
, from_char
);
1166 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1167 args_out_of_range_3 (string
, make_number (from_char
),
1168 make_number (to_char
));
1170 if (STRINGP (string
))
1172 res
= make_specified_string (SSDATA (string
) + from_byte
,
1173 to_char
- from_char
, to_byte
- from_byte
,
1174 STRING_MULTIBYTE (string
));
1175 copy_text_properties (make_number (from_char
), make_number (to_char
),
1176 string
, make_number (0), res
, Qnil
);
1179 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1185 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1186 doc
: /* Return a substring of STRING, without text properties.
1187 It starts at index FROM and ends before TO.
1188 TO may be nil or omitted; then the substring runs to the end of STRING.
1189 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1190 If FROM or TO is negative, it counts from the end.
1192 With one argument, just copy STRING without its properties. */)
1193 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1195 EMACS_INT size
, size_byte
;
1196 EMACS_INT from_char
, to_char
;
1197 EMACS_INT from_byte
, to_byte
;
1199 CHECK_STRING (string
);
1201 size
= SCHARS (string
);
1202 size_byte
= SBYTES (string
);
1205 from_char
= from_byte
= 0;
1208 CHECK_NUMBER (from
);
1209 from_char
= XINT (from
);
1213 from_byte
= string_char_to_byte (string
, from_char
);
1219 to_byte
= size_byte
;
1225 to_char
= XINT (to
);
1229 to_byte
= string_char_to_byte (string
, to_char
);
1232 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1233 args_out_of_range_3 (string
, make_number (from_char
),
1234 make_number (to_char
));
1236 return make_specified_string (SSDATA (string
) + from_byte
,
1237 to_char
- from_char
, to_byte
- from_byte
,
1238 STRING_MULTIBYTE (string
));
1241 /* Extract a substring of STRING, giving start and end positions
1242 both in characters and in bytes. */
1245 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1246 EMACS_INT to
, EMACS_INT to_byte
)
1250 EMACS_INT size_byte
;
1252 CHECK_VECTOR_OR_STRING (string
);
1254 if (STRINGP (string
))
1256 size
= SCHARS (string
);
1257 size_byte
= SBYTES (string
);
1260 size
= ASIZE (string
);
1262 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1263 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1265 if (STRINGP (string
))
1267 res
= make_specified_string (SSDATA (string
) + from_byte
,
1268 to
- from
, to_byte
- from_byte
,
1269 STRING_MULTIBYTE (string
));
1270 copy_text_properties (make_number (from
), make_number (to
),
1271 string
, make_number (0), res
, Qnil
);
1274 res
= Fvector (to
- from
, &AREF (string
, from
));
1279 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1280 doc
: /* Take cdr N times on LIST, return the result. */)
1281 (Lisp_Object n
, Lisp_Object list
)
1283 register int i
, num
;
1286 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1289 CHECK_LIST_CONS (list
, list
);
1295 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1296 doc
: /* Return the Nth element of LIST.
1297 N counts from zero. If LIST is not that long, nil is returned. */)
1298 (Lisp_Object n
, Lisp_Object list
)
1300 return Fcar (Fnthcdr (n
, list
));
1303 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1304 doc
: /* Return element of SEQUENCE at index N. */)
1305 (register Lisp_Object sequence
, Lisp_Object n
)
1308 if (CONSP (sequence
) || NILP (sequence
))
1309 return Fcar (Fnthcdr (n
, sequence
));
1311 /* Faref signals a "not array" error, so check here. */
1312 CHECK_ARRAY (sequence
, Qsequencep
);
1313 return Faref (sequence
, n
);
1316 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1317 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1318 The value is actually the tail of LIST whose car is ELT. */)
1319 (register Lisp_Object elt
, Lisp_Object list
)
1321 register Lisp_Object tail
;
1322 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1324 register Lisp_Object tem
;
1325 CHECK_LIST_CONS (tail
, list
);
1327 if (! NILP (Fequal (elt
, tem
)))
1334 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1335 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1336 The value is actually the tail of LIST whose car is ELT. */)
1337 (register Lisp_Object elt
, Lisp_Object list
)
1341 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1345 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1349 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1360 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1361 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1362 The value is actually the tail of LIST whose car is ELT. */)
1363 (register Lisp_Object elt
, Lisp_Object list
)
1365 register Lisp_Object tail
;
1368 return Fmemq (elt
, list
);
1370 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1372 register Lisp_Object tem
;
1373 CHECK_LIST_CONS (tail
, list
);
1375 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1382 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1383 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1384 The value is actually the first element of LIST whose car is KEY.
1385 Elements of LIST that are not conses are ignored. */)
1386 (Lisp_Object key
, Lisp_Object list
)
1391 || (CONSP (XCAR (list
))
1392 && EQ (XCAR (XCAR (list
)), key
)))
1397 || (CONSP (XCAR (list
))
1398 && EQ (XCAR (XCAR (list
)), key
)))
1403 || (CONSP (XCAR (list
))
1404 && EQ (XCAR (XCAR (list
)), key
)))
1414 /* Like Fassq but never report an error and do not allow quits.
1415 Use only on lists known never to be circular. */
1418 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1421 && (!CONSP (XCAR (list
))
1422 || !EQ (XCAR (XCAR (list
)), key
)))
1425 return CAR_SAFE (list
);
1428 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1429 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1430 The value is actually the first element of LIST whose car equals KEY. */)
1431 (Lisp_Object key
, Lisp_Object list
)
1438 || (CONSP (XCAR (list
))
1439 && (car
= XCAR (XCAR (list
)),
1440 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1445 || (CONSP (XCAR (list
))
1446 && (car
= XCAR (XCAR (list
)),
1447 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1452 || (CONSP (XCAR (list
))
1453 && (car
= XCAR (XCAR (list
)),
1454 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1464 /* Like Fassoc but never report an error and do not allow quits.
1465 Use only on lists known never to be circular. */
1468 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1471 && (!CONSP (XCAR (list
))
1472 || (!EQ (XCAR (XCAR (list
)), key
)
1473 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1476 return CONSP (list
) ? XCAR (list
) : Qnil
;
1479 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1480 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1481 The value is actually the first element of LIST whose cdr is KEY. */)
1482 (register Lisp_Object key
, Lisp_Object list
)
1487 || (CONSP (XCAR (list
))
1488 && EQ (XCDR (XCAR (list
)), key
)))
1493 || (CONSP (XCAR (list
))
1494 && EQ (XCDR (XCAR (list
)), key
)))
1499 || (CONSP (XCAR (list
))
1500 && EQ (XCDR (XCAR (list
)), key
)))
1510 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1511 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1512 The value is actually the first element of LIST whose cdr equals KEY. */)
1513 (Lisp_Object key
, Lisp_Object list
)
1520 || (CONSP (XCAR (list
))
1521 && (cdr
= XCDR (XCAR (list
)),
1522 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1527 || (CONSP (XCAR (list
))
1528 && (cdr
= XCDR (XCAR (list
)),
1529 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (cdr
= XCDR (XCAR (list
)),
1536 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1546 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1547 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1548 The modified LIST is returned. Comparison is done with `eq'.
1549 If the first member of LIST is ELT, there is no way to remove it by side effect;
1550 therefore, write `(setq foo (delq element foo))'
1551 to be sure of changing the value of `foo'. */)
1552 (register Lisp_Object elt
, Lisp_Object list
)
1554 register Lisp_Object tail
, prev
;
1555 register Lisp_Object tem
;
1559 while (!NILP (tail
))
1561 CHECK_LIST_CONS (tail
, list
);
1568 Fsetcdr (prev
, XCDR (tail
));
1578 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1579 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1580 SEQ must be a list, a vector, or a string.
1581 The modified SEQ is returned. Comparison is done with `equal'.
1582 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1583 is not a side effect; it is simply using a different sequence.
1584 Therefore, write `(setq foo (delete element foo))'
1585 to be sure of changing the value of `foo'. */)
1586 (Lisp_Object elt
, Lisp_Object seq
)
1592 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1593 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1596 if (n
!= ASIZE (seq
))
1598 struct Lisp_Vector
*p
= allocate_vector (n
);
1600 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1601 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1602 p
->contents
[n
++] = AREF (seq
, i
);
1604 XSETVECTOR (seq
, p
);
1607 else if (STRINGP (seq
))
1609 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1612 for (i
= nchars
= nbytes
= ibyte
= 0;
1614 ++i
, ibyte
+= cbytes
)
1616 if (STRING_MULTIBYTE (seq
))
1618 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1619 cbytes
= CHAR_BYTES (c
);
1627 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1634 if (nchars
!= SCHARS (seq
))
1638 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1639 if (!STRING_MULTIBYTE (seq
))
1640 STRING_SET_UNIBYTE (tem
);
1642 for (i
= nchars
= nbytes
= ibyte
= 0;
1644 ++i
, ibyte
+= cbytes
)
1646 if (STRING_MULTIBYTE (seq
))
1648 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1649 cbytes
= CHAR_BYTES (c
);
1657 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1659 unsigned char *from
= SDATA (seq
) + ibyte
;
1660 unsigned char *to
= SDATA (tem
) + nbytes
;
1666 for (n
= cbytes
; n
--; )
1676 Lisp_Object tail
, prev
;
1678 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1680 CHECK_LIST_CONS (tail
, seq
);
1682 if (!NILP (Fequal (elt
, XCAR (tail
))))
1687 Fsetcdr (prev
, XCDR (tail
));
1698 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1699 doc
: /* Reverse LIST by modifying cdr pointers.
1700 Return the reversed list. */)
1703 register Lisp_Object prev
, tail
, next
;
1705 if (NILP (list
)) return list
;
1708 while (!NILP (tail
))
1711 CHECK_LIST_CONS (tail
, list
);
1713 Fsetcdr (tail
, prev
);
1720 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1721 doc
: /* Reverse LIST, copying. Return the reversed list.
1722 See also the function `nreverse', which is used more often. */)
1727 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1730 new = Fcons (XCAR (list
), new);
1732 CHECK_LIST_END (list
, list
);
1736 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1738 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1739 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1740 Returns the sorted list. LIST is modified by side effects.
1741 PREDICATE is called with two elements of LIST, and should return non-nil
1742 if the first element should sort before the second. */)
1743 (Lisp_Object list
, Lisp_Object predicate
)
1745 Lisp_Object front
, back
;
1746 register Lisp_Object len
, tem
;
1747 struct gcpro gcpro1
, gcpro2
;
1748 register int length
;
1751 len
= Flength (list
);
1752 length
= XINT (len
);
1756 XSETINT (len
, (length
/ 2) - 1);
1757 tem
= Fnthcdr (len
, list
);
1759 Fsetcdr (tem
, Qnil
);
1761 GCPRO2 (front
, back
);
1762 front
= Fsort (front
, predicate
);
1763 back
= Fsort (back
, predicate
);
1765 return merge (front
, back
, predicate
);
1769 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1772 register Lisp_Object tail
;
1774 register Lisp_Object l1
, l2
;
1775 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1782 /* It is sufficient to protect org_l1 and org_l2.
1783 When l1 and l2 are updated, we copy the new values
1784 back into the org_ vars. */
1785 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1805 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1821 Fsetcdr (tail
, tem
);
1827 /* This does not check for quits. That is safe since it must terminate. */
1829 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1830 doc
: /* Extract a value from a property list.
1831 PLIST is a property list, which is a list of the form
1832 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1833 corresponding to the given PROP, or nil if PROP is not one of the
1834 properties on the list. This function never signals an error. */)
1835 (Lisp_Object plist
, Lisp_Object prop
)
1837 Lisp_Object tail
, halftail
;
1839 /* halftail is used to detect circular lists. */
1840 tail
= halftail
= plist
;
1841 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1843 if (EQ (prop
, XCAR (tail
)))
1844 return XCAR (XCDR (tail
));
1846 tail
= XCDR (XCDR (tail
));
1847 halftail
= XCDR (halftail
);
1848 if (EQ (tail
, halftail
))
1851 #if 0 /* Unsafe version. */
1852 /* This function can be called asynchronously
1853 (setup_coding_system). Don't QUIT in that case. */
1854 if (!interrupt_input_blocked
)
1862 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1863 doc
: /* Return the value of SYMBOL's PROPNAME property.
1864 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1865 (Lisp_Object symbol
, Lisp_Object propname
)
1867 CHECK_SYMBOL (symbol
);
1868 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1871 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1872 doc
: /* Change value in PLIST of PROP to VAL.
1873 PLIST is a property list, which is a list of the form
1874 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1875 If PROP is already a property on the list, its value is set to VAL,
1876 otherwise the new PROP VAL pair is added. The new plist is returned;
1877 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1878 The PLIST is modified by side effects. */)
1879 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1881 register Lisp_Object tail
, prev
;
1882 Lisp_Object newcell
;
1884 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1885 tail
= XCDR (XCDR (tail
)))
1887 if (EQ (prop
, XCAR (tail
)))
1889 Fsetcar (XCDR (tail
), val
);
1896 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1900 Fsetcdr (XCDR (prev
), newcell
);
1904 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1905 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1906 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1907 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1909 CHECK_SYMBOL (symbol
);
1910 XSYMBOL (symbol
)->plist
1911 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1915 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1916 doc
: /* Extract a value from a property list, comparing with `equal'.
1917 PLIST is a property list, which is a list of the form
1918 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1919 corresponding to the given PROP, or nil if PROP is not
1920 one of the properties on the list. */)
1921 (Lisp_Object plist
, Lisp_Object prop
)
1926 CONSP (tail
) && CONSP (XCDR (tail
));
1927 tail
= XCDR (XCDR (tail
)))
1929 if (! NILP (Fequal (prop
, XCAR (tail
))))
1930 return XCAR (XCDR (tail
));
1935 CHECK_LIST_END (tail
, prop
);
1940 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1941 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1942 PLIST is a property list, which is a list of the form
1943 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1944 If PROP is already a property on the list, its value is set to VAL,
1945 otherwise the new PROP VAL pair is added. The new plist is returned;
1946 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1947 The PLIST is modified by side effects. */)
1948 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1950 register Lisp_Object tail
, prev
;
1951 Lisp_Object newcell
;
1953 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1954 tail
= XCDR (XCDR (tail
)))
1956 if (! NILP (Fequal (prop
, XCAR (tail
))))
1958 Fsetcar (XCDR (tail
), val
);
1965 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1969 Fsetcdr (XCDR (prev
), newcell
);
1973 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1974 doc
: /* Return t if the two args are the same Lisp object.
1975 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1976 (Lisp_Object obj1
, Lisp_Object obj2
)
1979 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1981 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1984 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1985 doc
: /* Return t if two Lisp objects have similar structure and contents.
1986 They must have the same data type.
1987 Conses are compared by comparing the cars and the cdrs.
1988 Vectors and strings are compared element by element.
1989 Numbers are compared by value, but integers cannot equal floats.
1990 (Use `=' if you want integers and floats to be able to be equal.)
1991 Symbols must match exactly. */)
1992 (register Lisp_Object o1
, Lisp_Object o2
)
1994 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1997 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1998 doc
: /* Return t if two Lisp objects have similar structure and contents.
1999 This is like `equal' except that it compares the text properties
2000 of strings. (`equal' ignores text properties.) */)
2001 (register Lisp_Object o1
, Lisp_Object o2
)
2003 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2006 /* DEPTH is current depth of recursion. Signal an error if it
2008 PROPS, if non-nil, means compare string text properties too. */
2011 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2014 error ("Stack overflow in equal");
2020 if (XTYPE (o1
) != XTYPE (o2
))
2029 d1
= extract_float (o1
);
2030 d2
= extract_float (o2
);
2031 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2032 though they are not =. */
2033 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2037 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2044 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2048 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2050 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2053 o1
= XOVERLAY (o1
)->plist
;
2054 o2
= XOVERLAY (o2
)->plist
;
2059 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2060 && (XMARKER (o1
)->buffer
== 0
2061 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2065 case Lisp_Vectorlike
:
2068 EMACS_INT size
= ASIZE (o1
);
2069 /* Pseudovectors have the type encoded in the size field, so this test
2070 actually checks that the objects have the same type as well as the
2072 if (ASIZE (o2
) != size
)
2074 /* Boolvectors are compared much like strings. */
2075 if (BOOL_VECTOR_P (o1
))
2078 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2079 / BOOL_VECTOR_BITS_PER_CHAR
);
2081 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2083 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2088 if (WINDOW_CONFIGURATIONP (o1
))
2089 return compare_window_configurations (o1
, o2
, 0);
2091 /* Aside from them, only true vectors, char-tables, compiled
2092 functions, and fonts (font-spec, font-entity, font-ojbect)
2093 are sensible to compare, so eliminate the others now. */
2094 if (size
& PSEUDOVECTOR_FLAG
)
2096 if (!(size
& (PVEC_COMPILED
2097 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2099 size
&= PSEUDOVECTOR_SIZE_MASK
;
2101 for (i
= 0; i
< size
; i
++)
2106 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2114 if (SCHARS (o1
) != SCHARS (o2
))
2116 if (SBYTES (o1
) != SBYTES (o2
))
2118 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2120 if (props
&& !compare_string_intervals (o1
, o2
))
2132 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2133 doc
: /* Store each element of ARRAY with ITEM.
2134 ARRAY is a vector, string, char-table, or bool-vector. */)
2135 (Lisp_Object array
, Lisp_Object item
)
2137 register EMACS_INT size
, idx
;
2140 if (VECTORP (array
))
2142 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2143 size
= ASIZE (array
);
2144 for (idx
= 0; idx
< size
; idx
++)
2147 else if (CHAR_TABLE_P (array
))
2151 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2152 XCHAR_TABLE (array
)->contents
[i
] = item
;
2153 XCHAR_TABLE (array
)->defalt
= item
;
2155 else if (STRINGP (array
))
2157 register unsigned char *p
= SDATA (array
);
2158 CHECK_NUMBER (item
);
2159 charval
= XINT (item
);
2160 size
= SCHARS (array
);
2161 if (STRING_MULTIBYTE (array
))
2163 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2164 int len
= CHAR_STRING (charval
, str
);
2165 EMACS_INT size_byte
= SBYTES (array
);
2166 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2169 if (size
!= size_byte
)
2172 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2173 if (len
!= this_len
)
2174 error ("Attempt to change byte length of a string");
2177 for (i
= 0; i
< size_byte
; i
++)
2178 *p
++ = str
[i
% len
];
2181 for (idx
= 0; idx
< size
; idx
++)
2184 else if (BOOL_VECTOR_P (array
))
2186 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2188 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2189 / BOOL_VECTOR_BITS_PER_CHAR
);
2191 charval
= (! NILP (item
) ? -1 : 0);
2192 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2194 if (idx
< size_in_chars
)
2196 /* Mask out bits beyond the vector size. */
2197 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2198 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2203 wrong_type_argument (Qarrayp
, array
);
2207 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2209 doc
: /* Clear the contents of STRING.
2210 This makes STRING unibyte and may change its length. */)
2211 (Lisp_Object string
)
2214 CHECK_STRING (string
);
2215 len
= SBYTES (string
);
2216 memset (SDATA (string
), 0, len
);
2217 STRING_SET_CHARS (string
, len
);
2218 STRING_SET_UNIBYTE (string
);
2224 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2226 Lisp_Object args
[2];
2229 return Fnconc (2, args
);
2232 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2233 doc
: /* Concatenate any number of lists by altering them.
2234 Only the last argument is not altered, and need not be a list.
2235 usage: (nconc &rest LISTS) */)
2236 (size_t nargs
, Lisp_Object
*args
)
2238 register size_t argnum
;
2239 register Lisp_Object tail
, tem
, val
;
2243 for (argnum
= 0; argnum
< nargs
; argnum
++)
2246 if (NILP (tem
)) continue;
2251 if (argnum
+ 1 == nargs
) break;
2253 CHECK_LIST_CONS (tem
, tem
);
2262 tem
= args
[argnum
+ 1];
2263 Fsetcdr (tail
, tem
);
2265 args
[argnum
+ 1] = tail
;
2271 /* This is the guts of all mapping functions.
2272 Apply FN to each element of SEQ, one by one,
2273 storing the results into elements of VALS, a C vector of Lisp_Objects.
2274 LENI is the length of VALS, which should also be the length of SEQ. */
2277 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2279 register Lisp_Object tail
;
2281 register EMACS_INT i
;
2282 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2286 /* Don't let vals contain any garbage when GC happens. */
2287 for (i
= 0; i
< leni
; i
++)
2290 GCPRO3 (dummy
, fn
, seq
);
2292 gcpro1
.nvars
= leni
;
2296 /* We need not explicitly protect `tail' because it is used only on lists, and
2297 1) lists are not relocated and 2) the list is marked via `seq' so will not
2302 for (i
= 0; i
< leni
; i
++)
2304 dummy
= call1 (fn
, AREF (seq
, i
));
2309 else if (BOOL_VECTOR_P (seq
))
2311 for (i
= 0; i
< leni
; i
++)
2314 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2315 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2316 dummy
= call1 (fn
, dummy
);
2321 else if (STRINGP (seq
))
2325 for (i
= 0, i_byte
= 0; i
< leni
;)
2328 EMACS_INT i_before
= i
;
2330 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2331 XSETFASTINT (dummy
, c
);
2332 dummy
= call1 (fn
, dummy
);
2334 vals
[i_before
] = dummy
;
2337 else /* Must be a list, since Flength did not get an error */
2340 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2342 dummy
= call1 (fn
, XCAR (tail
));
2352 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2353 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2354 In between each pair of results, stick in SEPARATOR. Thus, " " as
2355 SEPARATOR results in spaces between the values returned by FUNCTION.
2356 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2357 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2360 register EMACS_INT leni
;
2362 register Lisp_Object
*args
;
2363 register EMACS_INT i
;
2364 struct gcpro gcpro1
;
2368 len
= Flength (sequence
);
2369 if (CHAR_TABLE_P (sequence
))
2370 wrong_type_argument (Qlistp
, sequence
);
2372 nargs
= leni
+ leni
- 1;
2373 if (nargs
< 0) return empty_unibyte_string
;
2375 SAFE_ALLOCA_LISP (args
, nargs
);
2378 mapcar1 (leni
, args
, function
, sequence
);
2381 for (i
= leni
- 1; i
> 0; i
--)
2382 args
[i
+ i
] = args
[i
];
2384 for (i
= 1; i
< nargs
; i
+= 2)
2385 args
[i
] = separator
;
2387 ret
= Fconcat (nargs
, args
);
2393 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2394 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2395 The result is a list just as long as SEQUENCE.
2396 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2397 (Lisp_Object function
, Lisp_Object sequence
)
2399 register Lisp_Object len
;
2400 register EMACS_INT leni
;
2401 register Lisp_Object
*args
;
2405 len
= Flength (sequence
);
2406 if (CHAR_TABLE_P (sequence
))
2407 wrong_type_argument (Qlistp
, sequence
);
2408 leni
= XFASTINT (len
);
2410 SAFE_ALLOCA_LISP (args
, leni
);
2412 mapcar1 (leni
, args
, function
, sequence
);
2414 ret
= Flist (leni
, args
);
2420 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2421 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2422 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2423 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2424 (Lisp_Object function
, Lisp_Object sequence
)
2426 register EMACS_INT leni
;
2428 leni
= XFASTINT (Flength (sequence
));
2429 if (CHAR_TABLE_P (sequence
))
2430 wrong_type_argument (Qlistp
, sequence
);
2431 mapcar1 (leni
, 0, function
, sequence
);
2436 /* This is how C code calls `yes-or-no-p' and allows the user
2439 Anything that calls this function must protect from GC! */
2442 do_yes_or_no_p (Lisp_Object prompt
)
2444 return call1 (intern ("yes-or-no-p"), prompt
);
2447 /* Anything that calls this function must protect from GC! */
2449 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2450 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2451 PROMPT is the string to display to ask the question. It should end in
2452 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2454 The user must confirm the answer with RET, and can edit it until it
2457 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2458 is nil, and `use-dialog-box' is non-nil. */)
2459 (Lisp_Object prompt
)
2461 register Lisp_Object ans
;
2462 Lisp_Object args
[2];
2463 struct gcpro gcpro1
;
2465 CHECK_STRING (prompt
);
2468 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2469 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2473 Lisp_Object pane
, menu
, obj
;
2474 redisplay_preserve_echo_area (4);
2475 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2476 Fcons (Fcons (build_string ("No"), Qnil
),
2479 menu
= Fcons (prompt
, pane
);
2480 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2484 #endif /* HAVE_MENUS */
2487 args
[1] = build_string ("(yes or no) ");
2488 prompt
= Fconcat (2, args
);
2494 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2495 Qyes_or_no_p_history
, Qnil
,
2497 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2502 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2510 message ("Please answer yes or no.");
2511 Fsleep_for (make_number (2), Qnil
);
2515 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2516 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2518 Each of the three load averages is multiplied by 100, then converted
2521 When USE-FLOATS is non-nil, floats will be used instead of integers.
2522 These floats are not multiplied by 100.
2524 If the 5-minute or 15-minute load averages are not available, return a
2525 shortened list, containing only those averages which are available.
2527 An error is thrown if the load average can't be obtained. In some
2528 cases making it work would require Emacs being installed setuid or
2529 setgid so that it can read kernel information, and that usually isn't
2531 (Lisp_Object use_floats
)
2534 int loads
= getloadavg (load_ave
, 3);
2535 Lisp_Object ret
= Qnil
;
2538 error ("load-average not implemented for this operating system");
2542 Lisp_Object load
= (NILP (use_floats
) ?
2543 make_number ((int) (100.0 * load_ave
[loads
]))
2544 : make_float (load_ave
[loads
]));
2545 ret
= Fcons (load
, ret
);
2551 Lisp_Object Qsubfeatures
;
2553 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2554 doc
: /* Return t if FEATURE is present in this Emacs.
2556 Use this to conditionalize execution of lisp code based on the
2557 presence or absence of Emacs or environment extensions.
2558 Use `provide' to declare that a feature is available. This function
2559 looks at the value of the variable `features'. The optional argument
2560 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2561 (Lisp_Object feature
, Lisp_Object subfeature
)
2563 register Lisp_Object tem
;
2564 CHECK_SYMBOL (feature
);
2565 tem
= Fmemq (feature
, Vfeatures
);
2566 if (!NILP (tem
) && !NILP (subfeature
))
2567 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2568 return (NILP (tem
)) ? Qnil
: Qt
;
2571 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2572 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2573 The optional argument SUBFEATURES should be a list of symbols listing
2574 particular subfeatures supported in this version of FEATURE. */)
2575 (Lisp_Object feature
, Lisp_Object subfeatures
)
2577 register Lisp_Object tem
;
2578 CHECK_SYMBOL (feature
);
2579 CHECK_LIST (subfeatures
);
2580 if (!NILP (Vautoload_queue
))
2581 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2583 tem
= Fmemq (feature
, Vfeatures
);
2585 Vfeatures
= Fcons (feature
, Vfeatures
);
2586 if (!NILP (subfeatures
))
2587 Fput (feature
, Qsubfeatures
, subfeatures
);
2588 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2590 /* Run any load-hooks for this file. */
2591 tem
= Fassq (feature
, Vafter_load_alist
);
2593 Fprogn (XCDR (tem
));
2598 /* `require' and its subroutines. */
2600 /* List of features currently being require'd, innermost first. */
2602 static Lisp_Object require_nesting_list
;
2605 require_unwind (Lisp_Object old_value
)
2607 return require_nesting_list
= old_value
;
2610 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2611 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2612 If FEATURE is not a member of the list `features', then the feature
2613 is not loaded; so load the file FILENAME.
2614 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2615 and `load' will try to load this name appended with the suffix `.elc' or
2616 `.el', in that order. The name without appended suffix will not be used.
2617 If the optional third argument NOERROR is non-nil,
2618 then return nil if the file is not found instead of signaling an error.
2619 Normally the return value is FEATURE.
2620 The normal messages at start and end of loading FILENAME are suppressed. */)
2621 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2623 register Lisp_Object tem
;
2624 struct gcpro gcpro1
, gcpro2
;
2625 int from_file
= load_in_progress
;
2627 CHECK_SYMBOL (feature
);
2629 /* Record the presence of `require' in this file
2630 even if the feature specified is already loaded.
2631 But not more than once in any file,
2632 and not when we aren't loading or reading from a file. */
2634 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2635 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2640 tem
= Fcons (Qrequire
, feature
);
2641 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2642 LOADHIST_ATTACH (tem
);
2644 tem
= Fmemq (feature
, Vfeatures
);
2648 int count
= SPECPDL_INDEX ();
2651 /* This is to make sure that loadup.el gives a clear picture
2652 of what files are preloaded and when. */
2653 if (! NILP (Vpurify_flag
))
2654 error ("(require %s) while preparing to dump",
2655 SDATA (SYMBOL_NAME (feature
)));
2657 /* A certain amount of recursive `require' is legitimate,
2658 but if we require the same feature recursively 3 times,
2660 tem
= require_nesting_list
;
2661 while (! NILP (tem
))
2663 if (! NILP (Fequal (feature
, XCAR (tem
))))
2668 error ("Recursive `require' for feature `%s'",
2669 SDATA (SYMBOL_NAME (feature
)));
2671 /* Update the list for any nested `require's that occur. */
2672 record_unwind_protect (require_unwind
, require_nesting_list
);
2673 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2675 /* Value saved here is to be restored into Vautoload_queue */
2676 record_unwind_protect (un_autoload
, Vautoload_queue
);
2677 Vautoload_queue
= Qt
;
2679 /* Load the file. */
2680 GCPRO2 (feature
, filename
);
2681 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2682 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2685 /* If load failed entirely, return nil. */
2687 return unbind_to (count
, Qnil
);
2689 tem
= Fmemq (feature
, Vfeatures
);
2691 error ("Required feature `%s' was not provided",
2692 SDATA (SYMBOL_NAME (feature
)));
2694 /* Once loading finishes, don't undo it. */
2695 Vautoload_queue
= Qt
;
2696 feature
= unbind_to (count
, feature
);
2702 /* Primitives for work of the "widget" library.
2703 In an ideal world, this section would not have been necessary.
2704 However, lisp function calls being as slow as they are, it turns
2705 out that some functions in the widget library (wid-edit.el) are the
2706 bottleneck of Widget operation. Here is their translation to C,
2707 for the sole reason of efficiency. */
2709 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2710 doc
: /* Return non-nil if PLIST has the property PROP.
2711 PLIST is a property list, which is a list of the form
2712 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2713 Unlike `plist-get', this allows you to distinguish between a missing
2714 property and a property with the value nil.
2715 The value is actually the tail of PLIST whose car is PROP. */)
2716 (Lisp_Object plist
, Lisp_Object prop
)
2718 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2721 plist
= XCDR (plist
);
2722 plist
= CDR (plist
);
2727 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2728 doc
: /* In WIDGET, set PROPERTY to VALUE.
2729 The value can later be retrieved with `widget-get'. */)
2730 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2732 CHECK_CONS (widget
);
2733 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2737 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2738 doc
: /* In WIDGET, get the value of PROPERTY.
2739 The value could either be specified when the widget was created, or
2740 later with `widget-put'. */)
2741 (Lisp_Object widget
, Lisp_Object property
)
2749 CHECK_CONS (widget
);
2750 tmp
= Fplist_member (XCDR (widget
), property
);
2756 tmp
= XCAR (widget
);
2759 widget
= Fget (tmp
, Qwidget_type
);
2763 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2764 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2765 ARGS are passed as extra arguments to the function.
2766 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2767 (size_t nargs
, Lisp_Object
*args
)
2769 /* This function can GC. */
2770 Lisp_Object newargs
[3];
2771 struct gcpro gcpro1
, gcpro2
;
2774 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2775 newargs
[1] = args
[0];
2776 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2777 GCPRO2 (newargs
[0], newargs
[2]);
2778 result
= Fapply (3, newargs
);
2783 #ifdef HAVE_LANGINFO_CODESET
2784 #include <langinfo.h>
2787 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2788 doc
: /* Access locale data ITEM for the current C locale, if available.
2789 ITEM should be one of the following:
2791 `codeset', returning the character set as a string (locale item CODESET);
2793 `days', returning a 7-element vector of day names (locale items DAY_n);
2795 `months', returning a 12-element vector of month names (locale items MON_n);
2797 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2798 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2800 If the system can't provide such information through a call to
2801 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2803 See also Info node `(libc)Locales'.
2805 The data read from the system are decoded using `locale-coding-system'. */)
2809 #ifdef HAVE_LANGINFO_CODESET
2811 if (EQ (item
, Qcodeset
))
2813 str
= nl_langinfo (CODESET
);
2814 return build_string (str
);
2817 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2819 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2820 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2822 struct gcpro gcpro1
;
2824 synchronize_system_time_locale ();
2825 for (i
= 0; i
< 7; i
++)
2827 str
= nl_langinfo (days
[i
]);
2828 val
= make_unibyte_string (str
, strlen (str
));
2829 /* Fixme: Is this coding system necessarily right, even if
2830 it is consistent with CODESET? If not, what to do? */
2831 Faset (v
, make_number (i
),
2832 code_convert_string_norecord (val
, Vlocale_coding_system
,
2840 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2842 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2843 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2844 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2846 struct gcpro gcpro1
;
2848 synchronize_system_time_locale ();
2849 for (i
= 0; i
< 12; i
++)
2851 str
= nl_langinfo (months
[i
]);
2852 val
= make_unibyte_string (str
, strlen (str
));
2853 Faset (v
, make_number (i
),
2854 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2860 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2861 but is in the locale files. This could be used by ps-print. */
2863 else if (EQ (item
, Qpaper
))
2865 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2866 make_number (nl_langinfo (PAPER_HEIGHT
)));
2868 #endif /* PAPER_WIDTH */
2869 #endif /* HAVE_LANGINFO_CODESET*/
2873 /* base64 encode/decode functions (RFC 2045).
2874 Based on code from GNU recode. */
2876 #define MIME_LINE_LENGTH 76
2878 #define IS_ASCII(Character) \
2880 #define IS_BASE64(Character) \
2881 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2882 #define IS_BASE64_IGNORABLE(Character) \
2883 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2884 || (Character) == '\f' || (Character) == '\r')
2886 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2887 character or return retval if there are no characters left to
2889 #define READ_QUADRUPLET_BYTE(retval) \
2894 if (nchars_return) \
2895 *nchars_return = nchars; \
2900 while (IS_BASE64_IGNORABLE (c))
2902 /* Table of characters coding the 64 values. */
2903 static const char base64_value_to_char
[64] =
2905 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2906 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2907 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2908 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2909 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2910 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2911 '8', '9', '+', '/' /* 60-63 */
2914 /* Table of base64 values for first 128 characters. */
2915 static const short base64_char_to_value
[128] =
2917 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2918 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2920 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2921 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2922 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2923 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2924 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2925 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2926 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2927 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2928 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2929 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2932 /* The following diagram shows the logical steps by which three octets
2933 get transformed into four base64 characters.
2935 .--------. .--------. .--------.
2936 |aaaaaabb| |bbbbcccc| |ccdddddd|
2937 `--------' `--------' `--------'
2939 .--------+--------+--------+--------.
2940 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2941 `--------+--------+--------+--------'
2943 .--------+--------+--------+--------.
2944 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2945 `--------+--------+--------+--------'
2947 The octets are divided into 6 bit chunks, which are then encoded into
2948 base64 characters. */
2951 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2952 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2955 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2957 doc
: /* Base64-encode the region between BEG and END.
2958 Return the length of the encoded text.
2959 Optional third argument NO-LINE-BREAK means do not break long lines
2960 into shorter lines. */)
2961 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2964 EMACS_INT allength
, length
;
2965 EMACS_INT ibeg
, iend
, encoded_length
;
2966 EMACS_INT old_pos
= PT
;
2969 validate_region (&beg
, &end
);
2971 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2972 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2973 move_gap_both (XFASTINT (beg
), ibeg
);
2975 /* We need to allocate enough room for encoding the text.
2976 We need 33 1/3% more space, plus a newline every 76
2977 characters, and then we round up. */
2978 length
= iend
- ibeg
;
2979 allength
= length
+ length
/3 + 1;
2980 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2982 SAFE_ALLOCA (encoded
, char *, allength
);
2983 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2984 encoded
, length
, NILP (no_line_break
),
2985 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2986 if (encoded_length
> allength
)
2989 if (encoded_length
< 0)
2991 /* The encoding wasn't possible. */
2993 error ("Multibyte character in data for base64 encoding");
2996 /* Now we have encoded the region, so we insert the new contents
2997 and delete the old. (Insert first in order to preserve markers.) */
2998 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2999 insert (encoded
, encoded_length
);
3001 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3003 /* If point was outside of the region, restore it exactly; else just
3004 move to the beginning of the region. */
3005 if (old_pos
>= XFASTINT (end
))
3006 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3007 else if (old_pos
> XFASTINT (beg
))
3008 old_pos
= XFASTINT (beg
);
3011 /* We return the length of the encoded text. */
3012 return make_number (encoded_length
);
3015 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3017 doc
: /* Base64-encode STRING and return the result.
3018 Optional second argument NO-LINE-BREAK means do not break long lines
3019 into shorter lines. */)
3020 (Lisp_Object string
, Lisp_Object no_line_break
)
3022 EMACS_INT allength
, length
, encoded_length
;
3024 Lisp_Object encoded_string
;
3027 CHECK_STRING (string
);
3029 /* We need to allocate enough room for encoding the text.
3030 We need 33 1/3% more space, plus a newline every 76
3031 characters, and then we round up. */
3032 length
= SBYTES (string
);
3033 allength
= length
+ length
/3 + 1;
3034 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3036 /* We need to allocate enough room for decoding the text. */
3037 SAFE_ALLOCA (encoded
, char *, allength
);
3039 encoded_length
= base64_encode_1 (SSDATA (string
),
3040 encoded
, length
, NILP (no_line_break
),
3041 STRING_MULTIBYTE (string
));
3042 if (encoded_length
> allength
)
3045 if (encoded_length
< 0)
3047 /* The encoding wasn't possible. */
3049 error ("Multibyte character in data for base64 encoding");
3052 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3055 return encoded_string
;
3059 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3060 int line_break
, int multibyte
)
3073 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3074 if (CHAR_BYTE8_P (c
))
3075 c
= CHAR_TO_BYTE8 (c
);
3083 /* Wrap line every 76 characters. */
3087 if (counter
< MIME_LINE_LENGTH
/ 4)
3096 /* Process first byte of a triplet. */
3098 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3099 value
= (0x03 & c
) << 4;
3101 /* Process second byte of a triplet. */
3105 *e
++ = base64_value_to_char
[value
];
3113 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3114 if (CHAR_BYTE8_P (c
))
3115 c
= CHAR_TO_BYTE8 (c
);
3123 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3124 value
= (0x0f & c
) << 2;
3126 /* Process third byte of a triplet. */
3130 *e
++ = base64_value_to_char
[value
];
3137 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3138 if (CHAR_BYTE8_P (c
))
3139 c
= CHAR_TO_BYTE8 (c
);
3147 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3148 *e
++ = base64_value_to_char
[0x3f & c
];
3155 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3157 doc
: /* Base64-decode the region between BEG and END.
3158 Return the length of the decoded text.
3159 If the region can't be decoded, signal an error and don't modify the buffer. */)
3160 (Lisp_Object beg
, Lisp_Object end
)
3162 EMACS_INT ibeg
, iend
, length
, allength
;
3164 EMACS_INT old_pos
= PT
;
3165 EMACS_INT decoded_length
;
3166 EMACS_INT inserted_chars
;
3167 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3170 validate_region (&beg
, &end
);
3172 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3173 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3175 length
= iend
- ibeg
;
3177 /* We need to allocate enough room for decoding the text. If we are
3178 working on a multibyte buffer, each decoded code may occupy at
3180 allength
= multibyte
? length
* 2 : length
;
3181 SAFE_ALLOCA (decoded
, char *, allength
);
3183 move_gap_both (XFASTINT (beg
), ibeg
);
3184 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3186 multibyte
, &inserted_chars
);
3187 if (decoded_length
> allength
)
3190 if (decoded_length
< 0)
3192 /* The decoding wasn't possible. */
3194 error ("Invalid base64 data");
3197 /* Now we have decoded the region, so we insert the new contents
3198 and delete the old. (Insert first in order to preserve markers.) */
3199 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3200 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3203 /* Delete the original text. */
3204 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3205 iend
+ decoded_length
, 1);
3207 /* If point was outside of the region, restore it exactly; else just
3208 move to the beginning of the region. */
3209 if (old_pos
>= XFASTINT (end
))
3210 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3211 else if (old_pos
> XFASTINT (beg
))
3212 old_pos
= XFASTINT (beg
);
3213 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3215 return make_number (inserted_chars
);
3218 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3220 doc
: /* Base64-decode STRING and return the result. */)
3221 (Lisp_Object string
)
3224 EMACS_INT length
, decoded_length
;
3225 Lisp_Object decoded_string
;
3228 CHECK_STRING (string
);
3230 length
= SBYTES (string
);
3231 /* We need to allocate enough room for decoding the text. */
3232 SAFE_ALLOCA (decoded
, char *, length
);
3234 /* The decoded result should be unibyte. */
3235 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3237 if (decoded_length
> length
)
3239 else if (decoded_length
>= 0)
3240 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3242 decoded_string
= Qnil
;
3245 if (!STRINGP (decoded_string
))
3246 error ("Invalid base64 data");
3248 return decoded_string
;
3251 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3252 MULTIBYTE is nonzero, the decoded result should be in multibyte
3253 form. If NCHARS_RETRUN is not NULL, store the number of produced
3254 characters in *NCHARS_RETURN. */
3257 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3258 int multibyte
, EMACS_INT
*nchars_return
)
3260 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3263 unsigned long value
;
3264 EMACS_INT nchars
= 0;
3268 /* Process first byte of a quadruplet. */
3270 READ_QUADRUPLET_BYTE (e
-to
);
3274 value
= base64_char_to_value
[c
] << 18;
3276 /* Process second byte of a quadruplet. */
3278 READ_QUADRUPLET_BYTE (-1);
3282 value
|= base64_char_to_value
[c
] << 12;
3284 c
= (unsigned char) (value
>> 16);
3285 if (multibyte
&& c
>= 128)
3286 e
+= BYTE8_STRING (c
, e
);
3291 /* Process third byte of a quadruplet. */
3293 READ_QUADRUPLET_BYTE (-1);
3297 READ_QUADRUPLET_BYTE (-1);
3306 value
|= base64_char_to_value
[c
] << 6;
3308 c
= (unsigned char) (0xff & value
>> 8);
3309 if (multibyte
&& c
>= 128)
3310 e
+= BYTE8_STRING (c
, e
);
3315 /* Process fourth byte of a quadruplet. */
3317 READ_QUADRUPLET_BYTE (-1);
3324 value
|= base64_char_to_value
[c
];
3326 c
= (unsigned char) (0xff & value
);
3327 if (multibyte
&& c
>= 128)
3328 e
+= BYTE8_STRING (c
, e
);
3337 /***********************************************************************
3339 ***** Hash Tables *****
3341 ***********************************************************************/
3343 /* Implemented by gerd@gnu.org. This hash table implementation was
3344 inspired by CMUCL hash tables. */
3348 1. For small tables, association lists are probably faster than
3349 hash tables because they have lower overhead.
3351 For uses of hash tables where the O(1) behavior of table
3352 operations is not a requirement, it might therefore be a good idea
3353 not to hash. Instead, we could just do a linear search in the
3354 key_and_value vector of the hash table. This could be done
3355 if a `:linear-search t' argument is given to make-hash-table. */
3358 /* The list of all weak hash tables. Don't staticpro this one. */
3360 struct Lisp_Hash_Table
*weak_hash_tables
;
3362 /* Various symbols. */
3364 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3365 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3366 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3368 /* Function prototypes. */
3370 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3371 static size_t get_key_arg (Lisp_Object
, size_t, Lisp_Object
*, char *);
3372 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3373 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3374 Lisp_Object
, unsigned);
3375 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3376 Lisp_Object
, unsigned);
3377 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3378 unsigned, Lisp_Object
, unsigned);
3379 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3380 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3381 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3382 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3384 static unsigned sxhash_string (unsigned char *, int);
3385 static unsigned sxhash_list (Lisp_Object
, int);
3386 static unsigned sxhash_vector (Lisp_Object
, int);
3387 static unsigned sxhash_bool_vector (Lisp_Object
);
3388 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3392 /***********************************************************************
3394 ***********************************************************************/
3396 /* If OBJ is a Lisp hash table, return a pointer to its struct
3397 Lisp_Hash_Table. Otherwise, signal an error. */
3399 static struct Lisp_Hash_Table
*
3400 check_hash_table (Lisp_Object obj
)
3402 CHECK_HASH_TABLE (obj
);
3403 return XHASH_TABLE (obj
);
3407 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3411 next_almost_prime (int n
)
3423 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3424 which USED[I] is non-zero. If found at index I in ARGS, set
3425 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3426 0. This function is used to extract a keyword/argument pair from
3427 a DEFUN parameter list. */
3430 get_key_arg (Lisp_Object key
, size_t nargs
, Lisp_Object
*args
, char *used
)
3434 for (i
= 1; i
< nargs
; i
++)
3435 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3446 /* Return a Lisp vector which has the same contents as VEC but has
3447 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3448 vector that are not copied from VEC are set to INIT. */
3451 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3453 struct Lisp_Vector
*v
;
3456 xassert (VECTORP (vec
));
3457 old_size
= ASIZE (vec
);
3458 xassert (new_size
>= old_size
);
3460 v
= allocate_vector (new_size
);
3461 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3462 for (i
= old_size
; i
< new_size
; ++i
)
3463 v
->contents
[i
] = init
;
3464 XSETVECTOR (vec
, v
);
3469 /***********************************************************************
3471 ***********************************************************************/
3473 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3474 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3475 KEY2 are the same. */
3478 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3480 return (FLOATP (key1
)
3482 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3486 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3487 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3488 KEY2 are the same. */
3491 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3493 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3497 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3498 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3499 if KEY1 and KEY2 are the same. */
3502 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3506 Lisp_Object args
[3];
3508 args
[0] = h
->user_cmp_function
;
3511 return !NILP (Ffuncall (3, args
));
3518 /* Value is a hash code for KEY for use in hash table H which uses
3519 `eq' to compare keys. The hash code returned is guaranteed to fit
3520 in a Lisp integer. */
3523 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3525 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3526 xassert ((hash
& ~INTMASK
) == 0);
3531 /* Value is a hash code for KEY for use in hash table H which uses
3532 `eql' to compare keys. The hash code returned is guaranteed to fit
3533 in a Lisp integer. */
3536 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3540 hash
= sxhash (key
, 0);
3542 hash
= XUINT (key
) ^ XTYPE (key
);
3543 xassert ((hash
& ~INTMASK
) == 0);
3548 /* Value is a hash code for KEY for use in hash table H which uses
3549 `equal' to compare keys. The hash code returned is guaranteed to fit
3550 in a Lisp integer. */
3553 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3555 unsigned hash
= sxhash (key
, 0);
3556 xassert ((hash
& ~INTMASK
) == 0);
3561 /* Value is a hash code for KEY for use in hash table H which uses as
3562 user-defined function to compare keys. The hash code returned is
3563 guaranteed to fit in a Lisp integer. */
3566 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3568 Lisp_Object args
[2], hash
;
3570 args
[0] = h
->user_hash_function
;
3572 hash
= Ffuncall (2, args
);
3573 if (!INTEGERP (hash
))
3574 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3575 return XUINT (hash
);
3579 /* Create and initialize a new hash table.
3581 TEST specifies the test the hash table will use to compare keys.
3582 It must be either one of the predefined tests `eq', `eql' or
3583 `equal' or a symbol denoting a user-defined test named TEST with
3584 test and hash functions USER_TEST and USER_HASH.
3586 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3588 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3589 new size when it becomes full is computed by adding REHASH_SIZE to
3590 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3591 table's new size is computed by multiplying its old size with
3594 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3595 be resized when the ratio of (number of entries in the table) /
3596 (table size) is >= REHASH_THRESHOLD.
3598 WEAK specifies the weakness of the table. If non-nil, it must be
3599 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3602 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3603 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3604 Lisp_Object user_test
, Lisp_Object user_hash
)
3606 struct Lisp_Hash_Table
*h
;
3608 int index_size
, i
, sz
;
3610 /* Preconditions. */
3611 xassert (SYMBOLP (test
));
3612 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3613 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3614 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3615 xassert (FLOATP (rehash_threshold
)
3616 && XFLOATINT (rehash_threshold
) > 0
3617 && XFLOATINT (rehash_threshold
) <= 1.0);
3619 if (XFASTINT (size
) == 0)
3620 size
= make_number (1);
3622 /* Allocate a table and initialize it. */
3623 h
= allocate_hash_table ();
3625 /* Initialize hash table slots. */
3626 sz
= XFASTINT (size
);
3629 if (EQ (test
, Qeql
))
3631 h
->cmpfn
= cmpfn_eql
;
3632 h
->hashfn
= hashfn_eql
;
3634 else if (EQ (test
, Qeq
))
3637 h
->hashfn
= hashfn_eq
;
3639 else if (EQ (test
, Qequal
))
3641 h
->cmpfn
= cmpfn_equal
;
3642 h
->hashfn
= hashfn_equal
;
3646 h
->user_cmp_function
= user_test
;
3647 h
->user_hash_function
= user_hash
;
3648 h
->cmpfn
= cmpfn_user_defined
;
3649 h
->hashfn
= hashfn_user_defined
;
3653 h
->rehash_threshold
= rehash_threshold
;
3654 h
->rehash_size
= rehash_size
;
3656 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3657 h
->hash
= Fmake_vector (size
, Qnil
);
3658 h
->next
= Fmake_vector (size
, Qnil
);
3659 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3660 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3661 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3663 /* Set up the free list. */
3664 for (i
= 0; i
< sz
- 1; ++i
)
3665 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3666 h
->next_free
= make_number (0);
3668 XSET_HASH_TABLE (table
, h
);
3669 xassert (HASH_TABLE_P (table
));
3670 xassert (XHASH_TABLE (table
) == h
);
3672 /* Maybe add this hash table to the list of all weak hash tables. */
3674 h
->next_weak
= NULL
;
3677 h
->next_weak
= weak_hash_tables
;
3678 weak_hash_tables
= h
;
3685 /* Return a copy of hash table H1. Keys and values are not copied,
3686 only the table itself is. */
3689 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3692 struct Lisp_Hash_Table
*h2
;
3693 struct Lisp_Vector
*next
;
3695 h2
= allocate_hash_table ();
3696 next
= h2
->vec_next
;
3697 memcpy (h2
, h1
, sizeof *h2
);
3698 h2
->vec_next
= next
;
3699 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3700 h2
->hash
= Fcopy_sequence (h1
->hash
);
3701 h2
->next
= Fcopy_sequence (h1
->next
);
3702 h2
->index
= Fcopy_sequence (h1
->index
);
3703 XSET_HASH_TABLE (table
, h2
);
3705 /* Maybe add this hash table to the list of all weak hash tables. */
3706 if (!NILP (h2
->weak
))
3708 h2
->next_weak
= weak_hash_tables
;
3709 weak_hash_tables
= h2
;
3716 /* Resize hash table H if it's too full. If H cannot be resized
3717 because it's already too large, throw an error. */
3720 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3722 if (NILP (h
->next_free
))
3724 int old_size
= HASH_TABLE_SIZE (h
);
3725 int i
, new_size
, index_size
;
3728 if (INTEGERP (h
->rehash_size
))
3729 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3731 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3732 new_size
= max (old_size
+ 1, new_size
);
3733 index_size
= next_almost_prime ((int)
3735 / XFLOATINT (h
->rehash_threshold
)));
3736 /* Assignment to EMACS_INT stops GCC whining about limited range
3738 nsize
= max (index_size
, 2 * new_size
);
3739 if (nsize
> MOST_POSITIVE_FIXNUM
)
3740 error ("Hash table too large to resize");
3742 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3743 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3744 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3745 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3747 /* Update the free list. Do it so that new entries are added at
3748 the end of the free list. This makes some operations like
3750 for (i
= old_size
; i
< new_size
- 1; ++i
)
3751 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3753 if (!NILP (h
->next_free
))
3755 Lisp_Object last
, next
;
3757 last
= h
->next_free
;
3758 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3762 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3765 XSETFASTINT (h
->next_free
, old_size
);
3768 for (i
= 0; i
< old_size
; ++i
)
3769 if (!NILP (HASH_HASH (h
, i
)))
3771 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3772 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3773 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3774 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3780 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3781 the hash code of KEY. Value is the index of the entry in H
3782 matching KEY, or -1 if not found. */
3785 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3788 int start_of_bucket
;
3791 hash_code
= h
->hashfn (h
, key
);
3795 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3796 idx
= HASH_INDEX (h
, start_of_bucket
);
3798 /* We need not gcpro idx since it's either an integer or nil. */
3801 int i
= XFASTINT (idx
);
3802 if (EQ (key
, HASH_KEY (h
, i
))
3804 && h
->cmpfn (h
, key
, hash_code
,
3805 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3807 idx
= HASH_NEXT (h
, i
);
3810 return NILP (idx
) ? -1 : XFASTINT (idx
);
3814 /* Put an entry into hash table H that associates KEY with VALUE.
3815 HASH is a previously computed hash code of KEY.
3816 Value is the index of the entry in H matching KEY. */
3819 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3821 int start_of_bucket
, i
;
3823 xassert ((hash
& ~INTMASK
) == 0);
3825 /* Increment count after resizing because resizing may fail. */
3826 maybe_resize_hash_table (h
);
3829 /* Store key/value in the key_and_value vector. */
3830 i
= XFASTINT (h
->next_free
);
3831 h
->next_free
= HASH_NEXT (h
, i
);
3832 HASH_KEY (h
, i
) = key
;
3833 HASH_VALUE (h
, i
) = value
;
3835 /* Remember its hash code. */
3836 HASH_HASH (h
, i
) = make_number (hash
);
3838 /* Add new entry to its collision chain. */
3839 start_of_bucket
= hash
% ASIZE (h
->index
);
3840 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3841 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3846 /* Remove the entry matching KEY from hash table H, if there is one. */
3849 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3852 int start_of_bucket
;
3853 Lisp_Object idx
, prev
;
3855 hash_code
= h
->hashfn (h
, key
);
3856 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3857 idx
= HASH_INDEX (h
, start_of_bucket
);
3860 /* We need not gcpro idx, prev since they're either integers or nil. */
3863 int i
= XFASTINT (idx
);
3865 if (EQ (key
, HASH_KEY (h
, i
))
3867 && h
->cmpfn (h
, key
, hash_code
,
3868 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3870 /* Take entry out of collision chain. */
3872 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3874 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3876 /* Clear slots in key_and_value and add the slots to
3878 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3879 HASH_NEXT (h
, i
) = h
->next_free
;
3880 h
->next_free
= make_number (i
);
3882 xassert (h
->count
>= 0);
3888 idx
= HASH_NEXT (h
, i
);
3894 /* Clear hash table H. */
3897 hash_clear (struct Lisp_Hash_Table
*h
)
3901 int i
, size
= HASH_TABLE_SIZE (h
);
3903 for (i
= 0; i
< size
; ++i
)
3905 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3906 HASH_KEY (h
, i
) = Qnil
;
3907 HASH_VALUE (h
, i
) = Qnil
;
3908 HASH_HASH (h
, i
) = Qnil
;
3911 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3912 ASET (h
->index
, i
, Qnil
);
3914 h
->next_free
= make_number (0);
3921 /************************************************************************
3923 ************************************************************************/
3926 init_weak_hash_tables (void)
3928 weak_hash_tables
= NULL
;
3931 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3932 entries from the table that don't survive the current GC.
3933 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3934 non-zero if anything was marked. */
3937 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3939 int bucket
, n
, marked
;
3941 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3944 for (bucket
= 0; bucket
< n
; ++bucket
)
3946 Lisp_Object idx
, next
, prev
;
3948 /* Follow collision chain, removing entries that
3949 don't survive this garbage collection. */
3951 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3953 int i
= XFASTINT (idx
);
3954 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3955 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3958 if (EQ (h
->weak
, Qkey
))
3959 remove_p
= !key_known_to_survive_p
;
3960 else if (EQ (h
->weak
, Qvalue
))
3961 remove_p
= !value_known_to_survive_p
;
3962 else if (EQ (h
->weak
, Qkey_or_value
))
3963 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3964 else if (EQ (h
->weak
, Qkey_and_value
))
3965 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3969 next
= HASH_NEXT (h
, i
);
3971 if (remove_entries_p
)
3975 /* Take out of collision chain. */
3977 HASH_INDEX (h
, bucket
) = next
;
3979 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3981 /* Add to free list. */
3982 HASH_NEXT (h
, i
) = h
->next_free
;
3985 /* Clear key, value, and hash. */
3986 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3987 HASH_HASH (h
, i
) = Qnil
;
4000 /* Make sure key and value survive. */
4001 if (!key_known_to_survive_p
)
4003 mark_object (HASH_KEY (h
, i
));
4007 if (!value_known_to_survive_p
)
4009 mark_object (HASH_VALUE (h
, i
));
4020 /* Remove elements from weak hash tables that don't survive the
4021 current garbage collection. Remove weak tables that don't survive
4022 from Vweak_hash_tables. Called from gc_sweep. */
4025 sweep_weak_hash_tables (void)
4027 struct Lisp_Hash_Table
*h
, *used
, *next
;
4030 /* Mark all keys and values that are in use. Keep on marking until
4031 there is no more change. This is necessary for cases like
4032 value-weak table A containing an entry X -> Y, where Y is used in a
4033 key-weak table B, Z -> Y. If B comes after A in the list of weak
4034 tables, X -> Y might be removed from A, although when looking at B
4035 one finds that it shouldn't. */
4039 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4041 if (h
->size
& ARRAY_MARK_FLAG
)
4042 marked
|= sweep_weak_table (h
, 0);
4047 /* Remove tables and entries that aren't used. */
4048 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4050 next
= h
->next_weak
;
4052 if (h
->size
& ARRAY_MARK_FLAG
)
4054 /* TABLE is marked as used. Sweep its contents. */
4056 sweep_weak_table (h
, 1);
4058 /* Add table to the list of used weak hash tables. */
4059 h
->next_weak
= used
;
4064 weak_hash_tables
= used
;
4069 /***********************************************************************
4070 Hash Code Computation
4071 ***********************************************************************/
4073 /* Maximum depth up to which to dive into Lisp structures. */
4075 #define SXHASH_MAX_DEPTH 3
4077 /* Maximum length up to which to take list and vector elements into
4080 #define SXHASH_MAX_LEN 7
4082 /* Combine two integers X and Y for hashing. */
4084 #define SXHASH_COMBINE(X, Y) \
4085 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4089 /* Return a hash for string PTR which has length LEN. The hash
4090 code returned is guaranteed to fit in a Lisp integer. */
4093 sxhash_string (unsigned char *ptr
, int len
)
4095 unsigned char *p
= ptr
;
4096 unsigned char *end
= p
+ len
;
4105 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4108 return hash
& INTMASK
;
4112 /* Return a hash for list LIST. DEPTH is the current depth in the
4113 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4116 sxhash_list (Lisp_Object list
, int depth
)
4121 if (depth
< SXHASH_MAX_DEPTH
)
4123 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4124 list
= XCDR (list
), ++i
)
4126 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4127 hash
= SXHASH_COMBINE (hash
, hash2
);
4132 unsigned hash2
= sxhash (list
, depth
+ 1);
4133 hash
= SXHASH_COMBINE (hash
, hash2
);
4140 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4141 the Lisp structure. */
4144 sxhash_vector (Lisp_Object vec
, int depth
)
4146 unsigned hash
= ASIZE (vec
);
4149 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4150 for (i
= 0; i
< n
; ++i
)
4152 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4153 hash
= SXHASH_COMBINE (hash
, hash2
);
4160 /* Return a hash for bool-vector VECTOR. */
4163 sxhash_bool_vector (Lisp_Object vec
)
4165 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4168 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4169 for (i
= 0; i
< n
; ++i
)
4170 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4176 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4177 structure. Value is an unsigned integer clipped to INTMASK. */
4180 sxhash (Lisp_Object obj
, int depth
)
4184 if (depth
> SXHASH_MAX_DEPTH
)
4187 switch (XTYPE (obj
))
4198 obj
= SYMBOL_NAME (obj
);
4202 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4205 /* This can be everything from a vector to an overlay. */
4206 case Lisp_Vectorlike
:
4208 /* According to the CL HyperSpec, two arrays are equal only if
4209 they are `eq', except for strings and bit-vectors. In
4210 Emacs, this works differently. We have to compare element
4212 hash
= sxhash_vector (obj
, depth
);
4213 else if (BOOL_VECTOR_P (obj
))
4214 hash
= sxhash_bool_vector (obj
);
4216 /* Others are `equal' if they are `eq', so let's take their
4222 hash
= sxhash_list (obj
, depth
);
4227 double val
= XFLOAT_DATA (obj
);
4228 unsigned char *p
= (unsigned char *) &val
;
4229 unsigned char *e
= p
+ sizeof val
;
4230 for (hash
= 0; p
< e
; ++p
)
4231 hash
= SXHASH_COMBINE (hash
, *p
);
4239 return hash
& INTMASK
;
4244 /***********************************************************************
4246 ***********************************************************************/
4249 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4250 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4253 unsigned hash
= sxhash (obj
, 0);
4254 return make_number (hash
);
4258 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4259 doc
: /* Create and return a new hash table.
4261 Arguments are specified as keyword/argument pairs. The following
4262 arguments are defined:
4264 :test TEST -- TEST must be a symbol that specifies how to compare
4265 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4266 `equal'. User-supplied test and hash functions can be specified via
4267 `define-hash-table-test'.
4269 :size SIZE -- A hint as to how many elements will be put in the table.
4272 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4273 fills up. If REHASH-SIZE is an integer, increase the size by that
4274 amount. If it is a float, it must be > 1.0, and the new size is the
4275 old size multiplied by that factor. Default is 1.5.
4277 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4278 Resize the hash table when the ratio (number of entries / table size)
4279 is greater than or equal to THRESHOLD. Default is 0.8.
4281 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4282 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4283 returned is a weak table. Key/value pairs are removed from a weak
4284 hash table when there are no non-weak references pointing to their
4285 key, value, one of key or value, or both key and value, depending on
4286 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4289 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4290 (size_t nargs
, Lisp_Object
*args
)
4292 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4293 Lisp_Object user_test
, user_hash
;
4297 /* The vector `used' is used to keep track of arguments that
4298 have been consumed. */
4299 used
= (char *) alloca (nargs
* sizeof *used
);
4300 memset (used
, 0, nargs
* sizeof *used
);
4302 /* See if there's a `:test TEST' among the arguments. */
4303 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4304 test
= i
? args
[i
] : Qeql
;
4305 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4307 /* See if it is a user-defined test. */
4310 prop
= Fget (test
, Qhash_table_test
);
4311 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4312 signal_error ("Invalid hash table test", test
);
4313 user_test
= XCAR (prop
);
4314 user_hash
= XCAR (XCDR (prop
));
4317 user_test
= user_hash
= Qnil
;
4319 /* See if there's a `:size SIZE' argument. */
4320 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4321 size
= i
? args
[i
] : Qnil
;
4323 size
= make_number (DEFAULT_HASH_SIZE
);
4324 else if (!INTEGERP (size
) || XINT (size
) < 0)
4325 signal_error ("Invalid hash table size", size
);
4327 /* Look for `:rehash-size SIZE'. */
4328 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4329 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4330 if (!NUMBERP (rehash_size
)
4331 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4332 || XFLOATINT (rehash_size
) <= 1.0)
4333 signal_error ("Invalid hash table rehash size", rehash_size
);
4335 /* Look for `:rehash-threshold THRESHOLD'. */
4336 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4337 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4338 if (!FLOATP (rehash_threshold
)
4339 || XFLOATINT (rehash_threshold
) <= 0.0
4340 || XFLOATINT (rehash_threshold
) > 1.0)
4341 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4343 /* Look for `:weakness WEAK'. */
4344 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4345 weak
= i
? args
[i
] : Qnil
;
4347 weak
= Qkey_and_value
;
4350 && !EQ (weak
, Qvalue
)
4351 && !EQ (weak
, Qkey_or_value
)
4352 && !EQ (weak
, Qkey_and_value
))
4353 signal_error ("Invalid hash table weakness", weak
);
4355 /* Now, all args should have been used up, or there's a problem. */
4356 for (i
= 0; i
< nargs
; ++i
)
4358 signal_error ("Invalid argument list", args
[i
]);
4360 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4361 user_test
, user_hash
);
4365 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4366 doc
: /* Return a copy of hash table TABLE. */)
4369 return copy_hash_table (check_hash_table (table
));
4373 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4374 doc
: /* Return the number of elements in TABLE. */)
4377 return make_number (check_hash_table (table
)->count
);
4381 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4382 Shash_table_rehash_size
, 1, 1, 0,
4383 doc
: /* Return the current rehash size of TABLE. */)
4386 return check_hash_table (table
)->rehash_size
;
4390 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4391 Shash_table_rehash_threshold
, 1, 1, 0,
4392 doc
: /* Return the current rehash threshold of TABLE. */)
4395 return check_hash_table (table
)->rehash_threshold
;
4399 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4400 doc
: /* Return the size of TABLE.
4401 The size can be used as an argument to `make-hash-table' to create
4402 a hash table than can hold as many elements as TABLE holds
4403 without need for resizing. */)
4406 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4407 return make_number (HASH_TABLE_SIZE (h
));
4411 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4412 doc
: /* Return the test TABLE uses. */)
4415 return check_hash_table (table
)->test
;
4419 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4421 doc
: /* Return the weakness of TABLE. */)
4424 return check_hash_table (table
)->weak
;
4428 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4429 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4432 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4436 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4437 doc
: /* Clear hash table TABLE and return it. */)
4440 hash_clear (check_hash_table (table
));
4441 /* Be compatible with XEmacs. */
4446 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4447 doc
: /* Look up KEY in TABLE and return its associated value.
4448 If KEY is not found, return DFLT which defaults to nil. */)
4449 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4451 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4452 int i
= hash_lookup (h
, key
, NULL
);
4453 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4457 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4458 doc
: /* Associate KEY with VALUE in hash table TABLE.
4459 If KEY is already present in table, replace its current value with
4461 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4463 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4467 i
= hash_lookup (h
, key
, &hash
);
4469 HASH_VALUE (h
, i
) = value
;
4471 hash_put (h
, key
, value
, hash
);
4477 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4478 doc
: /* Remove KEY from TABLE. */)
4479 (Lisp_Object key
, Lisp_Object table
)
4481 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4482 hash_remove_from_table (h
, key
);
4487 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4488 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4489 FUNCTION is called with two arguments, KEY and VALUE. */)
4490 (Lisp_Object function
, Lisp_Object table
)
4492 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4493 Lisp_Object args
[3];
4496 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4497 if (!NILP (HASH_HASH (h
, i
)))
4500 args
[1] = HASH_KEY (h
, i
);
4501 args
[2] = HASH_VALUE (h
, i
);
4509 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4510 Sdefine_hash_table_test
, 3, 3, 0,
4511 doc
: /* Define a new hash table test with name NAME, a symbol.
4513 In hash tables created with NAME specified as test, use TEST to
4514 compare keys, and HASH for computing hash codes of keys.
4516 TEST must be a function taking two arguments and returning non-nil if
4517 both arguments are the same. HASH must be a function taking one
4518 argument and return an integer that is the hash code of the argument.
4519 Hash code computation should use the whole value range of integers,
4520 including negative integers. */)
4521 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4523 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4528 /************************************************************************
4530 ************************************************************************/
4534 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4535 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4537 A message digest is a cryptographic checksum of a document, and the
4538 algorithm to calculate it is defined in RFC 1321.
4540 The two optional arguments START and END are character positions
4541 specifying for which part of OBJECT the message digest should be
4542 computed. If nil or omitted, the digest is computed for the whole
4545 The MD5 message digest is computed from the result of encoding the
4546 text in a coding system, not directly from the internal Emacs form of
4547 the text. The optional fourth argument CODING-SYSTEM specifies which
4548 coding system to encode the text with. It should be the same coding
4549 system that you used or will use when actually writing the text into a
4552 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4553 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4554 system would be chosen by default for writing this text into a file.
4556 If OBJECT is a string, the most preferred coding system (see the
4557 command `prefer-coding-system') is used.
4559 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4560 guesswork fails. Normally, an error is signaled in such case. */)
4561 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4563 unsigned char digest
[16];
4567 EMACS_INT size_byte
= 0;
4568 EMACS_INT start_char
= 0, end_char
= 0;
4569 EMACS_INT start_byte
= 0, end_byte
= 0;
4570 register EMACS_INT b
, e
;
4571 register struct buffer
*bp
;
4574 if (STRINGP (object
))
4576 if (NILP (coding_system
))
4578 /* Decide the coding-system to encode the data with. */
4580 if (STRING_MULTIBYTE (object
))
4581 /* use default, we can't guess correct value */
4582 coding_system
= preferred_coding_system ();
4584 coding_system
= Qraw_text
;
4587 if (NILP (Fcoding_system_p (coding_system
)))
4589 /* Invalid coding system. */
4591 if (!NILP (noerror
))
4592 coding_system
= Qraw_text
;
4594 xsignal1 (Qcoding_system_error
, coding_system
);
4597 if (STRING_MULTIBYTE (object
))
4598 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4600 size
= SCHARS (object
);
4601 size_byte
= SBYTES (object
);
4605 CHECK_NUMBER (start
);
4607 start_char
= XINT (start
);
4612 start_byte
= string_char_to_byte (object
, start_char
);
4618 end_byte
= size_byte
;
4624 end_char
= XINT (end
);
4629 end_byte
= string_char_to_byte (object
, end_char
);
4632 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4633 args_out_of_range_3 (object
, make_number (start_char
),
4634 make_number (end_char
));
4638 struct buffer
*prev
= current_buffer
;
4640 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4642 CHECK_BUFFER (object
);
4644 bp
= XBUFFER (object
);
4645 if (bp
!= current_buffer
)
4646 set_buffer_internal (bp
);
4652 CHECK_NUMBER_COERCE_MARKER (start
);
4660 CHECK_NUMBER_COERCE_MARKER (end
);
4665 temp
= b
, b
= e
, e
= temp
;
4667 if (!(BEGV
<= b
&& e
<= ZV
))
4668 args_out_of_range (start
, end
);
4670 if (NILP (coding_system
))
4672 /* Decide the coding-system to encode the data with.
4673 See fileio.c:Fwrite-region */
4675 if (!NILP (Vcoding_system_for_write
))
4676 coding_system
= Vcoding_system_for_write
;
4679 int force_raw_text
= 0;
4681 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4682 if (NILP (coding_system
)
4683 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4685 coding_system
= Qnil
;
4686 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4690 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4692 /* Check file-coding-system-alist. */
4693 Lisp_Object args
[4], val
;
4695 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4696 args
[3] = Fbuffer_file_name(object
);
4697 val
= Ffind_operation_coding_system (4, args
);
4698 if (CONSP (val
) && !NILP (XCDR (val
)))
4699 coding_system
= XCDR (val
);
4702 if (NILP (coding_system
)
4703 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4705 /* If we still have not decided a coding system, use the
4706 default value of buffer-file-coding-system. */
4707 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4711 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4712 /* Confirm that VAL can surely encode the current region. */
4713 coding_system
= call4 (Vselect_safe_coding_system_function
,
4714 make_number (b
), make_number (e
),
4715 coding_system
, Qnil
);
4718 coding_system
= Qraw_text
;
4721 if (NILP (Fcoding_system_p (coding_system
)))
4723 /* Invalid coding system. */
4725 if (!NILP (noerror
))
4726 coding_system
= Qraw_text
;
4728 xsignal1 (Qcoding_system_error
, coding_system
);
4732 object
= make_buffer_string (b
, e
, 0);
4733 if (prev
!= current_buffer
)
4734 set_buffer_internal (prev
);
4735 /* Discard the unwind protect for recovering the current
4739 if (STRING_MULTIBYTE (object
))
4740 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4743 md5_buffer (SSDATA (object
) + start_byte
,
4744 SBYTES (object
) - (size_byte
- end_byte
),
4747 for (i
= 0; i
< 16; i
++)
4748 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4751 return make_string (value
, 32);
4758 /* Hash table stuff. */
4759 Qhash_table_p
= intern_c_string ("hash-table-p");
4760 staticpro (&Qhash_table_p
);
4761 Qeq
= intern_c_string ("eq");
4763 Qeql
= intern_c_string ("eql");
4765 Qequal
= intern_c_string ("equal");
4766 staticpro (&Qequal
);
4767 QCtest
= intern_c_string (":test");
4768 staticpro (&QCtest
);
4769 QCsize
= intern_c_string (":size");
4770 staticpro (&QCsize
);
4771 QCrehash_size
= intern_c_string (":rehash-size");
4772 staticpro (&QCrehash_size
);
4773 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4774 staticpro (&QCrehash_threshold
);
4775 QCweakness
= intern_c_string (":weakness");
4776 staticpro (&QCweakness
);
4777 Qkey
= intern_c_string ("key");
4779 Qvalue
= intern_c_string ("value");
4780 staticpro (&Qvalue
);
4781 Qhash_table_test
= intern_c_string ("hash-table-test");
4782 staticpro (&Qhash_table_test
);
4783 Qkey_or_value
= intern_c_string ("key-or-value");
4784 staticpro (&Qkey_or_value
);
4785 Qkey_and_value
= intern_c_string ("key-and-value");
4786 staticpro (&Qkey_and_value
);
4789 defsubr (&Smake_hash_table
);
4790 defsubr (&Scopy_hash_table
);
4791 defsubr (&Shash_table_count
);
4792 defsubr (&Shash_table_rehash_size
);
4793 defsubr (&Shash_table_rehash_threshold
);
4794 defsubr (&Shash_table_size
);
4795 defsubr (&Shash_table_test
);
4796 defsubr (&Shash_table_weakness
);
4797 defsubr (&Shash_table_p
);
4798 defsubr (&Sclrhash
);
4799 defsubr (&Sgethash
);
4800 defsubr (&Sputhash
);
4801 defsubr (&Sremhash
);
4802 defsubr (&Smaphash
);
4803 defsubr (&Sdefine_hash_table_test
);
4805 Qstring_lessp
= intern_c_string ("string-lessp");
4806 staticpro (&Qstring_lessp
);
4807 Qprovide
= intern_c_string ("provide");
4808 staticpro (&Qprovide
);
4809 Qrequire
= intern_c_string ("require");
4810 staticpro (&Qrequire
);
4811 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4812 staticpro (&Qyes_or_no_p_history
);
4813 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4814 staticpro (&Qcursor_in_echo_area
);
4815 Qwidget_type
= intern_c_string ("widget-type");
4816 staticpro (&Qwidget_type
);
4818 staticpro (&string_char_byte_cache_string
);
4819 string_char_byte_cache_string
= Qnil
;
4821 require_nesting_list
= Qnil
;
4822 staticpro (&require_nesting_list
);
4824 Fset (Qyes_or_no_p_history
, Qnil
);
4826 DEFVAR_LISP ("features", Vfeatures
,
4827 doc
: /* A list of symbols which are the features of the executing Emacs.
4828 Used by `featurep' and `require', and altered by `provide'. */);
4829 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4830 Qsubfeatures
= intern_c_string ("subfeatures");
4831 staticpro (&Qsubfeatures
);
4833 #ifdef HAVE_LANGINFO_CODESET
4834 Qcodeset
= intern_c_string ("codeset");
4835 staticpro (&Qcodeset
);
4836 Qdays
= intern_c_string ("days");
4838 Qmonths
= intern_c_string ("months");
4839 staticpro (&Qmonths
);
4840 Qpaper
= intern_c_string ("paper");
4841 staticpro (&Qpaper
);
4842 #endif /* HAVE_LANGINFO_CODESET */
4844 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4845 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4846 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4847 invoked by mouse clicks and mouse menu items.
4849 On some platforms, file selection dialogs are also enabled if this is
4853 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4854 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4855 This applies to commands from menus and tool bar buttons even when
4856 they are initiated from the keyboard. If `use-dialog-box' is nil,
4857 that disables the use of a file dialog, regardless of the value of
4859 use_file_dialog
= 1;
4861 defsubr (&Sidentity
);
4864 defsubr (&Ssafe_length
);
4865 defsubr (&Sstring_bytes
);
4866 defsubr (&Sstring_equal
);
4867 defsubr (&Scompare_strings
);
4868 defsubr (&Sstring_lessp
);
4871 defsubr (&Svconcat
);
4872 defsubr (&Scopy_sequence
);
4873 defsubr (&Sstring_make_multibyte
);
4874 defsubr (&Sstring_make_unibyte
);
4875 defsubr (&Sstring_as_multibyte
);
4876 defsubr (&Sstring_as_unibyte
);
4877 defsubr (&Sstring_to_multibyte
);
4878 defsubr (&Sstring_to_unibyte
);
4879 defsubr (&Scopy_alist
);
4880 defsubr (&Ssubstring
);
4881 defsubr (&Ssubstring_no_properties
);
4894 defsubr (&Snreverse
);
4895 defsubr (&Sreverse
);
4897 defsubr (&Splist_get
);
4899 defsubr (&Splist_put
);
4901 defsubr (&Slax_plist_get
);
4902 defsubr (&Slax_plist_put
);
4905 defsubr (&Sequal_including_properties
);
4906 defsubr (&Sfillarray
);
4907 defsubr (&Sclear_string
);
4911 defsubr (&Smapconcat
);
4912 defsubr (&Syes_or_no_p
);
4913 defsubr (&Sload_average
);
4914 defsubr (&Sfeaturep
);
4915 defsubr (&Srequire
);
4916 defsubr (&Sprovide
);
4917 defsubr (&Splist_member
);
4918 defsubr (&Swidget_put
);
4919 defsubr (&Swidget_get
);
4920 defsubr (&Swidget_apply
);
4921 defsubr (&Sbase64_encode_region
);
4922 defsubr (&Sbase64_decode_region
);
4923 defsubr (&Sbase64_encode_string
);
4924 defsubr (&Sbase64_decode_string
);
4926 defsubr (&Slocale_info
);