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
;
513 if (VECTORP (this) || COMPILEDP (this))
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
)
1080 long lconverted
= converted
;
1081 error ("Can't convert the %ldth character to unibyte", lconverted
);
1083 string
= make_unibyte_string ((char *) str
, chars
);
1090 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1091 doc
: /* Return a copy of ALIST.
1092 This is an alist which represents the same mapping from objects to objects,
1093 but does not share the alist structure with ALIST.
1094 The objects mapped (cars and cdrs of elements of the alist)
1095 are shared, however.
1096 Elements of ALIST that are not conses are also shared. */)
1099 register Lisp_Object tem
;
1104 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1105 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1107 register Lisp_Object car
;
1111 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1116 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1117 doc
: /* Return a new string whose contents are a substring of STRING.
1118 The returned string consists of the characters between index FROM
1119 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1120 zero-indexed: 0 means the first character of STRING. Negative values
1121 are counted from the end of STRING. If TO is nil, the substring runs
1122 to the end of STRING.
1124 The STRING argument may also be a vector. In that case, the return
1125 value is a new vector that contains the elements between index FROM
1126 \(inclusive) and index TO (exclusive) of that vector argument. */)
1127 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1131 EMACS_INT size_byte
= 0;
1132 EMACS_INT from_char
, to_char
;
1133 EMACS_INT from_byte
= 0, to_byte
= 0;
1135 CHECK_VECTOR_OR_STRING (string
);
1136 CHECK_NUMBER (from
);
1138 if (STRINGP (string
))
1140 size
= SCHARS (string
);
1141 size_byte
= SBYTES (string
);
1144 size
= ASIZE (string
);
1149 to_byte
= size_byte
;
1155 to_char
= XINT (to
);
1159 if (STRINGP (string
))
1160 to_byte
= string_char_to_byte (string
, to_char
);
1163 from_char
= XINT (from
);
1166 if (STRINGP (string
))
1167 from_byte
= string_char_to_byte (string
, from_char
);
1169 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1170 args_out_of_range_3 (string
, make_number (from_char
),
1171 make_number (to_char
));
1173 if (STRINGP (string
))
1175 res
= make_specified_string (SSDATA (string
) + from_byte
,
1176 to_char
- from_char
, to_byte
- from_byte
,
1177 STRING_MULTIBYTE (string
));
1178 copy_text_properties (make_number (from_char
), make_number (to_char
),
1179 string
, make_number (0), res
, Qnil
);
1182 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1188 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1189 doc
: /* Return a substring of STRING, without text properties.
1190 It starts at index FROM and ends before TO.
1191 TO may be nil or omitted; then the substring runs to the end of STRING.
1192 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1193 If FROM or TO is negative, it counts from the end.
1195 With one argument, just copy STRING without its properties. */)
1196 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1198 EMACS_INT size
, size_byte
;
1199 EMACS_INT from_char
, to_char
;
1200 EMACS_INT from_byte
, to_byte
;
1202 CHECK_STRING (string
);
1204 size
= SCHARS (string
);
1205 size_byte
= SBYTES (string
);
1208 from_char
= from_byte
= 0;
1211 CHECK_NUMBER (from
);
1212 from_char
= XINT (from
);
1216 from_byte
= string_char_to_byte (string
, from_char
);
1222 to_byte
= size_byte
;
1228 to_char
= XINT (to
);
1232 to_byte
= string_char_to_byte (string
, to_char
);
1235 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1236 args_out_of_range_3 (string
, make_number (from_char
),
1237 make_number (to_char
));
1239 return make_specified_string (SSDATA (string
) + from_byte
,
1240 to_char
- from_char
, to_byte
- from_byte
,
1241 STRING_MULTIBYTE (string
));
1244 /* Extract a substring of STRING, giving start and end positions
1245 both in characters and in bytes. */
1248 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1249 EMACS_INT to
, EMACS_INT to_byte
)
1254 CHECK_VECTOR_OR_STRING (string
);
1256 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1258 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1259 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1261 if (STRINGP (string
))
1263 res
= make_specified_string (SSDATA (string
) + from_byte
,
1264 to
- from
, to_byte
- from_byte
,
1265 STRING_MULTIBYTE (string
));
1266 copy_text_properties (make_number (from
), make_number (to
),
1267 string
, make_number (0), res
, Qnil
);
1270 res
= Fvector (to
- from
, &AREF (string
, from
));
1275 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1276 doc
: /* Take cdr N times on LIST, return the result. */)
1277 (Lisp_Object n
, Lisp_Object list
)
1279 register int i
, num
;
1282 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1285 CHECK_LIST_CONS (list
, list
);
1291 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1292 doc
: /* Return the Nth element of LIST.
1293 N counts from zero. If LIST is not that long, nil is returned. */)
1294 (Lisp_Object n
, Lisp_Object list
)
1296 return Fcar (Fnthcdr (n
, list
));
1299 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1300 doc
: /* Return element of SEQUENCE at index N. */)
1301 (register Lisp_Object sequence
, Lisp_Object n
)
1304 if (CONSP (sequence
) || NILP (sequence
))
1305 return Fcar (Fnthcdr (n
, sequence
));
1307 /* Faref signals a "not array" error, so check here. */
1308 CHECK_ARRAY (sequence
, Qsequencep
);
1309 return Faref (sequence
, n
);
1312 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1313 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1314 The value is actually the tail of LIST whose car is ELT. */)
1315 (register Lisp_Object elt
, Lisp_Object list
)
1317 register Lisp_Object tail
;
1318 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1320 register Lisp_Object tem
;
1321 CHECK_LIST_CONS (tail
, list
);
1323 if (! NILP (Fequal (elt
, tem
)))
1330 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1331 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1332 The value is actually the tail of LIST whose car is ELT. */)
1333 (register Lisp_Object elt
, Lisp_Object list
)
1337 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1341 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1345 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1356 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1357 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1358 The value is actually the tail of LIST whose car is ELT. */)
1359 (register Lisp_Object elt
, Lisp_Object list
)
1361 register Lisp_Object tail
;
1364 return Fmemq (elt
, list
);
1366 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1368 register Lisp_Object tem
;
1369 CHECK_LIST_CONS (tail
, list
);
1371 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1378 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1379 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1380 The value is actually the first element of LIST whose car is KEY.
1381 Elements of LIST that are not conses are ignored. */)
1382 (Lisp_Object key
, Lisp_Object list
)
1387 || (CONSP (XCAR (list
))
1388 && EQ (XCAR (XCAR (list
)), key
)))
1393 || (CONSP (XCAR (list
))
1394 && EQ (XCAR (XCAR (list
)), key
)))
1399 || (CONSP (XCAR (list
))
1400 && EQ (XCAR (XCAR (list
)), key
)))
1410 /* Like Fassq but never report an error and do not allow quits.
1411 Use only on lists known never to be circular. */
1414 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1417 && (!CONSP (XCAR (list
))
1418 || !EQ (XCAR (XCAR (list
)), key
)))
1421 return CAR_SAFE (list
);
1424 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1425 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1426 The value is actually the first element of LIST whose car equals KEY. */)
1427 (Lisp_Object key
, Lisp_Object list
)
1434 || (CONSP (XCAR (list
))
1435 && (car
= XCAR (XCAR (list
)),
1436 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1441 || (CONSP (XCAR (list
))
1442 && (car
= XCAR (XCAR (list
)),
1443 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1448 || (CONSP (XCAR (list
))
1449 && (car
= XCAR (XCAR (list
)),
1450 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1460 /* Like Fassoc but never report an error and do not allow quits.
1461 Use only on lists known never to be circular. */
1464 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1467 && (!CONSP (XCAR (list
))
1468 || (!EQ (XCAR (XCAR (list
)), key
)
1469 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1472 return CONSP (list
) ? XCAR (list
) : Qnil
;
1475 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1476 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1477 The value is actually the first element of LIST whose cdr is KEY. */)
1478 (register Lisp_Object key
, Lisp_Object list
)
1483 || (CONSP (XCAR (list
))
1484 && EQ (XCDR (XCAR (list
)), key
)))
1489 || (CONSP (XCAR (list
))
1490 && EQ (XCDR (XCAR (list
)), key
)))
1495 || (CONSP (XCAR (list
))
1496 && EQ (XCDR (XCAR (list
)), key
)))
1506 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1507 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1508 The value is actually the first element of LIST whose cdr equals KEY. */)
1509 (Lisp_Object key
, Lisp_Object list
)
1516 || (CONSP (XCAR (list
))
1517 && (cdr
= XCDR (XCAR (list
)),
1518 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1523 || (CONSP (XCAR (list
))
1524 && (cdr
= XCDR (XCAR (list
)),
1525 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1530 || (CONSP (XCAR (list
))
1531 && (cdr
= XCDR (XCAR (list
)),
1532 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1542 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1543 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1544 The modified LIST is returned. Comparison is done with `eq'.
1545 If the first member of LIST is ELT, there is no way to remove it by side effect;
1546 therefore, write `(setq foo (delq element foo))'
1547 to be sure of changing the value of `foo'. */)
1548 (register Lisp_Object elt
, Lisp_Object list
)
1550 register Lisp_Object tail
, prev
;
1551 register Lisp_Object tem
;
1555 while (!NILP (tail
))
1557 CHECK_LIST_CONS (tail
, list
);
1564 Fsetcdr (prev
, XCDR (tail
));
1574 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1575 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1576 SEQ must be a list, a vector, or a string.
1577 The modified SEQ is returned. Comparison is done with `equal'.
1578 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1579 is not a side effect; it is simply using a different sequence.
1580 Therefore, write `(setq foo (delete element foo))'
1581 to be sure of changing the value of `foo'. */)
1582 (Lisp_Object elt
, Lisp_Object seq
)
1588 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1589 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1592 if (n
!= ASIZE (seq
))
1594 struct Lisp_Vector
*p
= allocate_vector (n
);
1596 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1597 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1598 p
->contents
[n
++] = AREF (seq
, i
);
1600 XSETVECTOR (seq
, p
);
1603 else if (STRINGP (seq
))
1605 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1608 for (i
= nchars
= nbytes
= ibyte
= 0;
1610 ++i
, ibyte
+= cbytes
)
1612 if (STRING_MULTIBYTE (seq
))
1614 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1615 cbytes
= CHAR_BYTES (c
);
1623 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1630 if (nchars
!= SCHARS (seq
))
1634 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1635 if (!STRING_MULTIBYTE (seq
))
1636 STRING_SET_UNIBYTE (tem
);
1638 for (i
= nchars
= nbytes
= ibyte
= 0;
1640 ++i
, ibyte
+= cbytes
)
1642 if (STRING_MULTIBYTE (seq
))
1644 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1645 cbytes
= CHAR_BYTES (c
);
1653 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1655 unsigned char *from
= SDATA (seq
) + ibyte
;
1656 unsigned char *to
= SDATA (tem
) + nbytes
;
1662 for (n
= cbytes
; n
--; )
1672 Lisp_Object tail
, prev
;
1674 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1676 CHECK_LIST_CONS (tail
, seq
);
1678 if (!NILP (Fequal (elt
, XCAR (tail
))))
1683 Fsetcdr (prev
, XCDR (tail
));
1694 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1695 doc
: /* Reverse LIST by modifying cdr pointers.
1696 Return the reversed list. */)
1699 register Lisp_Object prev
, tail
, next
;
1701 if (NILP (list
)) return list
;
1704 while (!NILP (tail
))
1707 CHECK_LIST_CONS (tail
, list
);
1709 Fsetcdr (tail
, prev
);
1716 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1717 doc
: /* Reverse LIST, copying. Return the reversed list.
1718 See also the function `nreverse', which is used more often. */)
1723 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1726 new = Fcons (XCAR (list
), new);
1728 CHECK_LIST_END (list
, list
);
1732 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1734 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1735 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1736 Returns the sorted list. LIST is modified by side effects.
1737 PREDICATE is called with two elements of LIST, and should return non-nil
1738 if the first element should sort before the second. */)
1739 (Lisp_Object list
, Lisp_Object predicate
)
1741 Lisp_Object front
, back
;
1742 register Lisp_Object len
, tem
;
1743 struct gcpro gcpro1
, gcpro2
;
1744 register int length
;
1747 len
= Flength (list
);
1748 length
= XINT (len
);
1752 XSETINT (len
, (length
/ 2) - 1);
1753 tem
= Fnthcdr (len
, list
);
1755 Fsetcdr (tem
, Qnil
);
1757 GCPRO2 (front
, back
);
1758 front
= Fsort (front
, predicate
);
1759 back
= Fsort (back
, predicate
);
1761 return merge (front
, back
, predicate
);
1765 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1768 register Lisp_Object tail
;
1770 register Lisp_Object l1
, l2
;
1771 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1778 /* It is sufficient to protect org_l1 and org_l2.
1779 When l1 and l2 are updated, we copy the new values
1780 back into the org_ vars. */
1781 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1801 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1817 Fsetcdr (tail
, tem
);
1823 /* This does not check for quits. That is safe since it must terminate. */
1825 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1826 doc
: /* Extract a value from a property list.
1827 PLIST is a property list, which is a list of the form
1828 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1829 corresponding to the given PROP, or nil if PROP is not one of the
1830 properties on the list. This function never signals an error. */)
1831 (Lisp_Object plist
, Lisp_Object prop
)
1833 Lisp_Object tail
, halftail
;
1835 /* halftail is used to detect circular lists. */
1836 tail
= halftail
= plist
;
1837 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1839 if (EQ (prop
, XCAR (tail
)))
1840 return XCAR (XCDR (tail
));
1842 tail
= XCDR (XCDR (tail
));
1843 halftail
= XCDR (halftail
);
1844 if (EQ (tail
, halftail
))
1847 #if 0 /* Unsafe version. */
1848 /* This function can be called asynchronously
1849 (setup_coding_system). Don't QUIT in that case. */
1850 if (!interrupt_input_blocked
)
1858 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1859 doc
: /* Return the value of SYMBOL's PROPNAME property.
1860 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1861 (Lisp_Object symbol
, Lisp_Object propname
)
1863 CHECK_SYMBOL (symbol
);
1864 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1867 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1868 doc
: /* Change value in PLIST of PROP to VAL.
1869 PLIST is a property list, which is a list of the form
1870 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1871 If PROP is already a property on the list, its value is set to VAL,
1872 otherwise the new PROP VAL pair is added. The new plist is returned;
1873 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1874 The PLIST is modified by side effects. */)
1875 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1877 register Lisp_Object tail
, prev
;
1878 Lisp_Object newcell
;
1880 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1881 tail
= XCDR (XCDR (tail
)))
1883 if (EQ (prop
, XCAR (tail
)))
1885 Fsetcar (XCDR (tail
), val
);
1892 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1896 Fsetcdr (XCDR (prev
), newcell
);
1900 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1901 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1902 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1903 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1905 CHECK_SYMBOL (symbol
);
1906 XSYMBOL (symbol
)->plist
1907 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1911 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1912 doc
: /* Extract a value from a property list, comparing with `equal'.
1913 PLIST is a property list, which is a list of the form
1914 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1915 corresponding to the given PROP, or nil if PROP is not
1916 one of the properties on the list. */)
1917 (Lisp_Object plist
, Lisp_Object prop
)
1922 CONSP (tail
) && CONSP (XCDR (tail
));
1923 tail
= XCDR (XCDR (tail
)))
1925 if (! NILP (Fequal (prop
, XCAR (tail
))))
1926 return XCAR (XCDR (tail
));
1931 CHECK_LIST_END (tail
, prop
);
1936 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1937 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1938 PLIST is a property list, which is a list of the form
1939 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1940 If PROP is already a property on the list, its value is set to VAL,
1941 otherwise the new PROP VAL pair is added. The new plist is returned;
1942 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1943 The PLIST is modified by side effects. */)
1944 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1946 register Lisp_Object tail
, prev
;
1947 Lisp_Object newcell
;
1949 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1950 tail
= XCDR (XCDR (tail
)))
1952 if (! NILP (Fequal (prop
, XCAR (tail
))))
1954 Fsetcar (XCDR (tail
), val
);
1961 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1965 Fsetcdr (XCDR (prev
), newcell
);
1969 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1970 doc
: /* Return t if the two args are the same Lisp object.
1971 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1972 (Lisp_Object obj1
, Lisp_Object obj2
)
1975 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1977 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1980 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1981 doc
: /* Return t if two Lisp objects have similar structure and contents.
1982 They must have the same data type.
1983 Conses are compared by comparing the cars and the cdrs.
1984 Vectors and strings are compared element by element.
1985 Numbers are compared by value, but integers cannot equal floats.
1986 (Use `=' if you want integers and floats to be able to be equal.)
1987 Symbols must match exactly. */)
1988 (register Lisp_Object o1
, Lisp_Object o2
)
1990 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1993 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1994 doc
: /* Return t if two Lisp objects have similar structure and contents.
1995 This is like `equal' except that it compares the text properties
1996 of strings. (`equal' ignores text properties.) */)
1997 (register Lisp_Object o1
, Lisp_Object o2
)
1999 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2002 /* DEPTH is current depth of recursion. Signal an error if it
2004 PROPS, if non-nil, means compare string text properties too. */
2007 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2010 error ("Stack overflow in equal");
2016 if (XTYPE (o1
) != XTYPE (o2
))
2025 d1
= extract_float (o1
);
2026 d2
= extract_float (o2
);
2027 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2028 though they are not =. */
2029 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2033 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2040 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2044 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2046 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2049 o1
= XOVERLAY (o1
)->plist
;
2050 o2
= XOVERLAY (o2
)->plist
;
2055 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2056 && (XMARKER (o1
)->buffer
== 0
2057 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2061 case Lisp_Vectorlike
:
2064 EMACS_INT size
= ASIZE (o1
);
2065 /* Pseudovectors have the type encoded in the size field, so this test
2066 actually checks that the objects have the same type as well as the
2068 if (ASIZE (o2
) != size
)
2070 /* Boolvectors are compared much like strings. */
2071 if (BOOL_VECTOR_P (o1
))
2074 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2075 / BOOL_VECTOR_BITS_PER_CHAR
);
2077 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2079 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2084 if (WINDOW_CONFIGURATIONP (o1
))
2085 return compare_window_configurations (o1
, o2
, 0);
2087 /* Aside from them, only true vectors, char-tables, compiled
2088 functions, and fonts (font-spec, font-entity, font-ojbect)
2089 are sensible to compare, so eliminate the others now. */
2090 if (size
& PSEUDOVECTOR_FLAG
)
2092 if (!(size
& (PVEC_COMPILED
2093 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2095 size
&= PSEUDOVECTOR_SIZE_MASK
;
2097 for (i
= 0; i
< size
; i
++)
2102 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2110 if (SCHARS (o1
) != SCHARS (o2
))
2112 if (SBYTES (o1
) != SBYTES (o2
))
2114 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2116 if (props
&& !compare_string_intervals (o1
, o2
))
2128 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2129 doc
: /* Store each element of ARRAY with ITEM.
2130 ARRAY is a vector, string, char-table, or bool-vector. */)
2131 (Lisp_Object array
, Lisp_Object item
)
2133 register EMACS_INT size
, idx
;
2136 if (VECTORP (array
))
2138 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2139 size
= ASIZE (array
);
2140 for (idx
= 0; idx
< size
; idx
++)
2143 else if (CHAR_TABLE_P (array
))
2147 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2148 XCHAR_TABLE (array
)->contents
[i
] = item
;
2149 XCHAR_TABLE (array
)->defalt
= item
;
2151 else if (STRINGP (array
))
2153 register unsigned char *p
= SDATA (array
);
2154 CHECK_NUMBER (item
);
2155 charval
= XINT (item
);
2156 size
= SCHARS (array
);
2157 if (STRING_MULTIBYTE (array
))
2159 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2160 int len
= CHAR_STRING (charval
, str
);
2161 EMACS_INT size_byte
= SBYTES (array
);
2162 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2165 if (size
!= size_byte
)
2168 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2169 if (len
!= this_len
)
2170 error ("Attempt to change byte length of a string");
2173 for (i
= 0; i
< size_byte
; i
++)
2174 *p
++ = str
[i
% len
];
2177 for (idx
= 0; idx
< size
; idx
++)
2180 else if (BOOL_VECTOR_P (array
))
2182 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2184 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2185 / BOOL_VECTOR_BITS_PER_CHAR
);
2187 charval
= (! NILP (item
) ? -1 : 0);
2188 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2190 if (idx
< size_in_chars
)
2192 /* Mask out bits beyond the vector size. */
2193 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2194 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2199 wrong_type_argument (Qarrayp
, array
);
2203 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2205 doc
: /* Clear the contents of STRING.
2206 This makes STRING unibyte and may change its length. */)
2207 (Lisp_Object string
)
2210 CHECK_STRING (string
);
2211 len
= SBYTES (string
);
2212 memset (SDATA (string
), 0, len
);
2213 STRING_SET_CHARS (string
, len
);
2214 STRING_SET_UNIBYTE (string
);
2220 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2222 Lisp_Object args
[2];
2225 return Fnconc (2, args
);
2228 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2229 doc
: /* Concatenate any number of lists by altering them.
2230 Only the last argument is not altered, and need not be a list.
2231 usage: (nconc &rest LISTS) */)
2232 (size_t nargs
, Lisp_Object
*args
)
2234 register size_t argnum
;
2235 register Lisp_Object tail
, tem
, val
;
2239 for (argnum
= 0; argnum
< nargs
; argnum
++)
2242 if (NILP (tem
)) continue;
2247 if (argnum
+ 1 == nargs
) break;
2249 CHECK_LIST_CONS (tem
, tem
);
2258 tem
= args
[argnum
+ 1];
2259 Fsetcdr (tail
, tem
);
2261 args
[argnum
+ 1] = tail
;
2267 /* This is the guts of all mapping functions.
2268 Apply FN to each element of SEQ, one by one,
2269 storing the results into elements of VALS, a C vector of Lisp_Objects.
2270 LENI is the length of VALS, which should also be the length of SEQ. */
2273 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2275 register Lisp_Object tail
;
2277 register EMACS_INT i
;
2278 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2282 /* Don't let vals contain any garbage when GC happens. */
2283 for (i
= 0; i
< leni
; i
++)
2286 GCPRO3 (dummy
, fn
, seq
);
2288 gcpro1
.nvars
= leni
;
2292 /* We need not explicitly protect `tail' because it is used only on lists, and
2293 1) lists are not relocated and 2) the list is marked via `seq' so will not
2296 if (VECTORP (seq
) || COMPILEDP (seq
))
2298 for (i
= 0; i
< leni
; i
++)
2300 dummy
= call1 (fn
, AREF (seq
, i
));
2305 else if (BOOL_VECTOR_P (seq
))
2307 for (i
= 0; i
< leni
; i
++)
2310 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2311 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2312 dummy
= call1 (fn
, dummy
);
2317 else if (STRINGP (seq
))
2321 for (i
= 0, i_byte
= 0; i
< leni
;)
2324 EMACS_INT i_before
= i
;
2326 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2327 XSETFASTINT (dummy
, c
);
2328 dummy
= call1 (fn
, dummy
);
2330 vals
[i_before
] = dummy
;
2333 else /* Must be a list, since Flength did not get an error */
2336 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2338 dummy
= call1 (fn
, XCAR (tail
));
2348 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2349 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2350 In between each pair of results, stick in SEPARATOR. Thus, " " as
2351 SEPARATOR results in spaces between the values returned by FUNCTION.
2352 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2353 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2356 register EMACS_INT leni
;
2358 register Lisp_Object
*args
;
2359 register EMACS_INT i
;
2360 struct gcpro gcpro1
;
2364 len
= Flength (sequence
);
2365 if (CHAR_TABLE_P (sequence
))
2366 wrong_type_argument (Qlistp
, sequence
);
2368 nargs
= leni
+ leni
- 1;
2369 if (nargs
< 0) return empty_unibyte_string
;
2371 SAFE_ALLOCA_LISP (args
, nargs
);
2374 mapcar1 (leni
, args
, function
, sequence
);
2377 for (i
= leni
- 1; i
> 0; i
--)
2378 args
[i
+ i
] = args
[i
];
2380 for (i
= 1; i
< nargs
; i
+= 2)
2381 args
[i
] = separator
;
2383 ret
= Fconcat (nargs
, args
);
2389 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2390 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2391 The result is a list just as long as SEQUENCE.
2392 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2393 (Lisp_Object function
, Lisp_Object sequence
)
2395 register Lisp_Object len
;
2396 register EMACS_INT leni
;
2397 register Lisp_Object
*args
;
2401 len
= Flength (sequence
);
2402 if (CHAR_TABLE_P (sequence
))
2403 wrong_type_argument (Qlistp
, sequence
);
2404 leni
= XFASTINT (len
);
2406 SAFE_ALLOCA_LISP (args
, leni
);
2408 mapcar1 (leni
, args
, function
, sequence
);
2410 ret
= Flist (leni
, args
);
2416 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2417 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2418 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2419 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2420 (Lisp_Object function
, Lisp_Object sequence
)
2422 register EMACS_INT leni
;
2424 leni
= XFASTINT (Flength (sequence
));
2425 if (CHAR_TABLE_P (sequence
))
2426 wrong_type_argument (Qlistp
, sequence
);
2427 mapcar1 (leni
, 0, function
, sequence
);
2432 /* This is how C code calls `yes-or-no-p' and allows the user
2435 Anything that calls this function must protect from GC! */
2438 do_yes_or_no_p (Lisp_Object prompt
)
2440 return call1 (intern ("yes-or-no-p"), prompt
);
2443 /* Anything that calls this function must protect from GC! */
2445 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2446 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2447 PROMPT is the string to display to ask the question. It should end in
2448 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2450 The user must confirm the answer with RET, and can edit it until it
2453 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2454 is nil, and `use-dialog-box' is non-nil. */)
2455 (Lisp_Object prompt
)
2457 register Lisp_Object ans
;
2458 Lisp_Object args
[2];
2459 struct gcpro gcpro1
;
2461 CHECK_STRING (prompt
);
2464 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2465 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2469 Lisp_Object pane
, menu
, obj
;
2470 redisplay_preserve_echo_area (4);
2471 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2472 Fcons (Fcons (build_string ("No"), Qnil
),
2475 menu
= Fcons (prompt
, pane
);
2476 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2480 #endif /* HAVE_MENUS */
2483 args
[1] = build_string ("(yes or no) ");
2484 prompt
= Fconcat (2, args
);
2490 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2491 Qyes_or_no_p_history
, Qnil
,
2493 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2498 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2506 message ("Please answer yes or no.");
2507 Fsleep_for (make_number (2), Qnil
);
2511 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2512 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2514 Each of the three load averages is multiplied by 100, then converted
2517 When USE-FLOATS is non-nil, floats will be used instead of integers.
2518 These floats are not multiplied by 100.
2520 If the 5-minute or 15-minute load averages are not available, return a
2521 shortened list, containing only those averages which are available.
2523 An error is thrown if the load average can't be obtained. In some
2524 cases making it work would require Emacs being installed setuid or
2525 setgid so that it can read kernel information, and that usually isn't
2527 (Lisp_Object use_floats
)
2530 int loads
= getloadavg (load_ave
, 3);
2531 Lisp_Object ret
= Qnil
;
2534 error ("load-average not implemented for this operating system");
2538 Lisp_Object load
= (NILP (use_floats
) ?
2539 make_number ((int) (100.0 * load_ave
[loads
]))
2540 : make_float (load_ave
[loads
]));
2541 ret
= Fcons (load
, ret
);
2547 Lisp_Object Qsubfeatures
;
2549 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2550 doc
: /* Return t if FEATURE is present in this Emacs.
2552 Use this to conditionalize execution of lisp code based on the
2553 presence or absence of Emacs or environment extensions.
2554 Use `provide' to declare that a feature is available. This function
2555 looks at the value of the variable `features'. The optional argument
2556 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2557 (Lisp_Object feature
, Lisp_Object subfeature
)
2559 register Lisp_Object tem
;
2560 CHECK_SYMBOL (feature
);
2561 tem
= Fmemq (feature
, Vfeatures
);
2562 if (!NILP (tem
) && !NILP (subfeature
))
2563 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2564 return (NILP (tem
)) ? Qnil
: Qt
;
2567 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2568 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2569 The optional argument SUBFEATURES should be a list of symbols listing
2570 particular subfeatures supported in this version of FEATURE. */)
2571 (Lisp_Object feature
, Lisp_Object subfeatures
)
2573 register Lisp_Object tem
;
2574 CHECK_SYMBOL (feature
);
2575 CHECK_LIST (subfeatures
);
2576 if (!NILP (Vautoload_queue
))
2577 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2579 tem
= Fmemq (feature
, Vfeatures
);
2581 Vfeatures
= Fcons (feature
, Vfeatures
);
2582 if (!NILP (subfeatures
))
2583 Fput (feature
, Qsubfeatures
, subfeatures
);
2584 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2586 /* Run any load-hooks for this file. */
2587 tem
= Fassq (feature
, Vafter_load_alist
);
2589 Fprogn (XCDR (tem
));
2594 /* `require' and its subroutines. */
2596 /* List of features currently being require'd, innermost first. */
2598 static Lisp_Object require_nesting_list
;
2601 require_unwind (Lisp_Object old_value
)
2603 return require_nesting_list
= old_value
;
2606 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2607 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2608 If FEATURE is not a member of the list `features', then the feature
2609 is not loaded; so load the file FILENAME.
2610 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2611 and `load' will try to load this name appended with the suffix `.elc' or
2612 `.el', in that order. The name without appended suffix will not be used.
2613 If the optional third argument NOERROR is non-nil,
2614 then return nil if the file is not found instead of signaling an error.
2615 Normally the return value is FEATURE.
2616 The normal messages at start and end of loading FILENAME are suppressed. */)
2617 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2619 register Lisp_Object tem
;
2620 struct gcpro gcpro1
, gcpro2
;
2621 int from_file
= load_in_progress
;
2623 CHECK_SYMBOL (feature
);
2625 /* Record the presence of `require' in this file
2626 even if the feature specified is already loaded.
2627 But not more than once in any file,
2628 and not when we aren't loading or reading from a file. */
2630 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2631 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2636 tem
= Fcons (Qrequire
, feature
);
2637 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2638 LOADHIST_ATTACH (tem
);
2640 tem
= Fmemq (feature
, Vfeatures
);
2644 int count
= SPECPDL_INDEX ();
2647 /* This is to make sure that loadup.el gives a clear picture
2648 of what files are preloaded and when. */
2649 if (! NILP (Vpurify_flag
))
2650 error ("(require %s) while preparing to dump",
2651 SDATA (SYMBOL_NAME (feature
)));
2653 /* A certain amount of recursive `require' is legitimate,
2654 but if we require the same feature recursively 3 times,
2656 tem
= require_nesting_list
;
2657 while (! NILP (tem
))
2659 if (! NILP (Fequal (feature
, XCAR (tem
))))
2664 error ("Recursive `require' for feature `%s'",
2665 SDATA (SYMBOL_NAME (feature
)));
2667 /* Update the list for any nested `require's that occur. */
2668 record_unwind_protect (require_unwind
, require_nesting_list
);
2669 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2671 /* Value saved here is to be restored into Vautoload_queue */
2672 record_unwind_protect (un_autoload
, Vautoload_queue
);
2673 Vautoload_queue
= Qt
;
2675 /* Load the file. */
2676 GCPRO2 (feature
, filename
);
2677 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2678 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2681 /* If load failed entirely, return nil. */
2683 return unbind_to (count
, Qnil
);
2685 tem
= Fmemq (feature
, Vfeatures
);
2687 error ("Required feature `%s' was not provided",
2688 SDATA (SYMBOL_NAME (feature
)));
2690 /* Once loading finishes, don't undo it. */
2691 Vautoload_queue
= Qt
;
2692 feature
= unbind_to (count
, feature
);
2698 /* Primitives for work of the "widget" library.
2699 In an ideal world, this section would not have been necessary.
2700 However, lisp function calls being as slow as they are, it turns
2701 out that some functions in the widget library (wid-edit.el) are the
2702 bottleneck of Widget operation. Here is their translation to C,
2703 for the sole reason of efficiency. */
2705 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2706 doc
: /* Return non-nil if PLIST has the property PROP.
2707 PLIST is a property list, which is a list of the form
2708 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2709 Unlike `plist-get', this allows you to distinguish between a missing
2710 property and a property with the value nil.
2711 The value is actually the tail of PLIST whose car is PROP. */)
2712 (Lisp_Object plist
, Lisp_Object prop
)
2714 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2717 plist
= XCDR (plist
);
2718 plist
= CDR (plist
);
2723 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2724 doc
: /* In WIDGET, set PROPERTY to VALUE.
2725 The value can later be retrieved with `widget-get'. */)
2726 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2728 CHECK_CONS (widget
);
2729 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2733 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2734 doc
: /* In WIDGET, get the value of PROPERTY.
2735 The value could either be specified when the widget was created, or
2736 later with `widget-put'. */)
2737 (Lisp_Object widget
, Lisp_Object property
)
2745 CHECK_CONS (widget
);
2746 tmp
= Fplist_member (XCDR (widget
), property
);
2752 tmp
= XCAR (widget
);
2755 widget
= Fget (tmp
, Qwidget_type
);
2759 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2760 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2761 ARGS are passed as extra arguments to the function.
2762 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2763 (size_t nargs
, Lisp_Object
*args
)
2765 /* This function can GC. */
2766 Lisp_Object newargs
[3];
2767 struct gcpro gcpro1
, gcpro2
;
2770 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2771 newargs
[1] = args
[0];
2772 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2773 GCPRO2 (newargs
[0], newargs
[2]);
2774 result
= Fapply (3, newargs
);
2779 #ifdef HAVE_LANGINFO_CODESET
2780 #include <langinfo.h>
2783 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2784 doc
: /* Access locale data ITEM for the current C locale, if available.
2785 ITEM should be one of the following:
2787 `codeset', returning the character set as a string (locale item CODESET);
2789 `days', returning a 7-element vector of day names (locale items DAY_n);
2791 `months', returning a 12-element vector of month names (locale items MON_n);
2793 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2794 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2796 If the system can't provide such information through a call to
2797 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2799 See also Info node `(libc)Locales'.
2801 The data read from the system are decoded using `locale-coding-system'. */)
2805 #ifdef HAVE_LANGINFO_CODESET
2807 if (EQ (item
, Qcodeset
))
2809 str
= nl_langinfo (CODESET
);
2810 return build_string (str
);
2813 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2815 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2816 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2818 struct gcpro gcpro1
;
2820 synchronize_system_time_locale ();
2821 for (i
= 0; i
< 7; i
++)
2823 str
= nl_langinfo (days
[i
]);
2824 val
= make_unibyte_string (str
, strlen (str
));
2825 /* Fixme: Is this coding system necessarily right, even if
2826 it is consistent with CODESET? If not, what to do? */
2827 Faset (v
, make_number (i
),
2828 code_convert_string_norecord (val
, Vlocale_coding_system
,
2836 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2838 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2839 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2840 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2842 struct gcpro gcpro1
;
2844 synchronize_system_time_locale ();
2845 for (i
= 0; i
< 12; i
++)
2847 str
= nl_langinfo (months
[i
]);
2848 val
= make_unibyte_string (str
, strlen (str
));
2849 Faset (v
, make_number (i
),
2850 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2856 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2857 but is in the locale files. This could be used by ps-print. */
2859 else if (EQ (item
, Qpaper
))
2861 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2862 make_number (nl_langinfo (PAPER_HEIGHT
)));
2864 #endif /* PAPER_WIDTH */
2865 #endif /* HAVE_LANGINFO_CODESET*/
2869 /* base64 encode/decode functions (RFC 2045).
2870 Based on code from GNU recode. */
2872 #define MIME_LINE_LENGTH 76
2874 #define IS_ASCII(Character) \
2876 #define IS_BASE64(Character) \
2877 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2878 #define IS_BASE64_IGNORABLE(Character) \
2879 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2880 || (Character) == '\f' || (Character) == '\r')
2882 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2883 character or return retval if there are no characters left to
2885 #define READ_QUADRUPLET_BYTE(retval) \
2890 if (nchars_return) \
2891 *nchars_return = nchars; \
2896 while (IS_BASE64_IGNORABLE (c))
2898 /* Table of characters coding the 64 values. */
2899 static const char base64_value_to_char
[64] =
2901 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2902 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2903 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2904 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2905 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2906 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2907 '8', '9', '+', '/' /* 60-63 */
2910 /* Table of base64 values for first 128 characters. */
2911 static const short base64_char_to_value
[128] =
2913 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2914 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2915 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2916 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2917 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2918 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2919 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2920 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2921 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2922 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2923 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2924 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2925 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2928 /* The following diagram shows the logical steps by which three octets
2929 get transformed into four base64 characters.
2931 .--------. .--------. .--------.
2932 |aaaaaabb| |bbbbcccc| |ccdddddd|
2933 `--------' `--------' `--------'
2935 .--------+--------+--------+--------.
2936 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2937 `--------+--------+--------+--------'
2939 .--------+--------+--------+--------.
2940 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2941 `--------+--------+--------+--------'
2943 The octets are divided into 6 bit chunks, which are then encoded into
2944 base64 characters. */
2947 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2948 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2951 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2953 doc
: /* Base64-encode the region between BEG and END.
2954 Return the length of the encoded text.
2955 Optional third argument NO-LINE-BREAK means do not break long lines
2956 into shorter lines. */)
2957 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2960 EMACS_INT allength
, length
;
2961 EMACS_INT ibeg
, iend
, encoded_length
;
2962 EMACS_INT old_pos
= PT
;
2965 validate_region (&beg
, &end
);
2967 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2968 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2969 move_gap_both (XFASTINT (beg
), ibeg
);
2971 /* We need to allocate enough room for encoding the text.
2972 We need 33 1/3% more space, plus a newline every 76
2973 characters, and then we round up. */
2974 length
= iend
- ibeg
;
2975 allength
= length
+ length
/3 + 1;
2976 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2978 SAFE_ALLOCA (encoded
, char *, allength
);
2979 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2980 encoded
, length
, NILP (no_line_break
),
2981 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2982 if (encoded_length
> allength
)
2985 if (encoded_length
< 0)
2987 /* The encoding wasn't possible. */
2989 error ("Multibyte character in data for base64 encoding");
2992 /* Now we have encoded the region, so we insert the new contents
2993 and delete the old. (Insert first in order to preserve markers.) */
2994 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2995 insert (encoded
, encoded_length
);
2997 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2999 /* If point was outside of the region, restore it exactly; else just
3000 move to the beginning of the region. */
3001 if (old_pos
>= XFASTINT (end
))
3002 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3003 else if (old_pos
> XFASTINT (beg
))
3004 old_pos
= XFASTINT (beg
);
3007 /* We return the length of the encoded text. */
3008 return make_number (encoded_length
);
3011 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3013 doc
: /* Base64-encode STRING and return the result.
3014 Optional second argument NO-LINE-BREAK means do not break long lines
3015 into shorter lines. */)
3016 (Lisp_Object string
, Lisp_Object no_line_break
)
3018 EMACS_INT allength
, length
, encoded_length
;
3020 Lisp_Object encoded_string
;
3023 CHECK_STRING (string
);
3025 /* We need to allocate enough room for encoding the text.
3026 We need 33 1/3% more space, plus a newline every 76
3027 characters, and then we round up. */
3028 length
= SBYTES (string
);
3029 allength
= length
+ length
/3 + 1;
3030 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3032 /* We need to allocate enough room for decoding the text. */
3033 SAFE_ALLOCA (encoded
, char *, allength
);
3035 encoded_length
= base64_encode_1 (SSDATA (string
),
3036 encoded
, length
, NILP (no_line_break
),
3037 STRING_MULTIBYTE (string
));
3038 if (encoded_length
> allength
)
3041 if (encoded_length
< 0)
3043 /* The encoding wasn't possible. */
3045 error ("Multibyte character in data for base64 encoding");
3048 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3051 return encoded_string
;
3055 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3056 int line_break
, int multibyte
)
3069 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3070 if (CHAR_BYTE8_P (c
))
3071 c
= CHAR_TO_BYTE8 (c
);
3079 /* Wrap line every 76 characters. */
3083 if (counter
< MIME_LINE_LENGTH
/ 4)
3092 /* Process first byte of a triplet. */
3094 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3095 value
= (0x03 & c
) << 4;
3097 /* Process second byte of a triplet. */
3101 *e
++ = base64_value_to_char
[value
];
3109 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3110 if (CHAR_BYTE8_P (c
))
3111 c
= CHAR_TO_BYTE8 (c
);
3119 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3120 value
= (0x0f & c
) << 2;
3122 /* Process third byte of a triplet. */
3126 *e
++ = base64_value_to_char
[value
];
3133 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3134 if (CHAR_BYTE8_P (c
))
3135 c
= CHAR_TO_BYTE8 (c
);
3143 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3144 *e
++ = base64_value_to_char
[0x3f & c
];
3151 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3153 doc
: /* Base64-decode the region between BEG and END.
3154 Return the length of the decoded text.
3155 If the region can't be decoded, signal an error and don't modify the buffer. */)
3156 (Lisp_Object beg
, Lisp_Object end
)
3158 EMACS_INT ibeg
, iend
, length
, allength
;
3160 EMACS_INT old_pos
= PT
;
3161 EMACS_INT decoded_length
;
3162 EMACS_INT inserted_chars
;
3163 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3166 validate_region (&beg
, &end
);
3168 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3169 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3171 length
= iend
- ibeg
;
3173 /* We need to allocate enough room for decoding the text. If we are
3174 working on a multibyte buffer, each decoded code may occupy at
3176 allength
= multibyte
? length
* 2 : length
;
3177 SAFE_ALLOCA (decoded
, char *, allength
);
3179 move_gap_both (XFASTINT (beg
), ibeg
);
3180 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3182 multibyte
, &inserted_chars
);
3183 if (decoded_length
> allength
)
3186 if (decoded_length
< 0)
3188 /* The decoding wasn't possible. */
3190 error ("Invalid base64 data");
3193 /* Now we have decoded the region, so we insert the new contents
3194 and delete the old. (Insert first in order to preserve markers.) */
3195 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3196 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3199 /* Delete the original text. */
3200 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3201 iend
+ decoded_length
, 1);
3203 /* If point was outside of the region, restore it exactly; else just
3204 move to the beginning of the region. */
3205 if (old_pos
>= XFASTINT (end
))
3206 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3207 else if (old_pos
> XFASTINT (beg
))
3208 old_pos
= XFASTINT (beg
);
3209 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3211 return make_number (inserted_chars
);
3214 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3216 doc
: /* Base64-decode STRING and return the result. */)
3217 (Lisp_Object string
)
3220 EMACS_INT length
, decoded_length
;
3221 Lisp_Object decoded_string
;
3224 CHECK_STRING (string
);
3226 length
= SBYTES (string
);
3227 /* We need to allocate enough room for decoding the text. */
3228 SAFE_ALLOCA (decoded
, char *, length
);
3230 /* The decoded result should be unibyte. */
3231 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3233 if (decoded_length
> length
)
3235 else if (decoded_length
>= 0)
3236 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3238 decoded_string
= Qnil
;
3241 if (!STRINGP (decoded_string
))
3242 error ("Invalid base64 data");
3244 return decoded_string
;
3247 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3248 MULTIBYTE is nonzero, the decoded result should be in multibyte
3249 form. If NCHARS_RETRUN is not NULL, store the number of produced
3250 characters in *NCHARS_RETURN. */
3253 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3254 int multibyte
, EMACS_INT
*nchars_return
)
3256 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3259 unsigned long value
;
3260 EMACS_INT nchars
= 0;
3264 /* Process first byte of a quadruplet. */
3266 READ_QUADRUPLET_BYTE (e
-to
);
3270 value
= base64_char_to_value
[c
] << 18;
3272 /* Process second byte of a quadruplet. */
3274 READ_QUADRUPLET_BYTE (-1);
3278 value
|= base64_char_to_value
[c
] << 12;
3280 c
= (unsigned char) (value
>> 16);
3281 if (multibyte
&& c
>= 128)
3282 e
+= BYTE8_STRING (c
, e
);
3287 /* Process third byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (-1);
3293 READ_QUADRUPLET_BYTE (-1);
3302 value
|= base64_char_to_value
[c
] << 6;
3304 c
= (unsigned char) (0xff & value
>> 8);
3305 if (multibyte
&& c
>= 128)
3306 e
+= BYTE8_STRING (c
, e
);
3311 /* Process fourth byte of a quadruplet. */
3313 READ_QUADRUPLET_BYTE (-1);
3320 value
|= base64_char_to_value
[c
];
3322 c
= (unsigned char) (0xff & value
);
3323 if (multibyte
&& c
>= 128)
3324 e
+= BYTE8_STRING (c
, e
);
3333 /***********************************************************************
3335 ***** Hash Tables *****
3337 ***********************************************************************/
3339 /* Implemented by gerd@gnu.org. This hash table implementation was
3340 inspired by CMUCL hash tables. */
3344 1. For small tables, association lists are probably faster than
3345 hash tables because they have lower overhead.
3347 For uses of hash tables where the O(1) behavior of table
3348 operations is not a requirement, it might therefore be a good idea
3349 not to hash. Instead, we could just do a linear search in the
3350 key_and_value vector of the hash table. This could be done
3351 if a `:linear-search t' argument is given to make-hash-table. */
3354 /* The list of all weak hash tables. Don't staticpro this one. */
3356 struct Lisp_Hash_Table
*weak_hash_tables
;
3358 /* Various symbols. */
3360 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3361 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3362 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3364 /* Function prototypes. */
3366 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3367 static size_t get_key_arg (Lisp_Object
, size_t, Lisp_Object
*, char *);
3368 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3369 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3370 Lisp_Object
, unsigned);
3371 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3372 Lisp_Object
, unsigned);
3373 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3374 unsigned, Lisp_Object
, unsigned);
3375 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3376 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3377 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3378 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3380 static unsigned sxhash_string (unsigned char *, int);
3381 static unsigned sxhash_list (Lisp_Object
, int);
3382 static unsigned sxhash_vector (Lisp_Object
, int);
3383 static unsigned sxhash_bool_vector (Lisp_Object
);
3384 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3388 /***********************************************************************
3390 ***********************************************************************/
3392 /* If OBJ is a Lisp hash table, return a pointer to its struct
3393 Lisp_Hash_Table. Otherwise, signal an error. */
3395 static struct Lisp_Hash_Table
*
3396 check_hash_table (Lisp_Object obj
)
3398 CHECK_HASH_TABLE (obj
);
3399 return XHASH_TABLE (obj
);
3403 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3407 next_almost_prime (int n
)
3419 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3420 which USED[I] is non-zero. If found at index I in ARGS, set
3421 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3422 0. This function is used to extract a keyword/argument pair from
3423 a DEFUN parameter list. */
3426 get_key_arg (Lisp_Object key
, size_t nargs
, Lisp_Object
*args
, char *used
)
3430 for (i
= 1; i
< nargs
; i
++)
3431 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3442 /* Return a Lisp vector which has the same contents as VEC but has
3443 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3444 vector that are not copied from VEC are set to INIT. */
3447 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3449 struct Lisp_Vector
*v
;
3452 xassert (VECTORP (vec
));
3453 old_size
= ASIZE (vec
);
3454 xassert (new_size
>= old_size
);
3456 v
= allocate_vector (new_size
);
3457 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3458 for (i
= old_size
; i
< new_size
; ++i
)
3459 v
->contents
[i
] = init
;
3460 XSETVECTOR (vec
, v
);
3465 /***********************************************************************
3467 ***********************************************************************/
3469 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3470 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3471 KEY2 are the same. */
3474 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3476 return (FLOATP (key1
)
3478 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3482 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3483 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3484 KEY2 are the same. */
3487 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3489 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3493 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3494 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3495 if KEY1 and KEY2 are the same. */
3498 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3502 Lisp_Object args
[3];
3504 args
[0] = h
->user_cmp_function
;
3507 return !NILP (Ffuncall (3, args
));
3514 /* Value is a hash code for KEY for use in hash table H which uses
3515 `eq' to compare keys. The hash code returned is guaranteed to fit
3516 in a Lisp integer. */
3519 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3521 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3522 xassert ((hash
& ~INTMASK
) == 0);
3527 /* Value is a hash code for KEY for use in hash table H which uses
3528 `eql' to compare keys. The hash code returned is guaranteed to fit
3529 in a Lisp integer. */
3532 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3536 hash
= sxhash (key
, 0);
3538 hash
= XUINT (key
) ^ XTYPE (key
);
3539 xassert ((hash
& ~INTMASK
) == 0);
3544 /* Value is a hash code for KEY for use in hash table H which uses
3545 `equal' to compare keys. The hash code returned is guaranteed to fit
3546 in a Lisp integer. */
3549 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3551 unsigned hash
= sxhash (key
, 0);
3552 xassert ((hash
& ~INTMASK
) == 0);
3557 /* Value is a hash code for KEY for use in hash table H which uses as
3558 user-defined function to compare keys. The hash code returned is
3559 guaranteed to fit in a Lisp integer. */
3562 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3564 Lisp_Object args
[2], hash
;
3566 args
[0] = h
->user_hash_function
;
3568 hash
= Ffuncall (2, args
);
3569 if (!INTEGERP (hash
))
3570 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3571 return XUINT (hash
);
3575 /* Create and initialize a new hash table.
3577 TEST specifies the test the hash table will use to compare keys.
3578 It must be either one of the predefined tests `eq', `eql' or
3579 `equal' or a symbol denoting a user-defined test named TEST with
3580 test and hash functions USER_TEST and USER_HASH.
3582 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3584 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3585 new size when it becomes full is computed by adding REHASH_SIZE to
3586 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3587 table's new size is computed by multiplying its old size with
3590 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3591 be resized when the ratio of (number of entries in the table) /
3592 (table size) is >= REHASH_THRESHOLD.
3594 WEAK specifies the weakness of the table. If non-nil, it must be
3595 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3598 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3599 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3600 Lisp_Object user_test
, Lisp_Object user_hash
)
3602 struct Lisp_Hash_Table
*h
;
3604 int index_size
, i
, sz
;
3606 /* Preconditions. */
3607 xassert (SYMBOLP (test
));
3608 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3609 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3610 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3611 xassert (FLOATP (rehash_threshold
)
3612 && XFLOATINT (rehash_threshold
) > 0
3613 && XFLOATINT (rehash_threshold
) <= 1.0);
3615 if (XFASTINT (size
) == 0)
3616 size
= make_number (1);
3618 /* Allocate a table and initialize it. */
3619 h
= allocate_hash_table ();
3621 /* Initialize hash table slots. */
3622 sz
= XFASTINT (size
);
3625 if (EQ (test
, Qeql
))
3627 h
->cmpfn
= cmpfn_eql
;
3628 h
->hashfn
= hashfn_eql
;
3630 else if (EQ (test
, Qeq
))
3633 h
->hashfn
= hashfn_eq
;
3635 else if (EQ (test
, Qequal
))
3637 h
->cmpfn
= cmpfn_equal
;
3638 h
->hashfn
= hashfn_equal
;
3642 h
->user_cmp_function
= user_test
;
3643 h
->user_hash_function
= user_hash
;
3644 h
->cmpfn
= cmpfn_user_defined
;
3645 h
->hashfn
= hashfn_user_defined
;
3649 h
->rehash_threshold
= rehash_threshold
;
3650 h
->rehash_size
= rehash_size
;
3652 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3653 h
->hash
= Fmake_vector (size
, Qnil
);
3654 h
->next
= Fmake_vector (size
, Qnil
);
3655 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3656 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3657 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3659 /* Set up the free list. */
3660 for (i
= 0; i
< sz
- 1; ++i
)
3661 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3662 h
->next_free
= make_number (0);
3664 XSET_HASH_TABLE (table
, h
);
3665 xassert (HASH_TABLE_P (table
));
3666 xassert (XHASH_TABLE (table
) == h
);
3668 /* Maybe add this hash table to the list of all weak hash tables. */
3670 h
->next_weak
= NULL
;
3673 h
->next_weak
= weak_hash_tables
;
3674 weak_hash_tables
= h
;
3681 /* Return a copy of hash table H1. Keys and values are not copied,
3682 only the table itself is. */
3685 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3688 struct Lisp_Hash_Table
*h2
;
3689 struct Lisp_Vector
*next
;
3691 h2
= allocate_hash_table ();
3692 next
= h2
->vec_next
;
3693 memcpy (h2
, h1
, sizeof *h2
);
3694 h2
->vec_next
= next
;
3695 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3696 h2
->hash
= Fcopy_sequence (h1
->hash
);
3697 h2
->next
= Fcopy_sequence (h1
->next
);
3698 h2
->index
= Fcopy_sequence (h1
->index
);
3699 XSET_HASH_TABLE (table
, h2
);
3701 /* Maybe add this hash table to the list of all weak hash tables. */
3702 if (!NILP (h2
->weak
))
3704 h2
->next_weak
= weak_hash_tables
;
3705 weak_hash_tables
= h2
;
3712 /* Resize hash table H if it's too full. If H cannot be resized
3713 because it's already too large, throw an error. */
3716 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3718 if (NILP (h
->next_free
))
3720 int old_size
= HASH_TABLE_SIZE (h
);
3721 int i
, new_size
, index_size
;
3724 if (INTEGERP (h
->rehash_size
))
3725 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3727 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3728 new_size
= max (old_size
+ 1, new_size
);
3729 index_size
= next_almost_prime ((int)
3731 / XFLOATINT (h
->rehash_threshold
)));
3732 /* Assignment to EMACS_INT stops GCC whining about limited range
3734 nsize
= max (index_size
, 2 * new_size
);
3735 if (nsize
> MOST_POSITIVE_FIXNUM
)
3736 error ("Hash table too large to resize");
3738 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3739 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3740 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3741 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3743 /* Update the free list. Do it so that new entries are added at
3744 the end of the free list. This makes some operations like
3746 for (i
= old_size
; i
< new_size
- 1; ++i
)
3747 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3749 if (!NILP (h
->next_free
))
3751 Lisp_Object last
, next
;
3753 last
= h
->next_free
;
3754 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3758 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3761 XSETFASTINT (h
->next_free
, old_size
);
3764 for (i
= 0; i
< old_size
; ++i
)
3765 if (!NILP (HASH_HASH (h
, i
)))
3767 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3768 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3769 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3770 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3776 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3777 the hash code of KEY. Value is the index of the entry in H
3778 matching KEY, or -1 if not found. */
3781 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3784 int start_of_bucket
;
3787 hash_code
= h
->hashfn (h
, key
);
3791 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3792 idx
= HASH_INDEX (h
, start_of_bucket
);
3794 /* We need not gcpro idx since it's either an integer or nil. */
3797 int i
= XFASTINT (idx
);
3798 if (EQ (key
, HASH_KEY (h
, i
))
3800 && h
->cmpfn (h
, key
, hash_code
,
3801 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3803 idx
= HASH_NEXT (h
, i
);
3806 return NILP (idx
) ? -1 : XFASTINT (idx
);
3810 /* Put an entry into hash table H that associates KEY with VALUE.
3811 HASH is a previously computed hash code of KEY.
3812 Value is the index of the entry in H matching KEY. */
3815 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3817 int start_of_bucket
, i
;
3819 xassert ((hash
& ~INTMASK
) == 0);
3821 /* Increment count after resizing because resizing may fail. */
3822 maybe_resize_hash_table (h
);
3825 /* Store key/value in the key_and_value vector. */
3826 i
= XFASTINT (h
->next_free
);
3827 h
->next_free
= HASH_NEXT (h
, i
);
3828 HASH_KEY (h
, i
) = key
;
3829 HASH_VALUE (h
, i
) = value
;
3831 /* Remember its hash code. */
3832 HASH_HASH (h
, i
) = make_number (hash
);
3834 /* Add new entry to its collision chain. */
3835 start_of_bucket
= hash
% ASIZE (h
->index
);
3836 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3837 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3842 /* Remove the entry matching KEY from hash table H, if there is one. */
3845 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3848 int start_of_bucket
;
3849 Lisp_Object idx
, prev
;
3851 hash_code
= h
->hashfn (h
, key
);
3852 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3853 idx
= HASH_INDEX (h
, start_of_bucket
);
3856 /* We need not gcpro idx, prev since they're either integers or nil. */
3859 int i
= XFASTINT (idx
);
3861 if (EQ (key
, HASH_KEY (h
, i
))
3863 && h
->cmpfn (h
, key
, hash_code
,
3864 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3866 /* Take entry out of collision chain. */
3868 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3870 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3872 /* Clear slots in key_and_value and add the slots to
3874 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3875 HASH_NEXT (h
, i
) = h
->next_free
;
3876 h
->next_free
= make_number (i
);
3878 xassert (h
->count
>= 0);
3884 idx
= HASH_NEXT (h
, i
);
3890 /* Clear hash table H. */
3893 hash_clear (struct Lisp_Hash_Table
*h
)
3897 int i
, size
= HASH_TABLE_SIZE (h
);
3899 for (i
= 0; i
< size
; ++i
)
3901 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3902 HASH_KEY (h
, i
) = Qnil
;
3903 HASH_VALUE (h
, i
) = Qnil
;
3904 HASH_HASH (h
, i
) = Qnil
;
3907 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3908 ASET (h
->index
, i
, Qnil
);
3910 h
->next_free
= make_number (0);
3917 /************************************************************************
3919 ************************************************************************/
3922 init_weak_hash_tables (void)
3924 weak_hash_tables
= NULL
;
3927 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3928 entries from the table that don't survive the current GC.
3929 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3930 non-zero if anything was marked. */
3933 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3935 int bucket
, n
, marked
;
3937 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3940 for (bucket
= 0; bucket
< n
; ++bucket
)
3942 Lisp_Object idx
, next
, prev
;
3944 /* Follow collision chain, removing entries that
3945 don't survive this garbage collection. */
3947 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3949 int i
= XFASTINT (idx
);
3950 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3951 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3954 if (EQ (h
->weak
, Qkey
))
3955 remove_p
= !key_known_to_survive_p
;
3956 else if (EQ (h
->weak
, Qvalue
))
3957 remove_p
= !value_known_to_survive_p
;
3958 else if (EQ (h
->weak
, Qkey_or_value
))
3959 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3960 else if (EQ (h
->weak
, Qkey_and_value
))
3961 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3965 next
= HASH_NEXT (h
, i
);
3967 if (remove_entries_p
)
3971 /* Take out of collision chain. */
3973 HASH_INDEX (h
, bucket
) = next
;
3975 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3977 /* Add to free list. */
3978 HASH_NEXT (h
, i
) = h
->next_free
;
3981 /* Clear key, value, and hash. */
3982 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3983 HASH_HASH (h
, i
) = Qnil
;
3996 /* Make sure key and value survive. */
3997 if (!key_known_to_survive_p
)
3999 mark_object (HASH_KEY (h
, i
));
4003 if (!value_known_to_survive_p
)
4005 mark_object (HASH_VALUE (h
, i
));
4016 /* Remove elements from weak hash tables that don't survive the
4017 current garbage collection. Remove weak tables that don't survive
4018 from Vweak_hash_tables. Called from gc_sweep. */
4021 sweep_weak_hash_tables (void)
4023 struct Lisp_Hash_Table
*h
, *used
, *next
;
4026 /* Mark all keys and values that are in use. Keep on marking until
4027 there is no more change. This is necessary for cases like
4028 value-weak table A containing an entry X -> Y, where Y is used in a
4029 key-weak table B, Z -> Y. If B comes after A in the list of weak
4030 tables, X -> Y might be removed from A, although when looking at B
4031 one finds that it shouldn't. */
4035 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4037 if (h
->size
& ARRAY_MARK_FLAG
)
4038 marked
|= sweep_weak_table (h
, 0);
4043 /* Remove tables and entries that aren't used. */
4044 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4046 next
= h
->next_weak
;
4048 if (h
->size
& ARRAY_MARK_FLAG
)
4050 /* TABLE is marked as used. Sweep its contents. */
4052 sweep_weak_table (h
, 1);
4054 /* Add table to the list of used weak hash tables. */
4055 h
->next_weak
= used
;
4060 weak_hash_tables
= used
;
4065 /***********************************************************************
4066 Hash Code Computation
4067 ***********************************************************************/
4069 /* Maximum depth up to which to dive into Lisp structures. */
4071 #define SXHASH_MAX_DEPTH 3
4073 /* Maximum length up to which to take list and vector elements into
4076 #define SXHASH_MAX_LEN 7
4078 /* Combine two integers X and Y for hashing. */
4080 #define SXHASH_COMBINE(X, Y) \
4081 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4085 /* Return a hash for string PTR which has length LEN. The hash
4086 code returned is guaranteed to fit in a Lisp integer. */
4089 sxhash_string (unsigned char *ptr
, int len
)
4091 unsigned char *p
= ptr
;
4092 unsigned char *end
= p
+ len
;
4101 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4104 return hash
& INTMASK
;
4108 /* Return a hash for list LIST. DEPTH is the current depth in the
4109 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4112 sxhash_list (Lisp_Object list
, int depth
)
4117 if (depth
< SXHASH_MAX_DEPTH
)
4119 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4120 list
= XCDR (list
), ++i
)
4122 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4123 hash
= SXHASH_COMBINE (hash
, hash2
);
4128 unsigned hash2
= sxhash (list
, depth
+ 1);
4129 hash
= SXHASH_COMBINE (hash
, hash2
);
4136 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4137 the Lisp structure. */
4140 sxhash_vector (Lisp_Object vec
, int depth
)
4142 unsigned hash
= ASIZE (vec
);
4145 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4146 for (i
= 0; i
< n
; ++i
)
4148 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4149 hash
= SXHASH_COMBINE (hash
, hash2
);
4156 /* Return a hash for bool-vector VECTOR. */
4159 sxhash_bool_vector (Lisp_Object vec
)
4161 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4164 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4165 for (i
= 0; i
< n
; ++i
)
4166 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4172 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4173 structure. Value is an unsigned integer clipped to INTMASK. */
4176 sxhash (Lisp_Object obj
, int depth
)
4180 if (depth
> SXHASH_MAX_DEPTH
)
4183 switch (XTYPE (obj
))
4194 obj
= SYMBOL_NAME (obj
);
4198 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4201 /* This can be everything from a vector to an overlay. */
4202 case Lisp_Vectorlike
:
4204 /* According to the CL HyperSpec, two arrays are equal only if
4205 they are `eq', except for strings and bit-vectors. In
4206 Emacs, this works differently. We have to compare element
4208 hash
= sxhash_vector (obj
, depth
);
4209 else if (BOOL_VECTOR_P (obj
))
4210 hash
= sxhash_bool_vector (obj
);
4212 /* Others are `equal' if they are `eq', so let's take their
4218 hash
= sxhash_list (obj
, depth
);
4223 double val
= XFLOAT_DATA (obj
);
4224 unsigned char *p
= (unsigned char *) &val
;
4226 for (hash
= 0, i
= 0; i
< sizeof val
; i
++)
4227 hash
= SXHASH_COMBINE (hash
, p
[i
]);
4235 return hash
& INTMASK
;
4240 /***********************************************************************
4242 ***********************************************************************/
4245 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4246 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4249 unsigned hash
= sxhash (obj
, 0);
4250 return make_number (hash
);
4254 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4255 doc
: /* Create and return a new hash table.
4257 Arguments are specified as keyword/argument pairs. The following
4258 arguments are defined:
4260 :test TEST -- TEST must be a symbol that specifies how to compare
4261 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4262 `equal'. User-supplied test and hash functions can be specified via
4263 `define-hash-table-test'.
4265 :size SIZE -- A hint as to how many elements will be put in the table.
4268 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4269 fills up. If REHASH-SIZE is an integer, increase the size by that
4270 amount. If it is a float, it must be > 1.0, and the new size is the
4271 old size multiplied by that factor. Default is 1.5.
4273 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4274 Resize the hash table when the ratio (number of entries / table size)
4275 is greater than or equal to THRESHOLD. Default is 0.8.
4277 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4278 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4279 returned is a weak table. Key/value pairs are removed from a weak
4280 hash table when there are no non-weak references pointing to their
4281 key, value, one of key or value, or both key and value, depending on
4282 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4285 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4286 (size_t nargs
, Lisp_Object
*args
)
4288 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4289 Lisp_Object user_test
, user_hash
;
4293 /* The vector `used' is used to keep track of arguments that
4294 have been consumed. */
4295 used
= (char *) alloca (nargs
* sizeof *used
);
4296 memset (used
, 0, nargs
* sizeof *used
);
4298 /* See if there's a `:test TEST' among the arguments. */
4299 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4300 test
= i
? args
[i
] : Qeql
;
4301 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4303 /* See if it is a user-defined test. */
4306 prop
= Fget (test
, Qhash_table_test
);
4307 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4308 signal_error ("Invalid hash table test", test
);
4309 user_test
= XCAR (prop
);
4310 user_hash
= XCAR (XCDR (prop
));
4313 user_test
= user_hash
= Qnil
;
4315 /* See if there's a `:size SIZE' argument. */
4316 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4317 size
= i
? args
[i
] : Qnil
;
4319 size
= make_number (DEFAULT_HASH_SIZE
);
4320 else if (!INTEGERP (size
) || XINT (size
) < 0)
4321 signal_error ("Invalid hash table size", size
);
4323 /* Look for `:rehash-size SIZE'. */
4324 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4325 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4326 if (!NUMBERP (rehash_size
)
4327 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4328 || XFLOATINT (rehash_size
) <= 1.0)
4329 signal_error ("Invalid hash table rehash size", rehash_size
);
4331 /* Look for `:rehash-threshold THRESHOLD'. */
4332 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4333 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4334 if (!FLOATP (rehash_threshold
)
4335 || XFLOATINT (rehash_threshold
) <= 0.0
4336 || XFLOATINT (rehash_threshold
) > 1.0)
4337 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4339 /* Look for `:weakness WEAK'. */
4340 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4341 weak
= i
? args
[i
] : Qnil
;
4343 weak
= Qkey_and_value
;
4346 && !EQ (weak
, Qvalue
)
4347 && !EQ (weak
, Qkey_or_value
)
4348 && !EQ (weak
, Qkey_and_value
))
4349 signal_error ("Invalid hash table weakness", weak
);
4351 /* Now, all args should have been used up, or there's a problem. */
4352 for (i
= 0; i
< nargs
; ++i
)
4354 signal_error ("Invalid argument list", args
[i
]);
4356 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4357 user_test
, user_hash
);
4361 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4362 doc
: /* Return a copy of hash table TABLE. */)
4365 return copy_hash_table (check_hash_table (table
));
4369 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4370 doc
: /* Return the number of elements in TABLE. */)
4373 return make_number (check_hash_table (table
)->count
);
4377 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4378 Shash_table_rehash_size
, 1, 1, 0,
4379 doc
: /* Return the current rehash size of TABLE. */)
4382 return check_hash_table (table
)->rehash_size
;
4386 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4387 Shash_table_rehash_threshold
, 1, 1, 0,
4388 doc
: /* Return the current rehash threshold of TABLE. */)
4391 return check_hash_table (table
)->rehash_threshold
;
4395 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4396 doc
: /* Return the size of TABLE.
4397 The size can be used as an argument to `make-hash-table' to create
4398 a hash table than can hold as many elements as TABLE holds
4399 without need for resizing. */)
4402 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4403 return make_number (HASH_TABLE_SIZE (h
));
4407 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4408 doc
: /* Return the test TABLE uses. */)
4411 return check_hash_table (table
)->test
;
4415 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4417 doc
: /* Return the weakness of TABLE. */)
4420 return check_hash_table (table
)->weak
;
4424 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4425 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4428 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4432 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4433 doc
: /* Clear hash table TABLE and return it. */)
4436 hash_clear (check_hash_table (table
));
4437 /* Be compatible with XEmacs. */
4442 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4443 doc
: /* Look up KEY in TABLE and return its associated value.
4444 If KEY is not found, return DFLT which defaults to nil. */)
4445 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4447 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4448 int i
= hash_lookup (h
, key
, NULL
);
4449 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4453 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4454 doc
: /* Associate KEY with VALUE in hash table TABLE.
4455 If KEY is already present in table, replace its current value with
4457 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4459 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4463 i
= hash_lookup (h
, key
, &hash
);
4465 HASH_VALUE (h
, i
) = value
;
4467 hash_put (h
, key
, value
, hash
);
4473 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4474 doc
: /* Remove KEY from TABLE. */)
4475 (Lisp_Object key
, Lisp_Object table
)
4477 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4478 hash_remove_from_table (h
, key
);
4483 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4484 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4485 FUNCTION is called with two arguments, KEY and VALUE. */)
4486 (Lisp_Object function
, Lisp_Object table
)
4488 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4489 Lisp_Object args
[3];
4492 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4493 if (!NILP (HASH_HASH (h
, i
)))
4496 args
[1] = HASH_KEY (h
, i
);
4497 args
[2] = HASH_VALUE (h
, i
);
4505 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4506 Sdefine_hash_table_test
, 3, 3, 0,
4507 doc
: /* Define a new hash table test with name NAME, a symbol.
4509 In hash tables created with NAME specified as test, use TEST to
4510 compare keys, and HASH for computing hash codes of keys.
4512 TEST must be a function taking two arguments and returning non-nil if
4513 both arguments are the same. HASH must be a function taking one
4514 argument and return an integer that is the hash code of the argument.
4515 Hash code computation should use the whole value range of integers,
4516 including negative integers. */)
4517 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4519 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4524 /************************************************************************
4526 ************************************************************************/
4530 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4531 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4533 A message digest is a cryptographic checksum of a document, and the
4534 algorithm to calculate it is defined in RFC 1321.
4536 The two optional arguments START and END are character positions
4537 specifying for which part of OBJECT the message digest should be
4538 computed. If nil or omitted, the digest is computed for the whole
4541 The MD5 message digest is computed from the result of encoding the
4542 text in a coding system, not directly from the internal Emacs form of
4543 the text. The optional fourth argument CODING-SYSTEM specifies which
4544 coding system to encode the text with. It should be the same coding
4545 system that you used or will use when actually writing the text into a
4548 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4549 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4550 system would be chosen by default for writing this text into a file.
4552 If OBJECT is a string, the most preferred coding system (see the
4553 command `prefer-coding-system') is used.
4555 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4556 guesswork fails. Normally, an error is signaled in such case. */)
4557 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4559 unsigned char digest
[16];
4563 EMACS_INT size_byte
= 0;
4564 EMACS_INT start_char
= 0, end_char
= 0;
4565 EMACS_INT start_byte
= 0, end_byte
= 0;
4566 register EMACS_INT b
, e
;
4567 register struct buffer
*bp
;
4570 if (STRINGP (object
))
4572 if (NILP (coding_system
))
4574 /* Decide the coding-system to encode the data with. */
4576 if (STRING_MULTIBYTE (object
))
4577 /* use default, we can't guess correct value */
4578 coding_system
= preferred_coding_system ();
4580 coding_system
= Qraw_text
;
4583 if (NILP (Fcoding_system_p (coding_system
)))
4585 /* Invalid coding system. */
4587 if (!NILP (noerror
))
4588 coding_system
= Qraw_text
;
4590 xsignal1 (Qcoding_system_error
, coding_system
);
4593 if (STRING_MULTIBYTE (object
))
4594 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4596 size
= SCHARS (object
);
4597 size_byte
= SBYTES (object
);
4601 CHECK_NUMBER (start
);
4603 start_char
= XINT (start
);
4608 start_byte
= string_char_to_byte (object
, start_char
);
4614 end_byte
= size_byte
;
4620 end_char
= XINT (end
);
4625 end_byte
= string_char_to_byte (object
, end_char
);
4628 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4629 args_out_of_range_3 (object
, make_number (start_char
),
4630 make_number (end_char
));
4634 struct buffer
*prev
= current_buffer
;
4636 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4638 CHECK_BUFFER (object
);
4640 bp
= XBUFFER (object
);
4641 if (bp
!= current_buffer
)
4642 set_buffer_internal (bp
);
4648 CHECK_NUMBER_COERCE_MARKER (start
);
4656 CHECK_NUMBER_COERCE_MARKER (end
);
4661 temp
= b
, b
= e
, e
= temp
;
4663 if (!(BEGV
<= b
&& e
<= ZV
))
4664 args_out_of_range (start
, end
);
4666 if (NILP (coding_system
))
4668 /* Decide the coding-system to encode the data with.
4669 See fileio.c:Fwrite-region */
4671 if (!NILP (Vcoding_system_for_write
))
4672 coding_system
= Vcoding_system_for_write
;
4675 int force_raw_text
= 0;
4677 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4678 if (NILP (coding_system
)
4679 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4681 coding_system
= Qnil
;
4682 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4686 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4688 /* Check file-coding-system-alist. */
4689 Lisp_Object args
[4], val
;
4691 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4692 args
[3] = Fbuffer_file_name(object
);
4693 val
= Ffind_operation_coding_system (4, args
);
4694 if (CONSP (val
) && !NILP (XCDR (val
)))
4695 coding_system
= XCDR (val
);
4698 if (NILP (coding_system
)
4699 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4701 /* If we still have not decided a coding system, use the
4702 default value of buffer-file-coding-system. */
4703 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4707 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4708 /* Confirm that VAL can surely encode the current region. */
4709 coding_system
= call4 (Vselect_safe_coding_system_function
,
4710 make_number (b
), make_number (e
),
4711 coding_system
, Qnil
);
4714 coding_system
= Qraw_text
;
4717 if (NILP (Fcoding_system_p (coding_system
)))
4719 /* Invalid coding system. */
4721 if (!NILP (noerror
))
4722 coding_system
= Qraw_text
;
4724 xsignal1 (Qcoding_system_error
, coding_system
);
4728 object
= make_buffer_string (b
, e
, 0);
4729 if (prev
!= current_buffer
)
4730 set_buffer_internal (prev
);
4731 /* Discard the unwind protect for recovering the current
4735 if (STRING_MULTIBYTE (object
))
4736 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4739 md5_buffer (SSDATA (object
) + start_byte
,
4740 SBYTES (object
) - (size_byte
- end_byte
),
4743 for (i
= 0; i
< 16; i
++)
4744 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4747 return make_string (value
, 32);
4754 /* Hash table stuff. */
4755 Qhash_table_p
= intern_c_string ("hash-table-p");
4756 staticpro (&Qhash_table_p
);
4757 Qeq
= intern_c_string ("eq");
4759 Qeql
= intern_c_string ("eql");
4761 Qequal
= intern_c_string ("equal");
4762 staticpro (&Qequal
);
4763 QCtest
= intern_c_string (":test");
4764 staticpro (&QCtest
);
4765 QCsize
= intern_c_string (":size");
4766 staticpro (&QCsize
);
4767 QCrehash_size
= intern_c_string (":rehash-size");
4768 staticpro (&QCrehash_size
);
4769 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4770 staticpro (&QCrehash_threshold
);
4771 QCweakness
= intern_c_string (":weakness");
4772 staticpro (&QCweakness
);
4773 Qkey
= intern_c_string ("key");
4775 Qvalue
= intern_c_string ("value");
4776 staticpro (&Qvalue
);
4777 Qhash_table_test
= intern_c_string ("hash-table-test");
4778 staticpro (&Qhash_table_test
);
4779 Qkey_or_value
= intern_c_string ("key-or-value");
4780 staticpro (&Qkey_or_value
);
4781 Qkey_and_value
= intern_c_string ("key-and-value");
4782 staticpro (&Qkey_and_value
);
4785 defsubr (&Smake_hash_table
);
4786 defsubr (&Scopy_hash_table
);
4787 defsubr (&Shash_table_count
);
4788 defsubr (&Shash_table_rehash_size
);
4789 defsubr (&Shash_table_rehash_threshold
);
4790 defsubr (&Shash_table_size
);
4791 defsubr (&Shash_table_test
);
4792 defsubr (&Shash_table_weakness
);
4793 defsubr (&Shash_table_p
);
4794 defsubr (&Sclrhash
);
4795 defsubr (&Sgethash
);
4796 defsubr (&Sputhash
);
4797 defsubr (&Sremhash
);
4798 defsubr (&Smaphash
);
4799 defsubr (&Sdefine_hash_table_test
);
4801 Qstring_lessp
= intern_c_string ("string-lessp");
4802 staticpro (&Qstring_lessp
);
4803 Qprovide
= intern_c_string ("provide");
4804 staticpro (&Qprovide
);
4805 Qrequire
= intern_c_string ("require");
4806 staticpro (&Qrequire
);
4807 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4808 staticpro (&Qyes_or_no_p_history
);
4809 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4810 staticpro (&Qcursor_in_echo_area
);
4811 Qwidget_type
= intern_c_string ("widget-type");
4812 staticpro (&Qwidget_type
);
4814 staticpro (&string_char_byte_cache_string
);
4815 string_char_byte_cache_string
= Qnil
;
4817 require_nesting_list
= Qnil
;
4818 staticpro (&require_nesting_list
);
4820 Fset (Qyes_or_no_p_history
, Qnil
);
4822 DEFVAR_LISP ("features", Vfeatures
,
4823 doc
: /* A list of symbols which are the features of the executing Emacs.
4824 Used by `featurep' and `require', and altered by `provide'. */);
4825 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4826 Qsubfeatures
= intern_c_string ("subfeatures");
4827 staticpro (&Qsubfeatures
);
4829 #ifdef HAVE_LANGINFO_CODESET
4830 Qcodeset
= intern_c_string ("codeset");
4831 staticpro (&Qcodeset
);
4832 Qdays
= intern_c_string ("days");
4834 Qmonths
= intern_c_string ("months");
4835 staticpro (&Qmonths
);
4836 Qpaper
= intern_c_string ("paper");
4837 staticpro (&Qpaper
);
4838 #endif /* HAVE_LANGINFO_CODESET */
4840 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4841 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4842 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4843 invoked by mouse clicks and mouse menu items.
4845 On some platforms, file selection dialogs are also enabled if this is
4849 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4850 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4851 This applies to commands from menus and tool bar buttons even when
4852 they are initiated from the keyboard. If `use-dialog-box' is nil,
4853 that disables the use of a file dialog, regardless of the value of
4855 use_file_dialog
= 1;
4857 defsubr (&Sidentity
);
4860 defsubr (&Ssafe_length
);
4861 defsubr (&Sstring_bytes
);
4862 defsubr (&Sstring_equal
);
4863 defsubr (&Scompare_strings
);
4864 defsubr (&Sstring_lessp
);
4867 defsubr (&Svconcat
);
4868 defsubr (&Scopy_sequence
);
4869 defsubr (&Sstring_make_multibyte
);
4870 defsubr (&Sstring_make_unibyte
);
4871 defsubr (&Sstring_as_multibyte
);
4872 defsubr (&Sstring_as_unibyte
);
4873 defsubr (&Sstring_to_multibyte
);
4874 defsubr (&Sstring_to_unibyte
);
4875 defsubr (&Scopy_alist
);
4876 defsubr (&Ssubstring
);
4877 defsubr (&Ssubstring_no_properties
);
4890 defsubr (&Snreverse
);
4891 defsubr (&Sreverse
);
4893 defsubr (&Splist_get
);
4895 defsubr (&Splist_put
);
4897 defsubr (&Slax_plist_get
);
4898 defsubr (&Slax_plist_put
);
4901 defsubr (&Sequal_including_properties
);
4902 defsubr (&Sfillarray
);
4903 defsubr (&Sclear_string
);
4907 defsubr (&Smapconcat
);
4908 defsubr (&Syes_or_no_p
);
4909 defsubr (&Sload_average
);
4910 defsubr (&Sfeaturep
);
4911 defsubr (&Srequire
);
4912 defsubr (&Sprovide
);
4913 defsubr (&Splist_member
);
4914 defsubr (&Swidget_put
);
4915 defsubr (&Swidget_get
);
4916 defsubr (&Swidget_apply
);
4917 defsubr (&Sbase64_encode_region
);
4918 defsubr (&Sbase64_decode_region
);
4919 defsubr (&Sbase64_encode_string
);
4920 defsubr (&Sbase64_decode_string
);
4922 defsubr (&Slocale_info
);