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
;
53 static Lisp_Object Qprovide
, Qrequire
;
54 static Lisp_Object Qyes_or_no_p_history
;
55 Lisp_Object Qcursor_in_echo_area
;
56 static Lisp_Object Qwidget_type
;
57 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
59 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
65 DEFUE ("identity", Fidentity
, Sidentity
, 1, 1, 0,
66 doc
: /* Return the argument unchanged. */)
72 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
73 doc
: /* Return a pseudo-random number.
74 All integers representable in Lisp are equally likely.
75 On most systems, this is 29 bits' worth.
76 With positive integer LIMIT, return random number in interval [0,LIMIT).
77 With argument t, set the random number seed from the current time and pid.
78 Other values of LIMIT are ignored. */)
82 Lisp_Object lispy_val
;
83 unsigned long denominator
;
86 seed_random (getpid () + time (NULL
));
87 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
89 /* Try to take our random number from the higher bits of VAL,
90 not the lower, since (says Gentzel) the low bits of `random'
91 are less random than the higher ones. We do this by using the
92 quotient rather than the remainder. At the high end of the RNG
93 it's possible to get a quotient larger than n; discarding
94 these values eliminates the bias that would otherwise appear
95 when using a large n. */
96 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
98 val
= get_random () / denominator
;
99 while (val
>= XFASTINT (limit
));
103 XSETINT (lispy_val
, val
);
107 /* Random data-structure functions */
109 DEFUE ("length", Flength
, Slength
, 1, 1, 0,
110 doc
: /* Return the length of vector, list or string SEQUENCE.
111 A byte-code function object is also allowed.
112 If the string contains multibyte characters, this is not necessarily
113 the number of bytes in the string; it is the number of characters.
114 To get the number of bytes, use `string-bytes'. */)
115 (register Lisp_Object sequence
)
117 register Lisp_Object val
;
120 if (STRINGP (sequence
))
121 XSETFASTINT (val
, SCHARS (sequence
));
122 else if (VECTORP (sequence
))
123 XSETFASTINT (val
, ASIZE (sequence
));
124 else if (CHAR_TABLE_P (sequence
))
125 XSETFASTINT (val
, MAX_CHAR
);
126 else if (BOOL_VECTOR_P (sequence
))
127 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
128 else if (COMPILEDP (sequence
))
129 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
130 else if (CONSP (sequence
))
133 while (CONSP (sequence
))
135 sequence
= XCDR (sequence
);
138 if (!CONSP (sequence
))
141 sequence
= XCDR (sequence
);
146 CHECK_LIST_END (sequence
, sequence
);
148 val
= make_number (i
);
150 else if (NILP (sequence
))
151 XSETFASTINT (val
, 0);
153 wrong_type_argument (Qsequencep
, sequence
);
158 /* This does not check for quits. That is safe since it must terminate. */
160 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
161 doc
: /* Return the length of a list, but avoid error or infinite loop.
162 This function never gets an error. If LIST is not really a list,
163 it returns 0. If LIST is circular, it returns a finite value
164 which is at least the number of distinct elements. */)
167 Lisp_Object tail
, halftail
, length
;
170 /* halftail is used to detect circular lists. */
172 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
174 if (EQ (tail
, halftail
) && len
!= 0)
178 halftail
= XCDR (halftail
);
181 XSETINT (length
, len
);
185 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
186 doc
: /* Return the number of bytes in STRING.
187 If STRING is multibyte, this may be greater than the length of STRING. */)
190 CHECK_STRING (string
);
191 return make_number (SBYTES (string
));
194 DEFUE ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
195 doc
: /* Return t if two strings have identical contents.
196 Case is significant, but text properties are ignored.
197 Symbols are also allowed; their print names are used instead. */)
198 (register Lisp_Object s1
, Lisp_Object s2
)
201 s1
= SYMBOL_NAME (s1
);
203 s2
= SYMBOL_NAME (s2
);
207 if (SCHARS (s1
) != SCHARS (s2
)
208 || SBYTES (s1
) != SBYTES (s2
)
209 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
214 DEFUE ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
215 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
216 In string STR1, skip the first START1 characters and stop at END1.
217 In string STR2, skip the first START2 characters and stop at END2.
218 END1 and END2 default to the full lengths of the respective strings.
220 Case is significant in this comparison if IGNORE-CASE is nil.
221 Unibyte strings are converted to multibyte for comparison.
223 The value is t if the strings (or specified portions) match.
224 If string STR1 is less, the value is a negative number N;
225 - 1 - N is the number of characters that match at the beginning.
226 If string STR1 is greater, the value is a positive number N;
227 N - 1 is the number of characters that match at the beginning. */)
228 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
230 register EMACS_INT end1_char
, end2_char
;
231 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
236 start1
= make_number (0);
238 start2
= make_number (0);
239 CHECK_NATNUM (start1
);
240 CHECK_NATNUM (start2
);
249 i1_byte
= string_char_to_byte (str1
, i1
);
250 i2_byte
= string_char_to_byte (str2
, i2
);
252 end1_char
= SCHARS (str1
);
253 if (! NILP (end1
) && end1_char
> XINT (end1
))
254 end1_char
= XINT (end1
);
256 end2_char
= SCHARS (str2
);
257 if (! NILP (end2
) && end2_char
> XINT (end2
))
258 end2_char
= XINT (end2
);
260 while (i1
< end1_char
&& i2
< end2_char
)
262 /* When we find a mismatch, we must compare the
263 characters, not just the bytes. */
266 if (STRING_MULTIBYTE (str1
))
267 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
270 c1
= SREF (str1
, i1
++);
271 MAKE_CHAR_MULTIBYTE (c1
);
274 if (STRING_MULTIBYTE (str2
))
275 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
278 c2
= SREF (str2
, i2
++);
279 MAKE_CHAR_MULTIBYTE (c2
);
285 if (! NILP (ignore_case
))
289 tem
= Fupcase (make_number (c1
));
291 tem
= Fupcase (make_number (c2
));
298 /* Note that I1 has already been incremented
299 past the character that we are comparing;
300 hence we don't add or subtract 1 here. */
302 return make_number (- i1
+ XINT (start1
));
304 return make_number (i1
- XINT (start1
));
308 return make_number (i1
- XINT (start1
) + 1);
310 return make_number (- i1
+ XINT (start1
) - 1);
315 DEFUE ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
316 doc
: /* Return t if first arg string is less than second in lexicographic order.
318 Symbols are also allowed; their print names are used instead. */)
319 (register Lisp_Object s1
, Lisp_Object s2
)
321 register EMACS_INT end
;
322 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
325 s1
= SYMBOL_NAME (s1
);
327 s2
= SYMBOL_NAME (s2
);
331 i1
= i1_byte
= i2
= i2_byte
= 0;
334 if (end
> SCHARS (s2
))
339 /* When we find a mismatch, we must compare the
340 characters, not just the bytes. */
343 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
344 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
347 return c1
< c2
? Qt
: Qnil
;
349 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
352 static Lisp_Object
concat (size_t nargs
, Lisp_Object
*args
,
353 enum Lisp_Type target_type
, int last_special
);
357 concat2 (Lisp_Object s1
, Lisp_Object s2
)
362 return concat (2, args
, Lisp_String
, 0);
367 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
373 return concat (3, args
, Lisp_String
, 0);
376 DEFUE ("append", Fappend
, Sappend
, 0, MANY
, 0,
377 doc
: /* Concatenate all the arguments and make the result a list.
378 The result is a list whose elements are the elements of all the arguments.
379 Each argument may be a list, vector or string.
380 The last argument is not copied, just used as the tail of the new list.
381 usage: (append &rest SEQUENCES) */)
382 (size_t nargs
, Lisp_Object
*args
)
384 return concat (nargs
, args
, Lisp_Cons
, 1);
387 DEFUE ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
388 doc
: /* Concatenate all the arguments and make the result a string.
389 The result is a string whose elements are the elements of all the arguments.
390 Each argument may be a string or a list or vector of characters (integers).
391 usage: (concat &rest SEQUENCES) */)
392 (size_t nargs
, Lisp_Object
*args
)
394 return concat (nargs
, args
, Lisp_String
, 0);
397 DEFUE ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
398 doc
: /* Concatenate all the arguments and make the result a vector.
399 The result is a vector whose elements are the elements of all the arguments.
400 Each argument may be a list, vector or string.
401 usage: (vconcat &rest SEQUENCES) */)
402 (size_t nargs
, Lisp_Object
*args
)
404 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
408 DEFUE ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
409 doc
: /* Return a copy of a list, vector, string or char-table.
410 The elements of a list or vector are not copied; they are shared
411 with the original. */)
414 if (NILP (arg
)) return arg
;
416 if (CHAR_TABLE_P (arg
))
418 return copy_char_table (arg
);
421 if (BOOL_VECTOR_P (arg
))
425 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
426 / BOOL_VECTOR_BITS_PER_CHAR
);
428 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
429 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
434 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
435 wrong_type_argument (Qsequencep
, arg
);
437 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
440 /* This structure holds information of an argument of `concat' that is
441 a string and has text properties to be copied. */
444 int argnum
; /* refer to ARGS (arguments of `concat') */
445 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
446 EMACS_INT to
; /* refer to VAL (the target string) */
450 concat (size_t nargs
, Lisp_Object
*args
,
451 enum Lisp_Type target_type
, int last_special
)
454 register Lisp_Object tail
;
455 register Lisp_Object
this;
457 EMACS_INT toindex_byte
= 0;
458 register EMACS_INT result_len
;
459 register EMACS_INT result_len_byte
;
460 register size_t argnum
;
461 Lisp_Object last_tail
;
464 /* When we make a multibyte string, we can't copy text properties
465 while concatinating each string because the length of resulting
466 string can't be decided until we finish the whole concatination.
467 So, we record strings that have text properties to be copied
468 here, and copy the text properties after the concatination. */
469 struct textprop_rec
*textprops
= NULL
;
470 /* Number of elements in textprops. */
471 int num_textprops
= 0;
476 /* In append, the last arg isn't treated like the others */
477 if (last_special
&& nargs
> 0)
480 last_tail
= args
[nargs
];
485 /* Check each argument. */
486 for (argnum
= 0; argnum
< nargs
; argnum
++)
489 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
490 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
491 wrong_type_argument (Qsequencep
, this);
494 /* Compute total length in chars of arguments in RESULT_LEN.
495 If desired output is a string, also compute length in bytes
496 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
497 whether the result should be a multibyte string. */
501 for (argnum
= 0; argnum
< nargs
; argnum
++)
505 len
= XFASTINT (Flength (this));
506 if (target_type
== Lisp_String
)
508 /* We must count the number of bytes needed in the string
509 as well as the number of characters. */
512 EMACS_INT this_len_byte
;
514 if (VECTORP (this) || COMPILEDP (this))
515 for (i
= 0; i
< len
; i
++)
518 CHECK_CHARACTER (ch
);
519 this_len_byte
= CHAR_BYTES (XINT (ch
));
520 result_len_byte
+= this_len_byte
;
521 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
524 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
525 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
526 else if (CONSP (this))
527 for (; CONSP (this); this = XCDR (this))
530 CHECK_CHARACTER (ch
);
531 this_len_byte
= CHAR_BYTES (XINT (ch
));
532 result_len_byte
+= this_len_byte
;
533 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
536 else if (STRINGP (this))
538 if (STRING_MULTIBYTE (this))
541 result_len_byte
+= SBYTES (this);
544 result_len_byte
+= count_size_as_multibyte (SDATA (this),
551 error ("String overflow");
554 if (! some_multibyte
)
555 result_len_byte
= result_len
;
557 /* Create the output object. */
558 if (target_type
== Lisp_Cons
)
559 val
= Fmake_list (make_number (result_len
), Qnil
);
560 else if (target_type
== Lisp_Vectorlike
)
561 val
= Fmake_vector (make_number (result_len
), Qnil
);
562 else if (some_multibyte
)
563 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
565 val
= make_uninit_string (result_len
);
567 /* In `append', if all but last arg are nil, return last arg. */
568 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
571 /* Copy the contents of the args into the result. */
573 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
575 toindex
= 0, toindex_byte
= 0;
579 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
581 for (argnum
= 0; argnum
< nargs
; argnum
++)
584 EMACS_INT thisleni
= 0;
585 register EMACS_INT thisindex
= 0;
586 register EMACS_INT thisindex_byte
= 0;
590 thislen
= Flength (this), thisleni
= XINT (thislen
);
592 /* Between strings of the same kind, copy fast. */
593 if (STRINGP (this) && STRINGP (val
)
594 && STRING_MULTIBYTE (this) == some_multibyte
)
596 EMACS_INT thislen_byte
= SBYTES (this);
598 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
599 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
601 textprops
[num_textprops
].argnum
= argnum
;
602 textprops
[num_textprops
].from
= 0;
603 textprops
[num_textprops
++].to
= toindex
;
605 toindex_byte
+= thislen_byte
;
608 /* Copy a single-byte string to a multibyte string. */
609 else if (STRINGP (this) && STRINGP (val
))
611 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
613 textprops
[num_textprops
].argnum
= argnum
;
614 textprops
[num_textprops
].from
= 0;
615 textprops
[num_textprops
++].to
= toindex
;
617 toindex_byte
+= copy_text (SDATA (this),
618 SDATA (val
) + toindex_byte
,
619 SCHARS (this), 0, 1);
623 /* Copy element by element. */
626 register Lisp_Object elt
;
628 /* Fetch next element of `this' arg into `elt', or break if
629 `this' is exhausted. */
630 if (NILP (this)) break;
632 elt
= XCAR (this), this = XCDR (this);
633 else if (thisindex
>= thisleni
)
635 else if (STRINGP (this))
638 if (STRING_MULTIBYTE (this))
640 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
643 XSETFASTINT (elt
, c
);
647 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
649 && !ASCII_CHAR_P (XINT (elt
))
650 && XINT (elt
) < 0400)
652 c
= BYTE8_TO_CHAR (XINT (elt
));
657 else if (BOOL_VECTOR_P (this))
660 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
661 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
669 elt
= AREF (this, thisindex
);
673 /* Store this element into the result. */
680 else if (VECTORP (val
))
682 ASET (val
, toindex
, elt
);
689 toindex_byte
+= CHAR_STRING (XINT (elt
),
690 SDATA (val
) + toindex_byte
);
692 SSET (val
, toindex_byte
++, XINT (elt
));
698 XSETCDR (prev
, last_tail
);
700 if (num_textprops
> 0)
703 EMACS_INT last_to_end
= -1;
705 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
707 this = args
[textprops
[argnum
].argnum
];
708 props
= text_property_list (this,
710 make_number (SCHARS (this)),
712 /* If successive arguments have properites, be sure that the
713 value of `composition' property be the copy. */
714 if (last_to_end
== textprops
[argnum
].to
)
715 make_composition_value_copy (props
);
716 add_text_properties_from_list (val
, props
,
717 make_number (textprops
[argnum
].to
));
718 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
726 static Lisp_Object string_char_byte_cache_string
;
727 static EMACS_INT string_char_byte_cache_charpos
;
728 static EMACS_INT string_char_byte_cache_bytepos
;
731 clear_string_char_byte_cache (void)
733 string_char_byte_cache_string
= Qnil
;
736 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
739 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
742 EMACS_INT best_below
, best_below_byte
;
743 EMACS_INT best_above
, best_above_byte
;
745 best_below
= best_below_byte
= 0;
746 best_above
= SCHARS (string
);
747 best_above_byte
= SBYTES (string
);
748 if (best_above
== best_above_byte
)
751 if (EQ (string
, string_char_byte_cache_string
))
753 if (string_char_byte_cache_charpos
< char_index
)
755 best_below
= string_char_byte_cache_charpos
;
756 best_below_byte
= string_char_byte_cache_bytepos
;
760 best_above
= string_char_byte_cache_charpos
;
761 best_above_byte
= string_char_byte_cache_bytepos
;
765 if (char_index
- best_below
< best_above
- char_index
)
767 unsigned char *p
= SDATA (string
) + best_below_byte
;
769 while (best_below
< char_index
)
771 p
+= BYTES_BY_CHAR_HEAD (*p
);
774 i_byte
= p
- SDATA (string
);
778 unsigned char *p
= SDATA (string
) + best_above_byte
;
780 while (best_above
> char_index
)
783 while (!CHAR_HEAD_P (*p
)) p
--;
786 i_byte
= p
- SDATA (string
);
789 string_char_byte_cache_bytepos
= i_byte
;
790 string_char_byte_cache_charpos
= char_index
;
791 string_char_byte_cache_string
= string
;
796 /* Return the character index corresponding to BYTE_INDEX in STRING. */
799 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
802 EMACS_INT best_below
, best_below_byte
;
803 EMACS_INT best_above
, best_above_byte
;
805 best_below
= best_below_byte
= 0;
806 best_above
= SCHARS (string
);
807 best_above_byte
= SBYTES (string
);
808 if (best_above
== best_above_byte
)
811 if (EQ (string
, string_char_byte_cache_string
))
813 if (string_char_byte_cache_bytepos
< byte_index
)
815 best_below
= string_char_byte_cache_charpos
;
816 best_below_byte
= string_char_byte_cache_bytepos
;
820 best_above
= string_char_byte_cache_charpos
;
821 best_above_byte
= string_char_byte_cache_bytepos
;
825 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
827 unsigned char *p
= SDATA (string
) + best_below_byte
;
828 unsigned char *pend
= SDATA (string
) + byte_index
;
832 p
+= BYTES_BY_CHAR_HEAD (*p
);
836 i_byte
= p
- SDATA (string
);
840 unsigned char *p
= SDATA (string
) + best_above_byte
;
841 unsigned char *pbeg
= SDATA (string
) + byte_index
;
846 while (!CHAR_HEAD_P (*p
)) p
--;
850 i_byte
= p
- SDATA (string
);
853 string_char_byte_cache_bytepos
= i_byte
;
854 string_char_byte_cache_charpos
= i
;
855 string_char_byte_cache_string
= string
;
860 /* Convert STRING to a multibyte string. */
863 string_make_multibyte (Lisp_Object string
)
870 if (STRING_MULTIBYTE (string
))
873 nbytes
= count_size_as_multibyte (SDATA (string
),
875 /* If all the chars are ASCII, they won't need any more bytes
876 once converted. In that case, we can return STRING itself. */
877 if (nbytes
== SBYTES (string
))
880 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
881 copy_text (SDATA (string
), buf
, SBYTES (string
),
884 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
891 /* Convert STRING (if unibyte) to a multibyte string without changing
892 the number of characters. Characters 0200 trough 0237 are
893 converted to eight-bit characters. */
896 string_to_multibyte (Lisp_Object string
)
903 if (STRING_MULTIBYTE (string
))
906 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
907 /* If all the chars are ASCII, they won't need any more bytes once
909 if (nbytes
== SBYTES (string
))
910 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
912 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
913 memcpy (buf
, SDATA (string
), SBYTES (string
));
914 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
916 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
923 /* Convert STRING to a single-byte string. */
926 string_make_unibyte (Lisp_Object string
)
933 if (! STRING_MULTIBYTE (string
))
936 nchars
= SCHARS (string
);
938 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
939 copy_text (SDATA (string
), buf
, SBYTES (string
),
942 ret
= make_unibyte_string ((char *) buf
, nchars
);
948 DEFUE ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
950 doc
: /* Return the multibyte equivalent of STRING.
951 If STRING is unibyte and contains non-ASCII characters, the function
952 `unibyte-char-to-multibyte' is used to convert each unibyte character
953 to a multibyte character. In this case, the returned string is a
954 newly created string with no text properties. If STRING is multibyte
955 or entirely ASCII, it is returned unchanged. In particular, when
956 STRING is unibyte and entirely ASCII, the returned string is unibyte.
957 \(When the characters are all ASCII, Emacs primitives will treat the
958 string the same way whether it is unibyte or multibyte.) */)
961 CHECK_STRING (string
);
963 return string_make_multibyte (string
);
966 DEFUE ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
968 doc
: /* Return the unibyte equivalent of STRING.
969 Multibyte character codes are converted to unibyte according to
970 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
971 If the lookup in the translation table fails, this function takes just
972 the low 8 bits of each character. */)
975 CHECK_STRING (string
);
977 return string_make_unibyte (string
);
980 DEFUE ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
982 doc
: /* Return a unibyte string with the same individual bytes as STRING.
983 If STRING is unibyte, the result is STRING itself.
984 Otherwise it is a newly created string, with no text properties.
985 If STRING is multibyte and contains a character of charset
986 `eight-bit', it is converted to the corresponding single byte. */)
989 CHECK_STRING (string
);
991 if (STRING_MULTIBYTE (string
))
993 EMACS_INT bytes
= SBYTES (string
);
994 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
996 memcpy (str
, SDATA (string
), bytes
);
997 bytes
= str_as_unibyte (str
, bytes
);
998 string
= make_unibyte_string ((char *) str
, bytes
);
1004 DEFUE ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1006 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1007 If STRING is multibyte, the result is STRING itself.
1008 Otherwise it is a newly created string, with no text properties.
1010 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1011 part of a correct utf-8 sequence), it is converted to the corresponding
1012 multibyte character of charset `eight-bit'.
1013 See also `string-to-multibyte'.
1015 Beware, this often doesn't really do what you think it does.
1016 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1017 If you're not sure, whether to use `string-as-multibyte' or
1018 `string-to-multibyte', use `string-to-multibyte'. */)
1019 (Lisp_Object string
)
1021 CHECK_STRING (string
);
1023 if (! STRING_MULTIBYTE (string
))
1025 Lisp_Object new_string
;
1026 EMACS_INT nchars
, nbytes
;
1028 parse_str_as_multibyte (SDATA (string
),
1031 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1032 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1033 if (nbytes
!= SBYTES (string
))
1034 str_as_multibyte (SDATA (new_string
), nbytes
,
1035 SBYTES (string
), NULL
);
1036 string
= new_string
;
1037 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1042 DEFUE ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1044 doc
: /* Return a multibyte string with the same individual chars as STRING.
1045 If STRING is multibyte, the result is STRING itself.
1046 Otherwise it is a newly created string, with no text properties.
1048 If STRING is unibyte and contains an 8-bit byte, it is converted to
1049 the corresponding multibyte character of charset `eight-bit'.
1051 This differs from `string-as-multibyte' by converting each byte of a correct
1052 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1053 correct sequence. */)
1054 (Lisp_Object string
)
1056 CHECK_STRING (string
);
1058 return string_to_multibyte (string
);
1061 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1063 doc
: /* Return a unibyte string with the same individual chars as STRING.
1064 If STRING is unibyte, the result is STRING itself.
1065 Otherwise it is a newly created string, with no text properties,
1066 where each `eight-bit' character is converted to the corresponding byte.
1067 If STRING contains a non-ASCII, non-`eight-bit' character,
1068 an error is signaled. */)
1069 (Lisp_Object string
)
1071 CHECK_STRING (string
);
1073 if (STRING_MULTIBYTE (string
))
1075 EMACS_INT chars
= SCHARS (string
);
1076 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1077 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1079 if (converted
< chars
)
1080 error ("Can't convert the %"pEd
"th character to unibyte", converted
);
1081 string
= make_unibyte_string ((char *) str
, chars
);
1088 DEFUE ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1089 doc
: /* Return a copy of ALIST.
1090 This is an alist which represents the same mapping from objects to objects,
1091 but does not share the alist structure with ALIST.
1092 The objects mapped (cars and cdrs of elements of the alist)
1093 are shared, however.
1094 Elements of ALIST that are not conses are also shared. */)
1097 register Lisp_Object tem
;
1102 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1103 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1105 register Lisp_Object car
;
1109 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1114 DEFUE ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1115 doc
: /* Return a new string whose contents are a substring of STRING.
1116 The returned string consists of the characters between index FROM
1117 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1118 zero-indexed: 0 means the first character of STRING. Negative values
1119 are counted from the end of STRING. If TO is nil, the substring runs
1120 to the end of STRING.
1122 The STRING argument may also be a vector. In that case, the return
1123 value is a new vector that contains the elements between index FROM
1124 \(inclusive) and index TO (exclusive) of that vector argument. */)
1125 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1129 EMACS_INT size_byte
= 0;
1130 EMACS_INT from_char
, to_char
;
1131 EMACS_INT from_byte
= 0, to_byte
= 0;
1133 CHECK_VECTOR_OR_STRING (string
);
1134 CHECK_NUMBER (from
);
1136 if (STRINGP (string
))
1138 size
= SCHARS (string
);
1139 size_byte
= SBYTES (string
);
1142 size
= ASIZE (string
);
1147 to_byte
= size_byte
;
1153 to_char
= XINT (to
);
1157 if (STRINGP (string
))
1158 to_byte
= string_char_to_byte (string
, to_char
);
1161 from_char
= XINT (from
);
1164 if (STRINGP (string
))
1165 from_byte
= string_char_to_byte (string
, from_char
);
1167 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1168 args_out_of_range_3 (string
, make_number (from_char
),
1169 make_number (to_char
));
1171 if (STRINGP (string
))
1173 res
= make_specified_string (SSDATA (string
) + from_byte
,
1174 to_char
- from_char
, to_byte
- from_byte
,
1175 STRING_MULTIBYTE (string
));
1176 copy_text_properties (make_number (from_char
), make_number (to_char
),
1177 string
, make_number (0), res
, Qnil
);
1180 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1186 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1187 doc
: /* Return a substring of STRING, without text properties.
1188 It starts at index FROM and ends before TO.
1189 TO may be nil or omitted; then the substring runs to the end of STRING.
1190 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1191 If FROM or TO is negative, it counts from the end.
1193 With one argument, just copy STRING without its properties. */)
1194 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1196 EMACS_INT size
, size_byte
;
1197 EMACS_INT from_char
, to_char
;
1198 EMACS_INT from_byte
, to_byte
;
1200 CHECK_STRING (string
);
1202 size
= SCHARS (string
);
1203 size_byte
= SBYTES (string
);
1206 from_char
= from_byte
= 0;
1209 CHECK_NUMBER (from
);
1210 from_char
= XINT (from
);
1214 from_byte
= string_char_to_byte (string
, from_char
);
1220 to_byte
= size_byte
;
1226 to_char
= XINT (to
);
1230 to_byte
= string_char_to_byte (string
, to_char
);
1233 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1234 args_out_of_range_3 (string
, make_number (from_char
),
1235 make_number (to_char
));
1237 return make_specified_string (SSDATA (string
) + from_byte
,
1238 to_char
- from_char
, to_byte
- from_byte
,
1239 STRING_MULTIBYTE (string
));
1242 /* Extract a substring of STRING, giving start and end positions
1243 both in characters and in bytes. */
1246 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1247 EMACS_INT to
, EMACS_INT to_byte
)
1252 CHECK_VECTOR_OR_STRING (string
);
1254 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1256 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1257 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1259 if (STRINGP (string
))
1261 res
= make_specified_string (SSDATA (string
) + from_byte
,
1262 to
- from
, to_byte
- from_byte
,
1263 STRING_MULTIBYTE (string
));
1264 copy_text_properties (make_number (from
), make_number (to
),
1265 string
, make_number (0), res
, Qnil
);
1268 res
= Fvector (to
- from
, &AREF (string
, from
));
1273 DEFUE ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1274 doc
: /* Take cdr N times on LIST, return the result. */)
1275 (Lisp_Object n
, Lisp_Object list
)
1277 register int i
, num
;
1280 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1283 CHECK_LIST_CONS (list
, list
);
1289 DEFUE ("nth", Fnth
, Snth
, 2, 2, 0,
1290 doc
: /* Return the Nth element of LIST.
1291 N counts from zero. If LIST is not that long, nil is returned. */)
1292 (Lisp_Object n
, Lisp_Object list
)
1294 return Fcar (Fnthcdr (n
, list
));
1297 DEFUE ("elt", Felt
, Selt
, 2, 2, 0,
1298 doc
: /* Return element of SEQUENCE at index N. */)
1299 (register Lisp_Object sequence
, Lisp_Object n
)
1302 if (CONSP (sequence
) || NILP (sequence
))
1303 return Fcar (Fnthcdr (n
, sequence
));
1305 /* Faref signals a "not array" error, so check here. */
1306 CHECK_ARRAY (sequence
, Qsequencep
);
1307 return Faref (sequence
, n
);
1310 DEFUE ("member", Fmember
, Smember
, 2, 2, 0,
1311 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1312 The value is actually the tail of LIST whose car is ELT. */)
1313 (register Lisp_Object elt
, Lisp_Object list
)
1315 register Lisp_Object tail
;
1316 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1318 register Lisp_Object tem
;
1319 CHECK_LIST_CONS (tail
, list
);
1321 if (! NILP (Fequal (elt
, tem
)))
1328 DEFUE ("memq", Fmemq
, Smemq
, 2, 2, 0,
1329 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1330 The value is actually the tail of LIST whose car is ELT. */)
1331 (register Lisp_Object elt
, Lisp_Object list
)
1335 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1339 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1343 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1354 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1355 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1356 The value is actually the tail of LIST whose car is ELT. */)
1357 (register Lisp_Object elt
, Lisp_Object list
)
1359 register Lisp_Object tail
;
1362 return Fmemq (elt
, list
);
1364 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1366 register Lisp_Object tem
;
1367 CHECK_LIST_CONS (tail
, list
);
1369 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1376 DEFUE ("assq", Fassq
, Sassq
, 2, 2, 0,
1377 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1378 The value is actually the first element of LIST whose car is KEY.
1379 Elements of LIST that are not conses are ignored. */)
1380 (Lisp_Object key
, Lisp_Object list
)
1385 || (CONSP (XCAR (list
))
1386 && EQ (XCAR (XCAR (list
)), key
)))
1391 || (CONSP (XCAR (list
))
1392 && EQ (XCAR (XCAR (list
)), key
)))
1397 || (CONSP (XCAR (list
))
1398 && EQ (XCAR (XCAR (list
)), key
)))
1408 /* Like Fassq but never report an error and do not allow quits.
1409 Use only on lists known never to be circular. */
1412 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1415 && (!CONSP (XCAR (list
))
1416 || !EQ (XCAR (XCAR (list
)), key
)))
1419 return CAR_SAFE (list
);
1422 DEFUE ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1423 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1424 The value is actually the first element of LIST whose car equals KEY. */)
1425 (Lisp_Object key
, Lisp_Object list
)
1432 || (CONSP (XCAR (list
))
1433 && (car
= XCAR (XCAR (list
)),
1434 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1439 || (CONSP (XCAR (list
))
1440 && (car
= XCAR (XCAR (list
)),
1441 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1446 || (CONSP (XCAR (list
))
1447 && (car
= XCAR (XCAR (list
)),
1448 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1458 /* Like Fassoc but never report an error and do not allow quits.
1459 Use only on lists known never to be circular. */
1462 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1465 && (!CONSP (XCAR (list
))
1466 || (!EQ (XCAR (XCAR (list
)), key
)
1467 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1470 return CONSP (list
) ? XCAR (list
) : Qnil
;
1473 DEFUE ("rassq", Frassq
, Srassq
, 2, 2, 0,
1474 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1475 The value is actually the first element of LIST whose cdr is KEY. */)
1476 (register Lisp_Object key
, Lisp_Object list
)
1481 || (CONSP (XCAR (list
))
1482 && EQ (XCDR (XCAR (list
)), key
)))
1487 || (CONSP (XCAR (list
))
1488 && EQ (XCDR (XCAR (list
)), key
)))
1493 || (CONSP (XCAR (list
))
1494 && EQ (XCDR (XCAR (list
)), key
)))
1504 DEFUE ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1505 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1506 The value is actually the first element of LIST whose cdr equals KEY. */)
1507 (Lisp_Object key
, Lisp_Object list
)
1514 || (CONSP (XCAR (list
))
1515 && (cdr
= XCDR (XCAR (list
)),
1516 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1521 || (CONSP (XCAR (list
))
1522 && (cdr
= XCDR (XCAR (list
)),
1523 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1528 || (CONSP (XCAR (list
))
1529 && (cdr
= XCDR (XCAR (list
)),
1530 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1540 DEFUE ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1541 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1542 The modified LIST is returned. Comparison is done with `eq'.
1543 If the first member of LIST is ELT, there is no way to remove it by side effect;
1544 therefore, write `(setq foo (delq element foo))'
1545 to be sure of changing the value of `foo'. */)
1546 (register Lisp_Object elt
, Lisp_Object list
)
1548 register Lisp_Object tail
, prev
;
1549 register Lisp_Object tem
;
1553 while (!NILP (tail
))
1555 CHECK_LIST_CONS (tail
, list
);
1562 Fsetcdr (prev
, XCDR (tail
));
1572 DEFUE ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1573 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1574 SEQ must be a list, a vector, or a string.
1575 The modified SEQ is returned. Comparison is done with `equal'.
1576 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1577 is not a side effect; it is simply using a different sequence.
1578 Therefore, write `(setq foo (delete element foo))'
1579 to be sure of changing the value of `foo'. */)
1580 (Lisp_Object elt
, Lisp_Object seq
)
1586 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1587 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1590 if (n
!= ASIZE (seq
))
1592 struct Lisp_Vector
*p
= allocate_vector (n
);
1594 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1595 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1596 p
->contents
[n
++] = AREF (seq
, i
);
1598 XSETVECTOR (seq
, p
);
1601 else if (STRINGP (seq
))
1603 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1606 for (i
= nchars
= nbytes
= ibyte
= 0;
1608 ++i
, ibyte
+= cbytes
)
1610 if (STRING_MULTIBYTE (seq
))
1612 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1613 cbytes
= CHAR_BYTES (c
);
1621 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1628 if (nchars
!= SCHARS (seq
))
1632 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1633 if (!STRING_MULTIBYTE (seq
))
1634 STRING_SET_UNIBYTE (tem
);
1636 for (i
= nchars
= nbytes
= ibyte
= 0;
1638 ++i
, ibyte
+= cbytes
)
1640 if (STRING_MULTIBYTE (seq
))
1642 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1643 cbytes
= CHAR_BYTES (c
);
1651 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1653 unsigned char *from
= SDATA (seq
) + ibyte
;
1654 unsigned char *to
= SDATA (tem
) + nbytes
;
1660 for (n
= cbytes
; n
--; )
1670 Lisp_Object tail
, prev
;
1672 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1674 CHECK_LIST_CONS (tail
, seq
);
1676 if (!NILP (Fequal (elt
, XCAR (tail
))))
1681 Fsetcdr (prev
, XCDR (tail
));
1692 DEFUE ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1693 doc
: /* Reverse LIST by modifying cdr pointers.
1694 Return the reversed list. */)
1697 register Lisp_Object prev
, tail
, next
;
1699 if (NILP (list
)) return list
;
1702 while (!NILP (tail
))
1705 CHECK_LIST_CONS (tail
, list
);
1707 Fsetcdr (tail
, prev
);
1714 DEFUE ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1715 doc
: /* Reverse LIST, copying. Return the reversed list.
1716 See also the function `nreverse', which is used more often. */)
1721 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1724 new = Fcons (XCAR (list
), new);
1726 CHECK_LIST_END (list
, list
);
1730 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1732 DEFUE ("sort", Fsort
, Ssort
, 2, 2, 0,
1733 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1734 Returns the sorted list. LIST is modified by side effects.
1735 PREDICATE is called with two elements of LIST, and should return non-nil
1736 if the first element should sort before the second. */)
1737 (Lisp_Object list
, Lisp_Object predicate
)
1739 Lisp_Object front
, back
;
1740 register Lisp_Object len
, tem
;
1741 struct gcpro gcpro1
, gcpro2
;
1742 register int length
;
1745 len
= Flength (list
);
1746 length
= XINT (len
);
1750 XSETINT (len
, (length
/ 2) - 1);
1751 tem
= Fnthcdr (len
, list
);
1753 Fsetcdr (tem
, Qnil
);
1755 GCPRO2 (front
, back
);
1756 front
= Fsort (front
, predicate
);
1757 back
= Fsort (back
, predicate
);
1759 return merge (front
, back
, predicate
);
1763 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1766 register Lisp_Object tail
;
1768 register Lisp_Object l1
, l2
;
1769 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1776 /* It is sufficient to protect org_l1 and org_l2.
1777 When l1 and l2 are updated, we copy the new values
1778 back into the org_ vars. */
1779 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1799 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1815 Fsetcdr (tail
, tem
);
1821 /* This does not check for quits. That is safe since it must terminate. */
1823 DEFUE ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1824 doc
: /* Extract a value from a property list.
1825 PLIST is a property list, which is a list of the form
1826 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1827 corresponding to the given PROP, or nil if PROP is not one of the
1828 properties on the list. This function never signals an error. */)
1829 (Lisp_Object plist
, Lisp_Object prop
)
1831 Lisp_Object tail
, halftail
;
1833 /* halftail is used to detect circular lists. */
1834 tail
= halftail
= plist
;
1835 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1837 if (EQ (prop
, XCAR (tail
)))
1838 return XCAR (XCDR (tail
));
1840 tail
= XCDR (XCDR (tail
));
1841 halftail
= XCDR (halftail
);
1842 if (EQ (tail
, halftail
))
1845 #if 0 /* Unsafe version. */
1846 /* This function can be called asynchronously
1847 (setup_coding_system). Don't QUIT in that case. */
1848 if (!interrupt_input_blocked
)
1856 DEFUE ("get", Fget
, Sget
, 2, 2, 0,
1857 doc
: /* Return the value of SYMBOL's PROPNAME property.
1858 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1859 (Lisp_Object symbol
, Lisp_Object propname
)
1861 CHECK_SYMBOL (symbol
);
1862 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1865 DEFUE ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1866 doc
: /* Change value in PLIST of PROP to VAL.
1867 PLIST is a property list, which is a list of the form
1868 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1869 If PROP is already a property on the list, its value is set to VAL,
1870 otherwise the new PROP VAL pair is added. The new plist is returned;
1871 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1872 The PLIST is modified by side effects. */)
1873 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1875 register Lisp_Object tail
, prev
;
1876 Lisp_Object newcell
;
1878 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1879 tail
= XCDR (XCDR (tail
)))
1881 if (EQ (prop
, XCAR (tail
)))
1883 Fsetcar (XCDR (tail
), val
);
1890 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1894 Fsetcdr (XCDR (prev
), newcell
);
1898 DEFUE ("put", Fput
, Sput
, 3, 3, 0,
1899 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1900 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1901 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1903 CHECK_SYMBOL (symbol
);
1904 XSYMBOL (symbol
)->plist
1905 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1909 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1910 doc
: /* Extract a value from a property list, comparing with `equal'.
1911 PLIST is a property list, which is a list of the form
1912 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1913 corresponding to the given PROP, or nil if PROP is not
1914 one of the properties on the list. */)
1915 (Lisp_Object plist
, Lisp_Object prop
)
1920 CONSP (tail
) && CONSP (XCDR (tail
));
1921 tail
= XCDR (XCDR (tail
)))
1923 if (! NILP (Fequal (prop
, XCAR (tail
))))
1924 return XCAR (XCDR (tail
));
1929 CHECK_LIST_END (tail
, prop
);
1934 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1935 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1936 PLIST is a property list, which is a list of the form
1937 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1938 If PROP is already a property on the list, its value is set to VAL,
1939 otherwise the new PROP VAL pair is added. The new plist is returned;
1940 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1941 The PLIST is modified by side effects. */)
1942 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1944 register Lisp_Object tail
, prev
;
1945 Lisp_Object newcell
;
1947 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1948 tail
= XCDR (XCDR (tail
)))
1950 if (! NILP (Fequal (prop
, XCAR (tail
))))
1952 Fsetcar (XCDR (tail
), val
);
1959 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1963 Fsetcdr (XCDR (prev
), newcell
);
1967 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1968 doc
: /* Return t if the two args are the same Lisp object.
1969 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1970 (Lisp_Object obj1
, Lisp_Object obj2
)
1973 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1975 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1978 DEFUE ("equal", Fequal
, Sequal
, 2, 2, 0,
1979 doc
: /* Return t if two Lisp objects have similar structure and contents.
1980 They must have the same data type.
1981 Conses are compared by comparing the cars and the cdrs.
1982 Vectors and strings are compared element by element.
1983 Numbers are compared by value, but integers cannot equal floats.
1984 (Use `=' if you want integers and floats to be able to be equal.)
1985 Symbols must match exactly. */)
1986 (register Lisp_Object o1
, Lisp_Object o2
)
1988 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1991 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1992 doc
: /* Return t if two Lisp objects have similar structure and contents.
1993 This is like `equal' except that it compares the text properties
1994 of strings. (`equal' ignores text properties.) */)
1995 (register Lisp_Object o1
, Lisp_Object o2
)
1997 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2000 /* DEPTH is current depth of recursion. Signal an error if it
2002 PROPS, if non-nil, means compare string text properties too. */
2005 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2008 error ("Stack overflow in equal");
2014 if (XTYPE (o1
) != XTYPE (o2
))
2023 d1
= extract_float (o1
);
2024 d2
= extract_float (o2
);
2025 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2026 though they are not =. */
2027 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2031 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2038 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2042 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2044 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2047 o1
= XOVERLAY (o1
)->plist
;
2048 o2
= XOVERLAY (o2
)->plist
;
2053 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2054 && (XMARKER (o1
)->buffer
== 0
2055 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2059 case Lisp_Vectorlike
:
2062 EMACS_INT size
= ASIZE (o1
);
2063 /* Pseudovectors have the type encoded in the size field, so this test
2064 actually checks that the objects have the same type as well as the
2066 if (ASIZE (o2
) != size
)
2068 /* Boolvectors are compared much like strings. */
2069 if (BOOL_VECTOR_P (o1
))
2072 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2073 / BOOL_VECTOR_BITS_PER_CHAR
);
2075 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2077 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2082 if (WINDOW_CONFIGURATIONP (o1
))
2083 return compare_window_configurations (o1
, o2
, 0);
2085 /* Aside from them, only true vectors, char-tables, compiled
2086 functions, and fonts (font-spec, font-entity, font-ojbect)
2087 are sensible to compare, so eliminate the others now. */
2088 if (size
& PSEUDOVECTOR_FLAG
)
2090 if (!(size
& (PVEC_COMPILED
2091 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2093 size
&= PSEUDOVECTOR_SIZE_MASK
;
2095 for (i
= 0; i
< size
; i
++)
2100 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2108 if (SCHARS (o1
) != SCHARS (o2
))
2110 if (SBYTES (o1
) != SBYTES (o2
))
2112 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2114 if (props
&& !compare_string_intervals (o1
, o2
))
2126 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2127 doc
: /* Store each element of ARRAY with ITEM.
2128 ARRAY is a vector, string, char-table, or bool-vector. */)
2129 (Lisp_Object array
, Lisp_Object item
)
2131 register EMACS_INT size
, idx
;
2134 if (VECTORP (array
))
2136 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2137 size
= ASIZE (array
);
2138 for (idx
= 0; idx
< size
; idx
++)
2141 else if (CHAR_TABLE_P (array
))
2145 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2146 XCHAR_TABLE (array
)->contents
[i
] = item
;
2147 XCHAR_TABLE (array
)->defalt
= item
;
2149 else if (STRINGP (array
))
2151 register unsigned char *p
= SDATA (array
);
2152 CHECK_NUMBER (item
);
2153 charval
= XINT (item
);
2154 size
= SCHARS (array
);
2155 if (STRING_MULTIBYTE (array
))
2157 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2158 int len
= CHAR_STRING (charval
, str
);
2159 EMACS_INT size_byte
= SBYTES (array
);
2160 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2163 if (size
!= size_byte
)
2166 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2167 if (len
!= this_len
)
2168 error ("Attempt to change byte length of a string");
2171 for (i
= 0; i
< size_byte
; i
++)
2172 *p
++ = str
[i
% len
];
2175 for (idx
= 0; idx
< size
; idx
++)
2178 else if (BOOL_VECTOR_P (array
))
2180 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2182 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2183 / BOOL_VECTOR_BITS_PER_CHAR
);
2185 charval
= (! NILP (item
) ? -1 : 0);
2186 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2188 if (idx
< size_in_chars
)
2190 /* Mask out bits beyond the vector size. */
2191 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2192 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2197 wrong_type_argument (Qarrayp
, array
);
2201 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2203 doc
: /* Clear the contents of STRING.
2204 This makes STRING unibyte and may change its length. */)
2205 (Lisp_Object string
)
2208 CHECK_STRING (string
);
2209 len
= SBYTES (string
);
2210 memset (SDATA (string
), 0, len
);
2211 STRING_SET_CHARS (string
, len
);
2212 STRING_SET_UNIBYTE (string
);
2218 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2220 Lisp_Object args
[2];
2223 return Fnconc (2, args
);
2226 DEFUE ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2227 doc
: /* Concatenate any number of lists by altering them.
2228 Only the last argument is not altered, and need not be a list.
2229 usage: (nconc &rest LISTS) */)
2230 (size_t nargs
, Lisp_Object
*args
)
2232 register size_t argnum
;
2233 register Lisp_Object tail
, tem
, val
;
2237 for (argnum
= 0; argnum
< nargs
; argnum
++)
2240 if (NILP (tem
)) continue;
2245 if (argnum
+ 1 == nargs
) break;
2247 CHECK_LIST_CONS (tem
, tem
);
2256 tem
= args
[argnum
+ 1];
2257 Fsetcdr (tail
, tem
);
2259 args
[argnum
+ 1] = tail
;
2265 /* This is the guts of all mapping functions.
2266 Apply FN to each element of SEQ, one by one,
2267 storing the results into elements of VALS, a C vector of Lisp_Objects.
2268 LENI is the length of VALS, which should also be the length of SEQ. */
2271 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2273 register Lisp_Object tail
;
2275 register EMACS_INT i
;
2276 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2280 /* Don't let vals contain any garbage when GC happens. */
2281 for (i
= 0; i
< leni
; i
++)
2284 GCPRO3 (dummy
, fn
, seq
);
2286 gcpro1
.nvars
= leni
;
2290 /* We need not explicitly protect `tail' because it is used only on lists, and
2291 1) lists are not relocated and 2) the list is marked via `seq' so will not
2294 if (VECTORP (seq
) || COMPILEDP (seq
))
2296 for (i
= 0; i
< leni
; i
++)
2298 dummy
= call1 (fn
, AREF (seq
, i
));
2303 else if (BOOL_VECTOR_P (seq
))
2305 for (i
= 0; i
< leni
; i
++)
2308 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2309 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2310 dummy
= call1 (fn
, dummy
);
2315 else if (STRINGP (seq
))
2319 for (i
= 0, i_byte
= 0; i
< leni
;)
2322 EMACS_INT i_before
= i
;
2324 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2325 XSETFASTINT (dummy
, c
);
2326 dummy
= call1 (fn
, dummy
);
2328 vals
[i_before
] = dummy
;
2331 else /* Must be a list, since Flength did not get an error */
2334 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2336 dummy
= call1 (fn
, XCAR (tail
));
2346 DEFUE ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2347 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2348 In between each pair of results, stick in SEPARATOR. Thus, " " as
2349 SEPARATOR results in spaces between the values returned by FUNCTION.
2350 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2351 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2354 register EMACS_INT leni
;
2356 register Lisp_Object
*args
;
2357 register EMACS_INT i
;
2358 struct gcpro gcpro1
;
2362 len
= Flength (sequence
);
2363 if (CHAR_TABLE_P (sequence
))
2364 wrong_type_argument (Qlistp
, sequence
);
2366 nargs
= leni
+ leni
- 1;
2367 if (nargs
< 0) return empty_unibyte_string
;
2369 SAFE_ALLOCA_LISP (args
, nargs
);
2372 mapcar1 (leni
, args
, function
, sequence
);
2375 for (i
= leni
- 1; i
> 0; i
--)
2376 args
[i
+ i
] = args
[i
];
2378 for (i
= 1; i
< nargs
; i
+= 2)
2379 args
[i
] = separator
;
2381 ret
= Fconcat (nargs
, args
);
2387 DEFUE ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2388 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2389 The result is a list just as long as SEQUENCE.
2390 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2391 (Lisp_Object function
, Lisp_Object sequence
)
2393 register Lisp_Object len
;
2394 register EMACS_INT leni
;
2395 register Lisp_Object
*args
;
2399 len
= Flength (sequence
);
2400 if (CHAR_TABLE_P (sequence
))
2401 wrong_type_argument (Qlistp
, sequence
);
2402 leni
= XFASTINT (len
);
2404 SAFE_ALLOCA_LISP (args
, leni
);
2406 mapcar1 (leni
, args
, function
, sequence
);
2408 ret
= Flist (leni
, args
);
2414 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2415 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2416 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2417 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2418 (Lisp_Object function
, Lisp_Object sequence
)
2420 register EMACS_INT leni
;
2422 leni
= XFASTINT (Flength (sequence
));
2423 if (CHAR_TABLE_P (sequence
))
2424 wrong_type_argument (Qlistp
, sequence
);
2425 mapcar1 (leni
, 0, function
, sequence
);
2430 /* This is how C code calls `yes-or-no-p' and allows the user
2433 Anything that calls this function must protect from GC! */
2436 do_yes_or_no_p (Lisp_Object prompt
)
2438 return call1 (intern ("yes-or-no-p"), prompt
);
2441 /* Anything that calls this function must protect from GC! */
2443 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2444 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2445 PROMPT is the string to display to ask the question. It should end in
2446 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2448 The user must confirm the answer with RET, and can edit it until it
2451 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2452 is nil, and `use-dialog-box' is non-nil. */)
2453 (Lisp_Object prompt
)
2455 register Lisp_Object ans
;
2456 Lisp_Object args
[2];
2457 struct gcpro gcpro1
;
2459 CHECK_STRING (prompt
);
2462 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2463 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2467 Lisp_Object pane
, menu
, obj
;
2468 redisplay_preserve_echo_area (4);
2469 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2470 Fcons (Fcons (build_string ("No"), Qnil
),
2473 menu
= Fcons (prompt
, pane
);
2474 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2478 #endif /* HAVE_MENUS */
2481 args
[1] = build_string ("(yes or no) ");
2482 prompt
= Fconcat (2, args
);
2488 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2489 Qyes_or_no_p_history
, Qnil
,
2491 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2496 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2504 message ("Please answer yes or no.");
2505 Fsleep_for (make_number (2), Qnil
);
2509 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2510 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2512 Each of the three load averages is multiplied by 100, then converted
2515 When USE-FLOATS is non-nil, floats will be used instead of integers.
2516 These floats are not multiplied by 100.
2518 If the 5-minute or 15-minute load averages are not available, return a
2519 shortened list, containing only those averages which are available.
2521 An error is thrown if the load average can't be obtained. In some
2522 cases making it work would require Emacs being installed setuid or
2523 setgid so that it can read kernel information, and that usually isn't
2525 (Lisp_Object use_floats
)
2528 int loads
= getloadavg (load_ave
, 3);
2529 Lisp_Object ret
= Qnil
;
2532 error ("load-average not implemented for this operating system");
2536 Lisp_Object load
= (NILP (use_floats
) ?
2537 make_number ((int) (100.0 * load_ave
[loads
]))
2538 : make_float (load_ave
[loads
]));
2539 ret
= Fcons (load
, ret
);
2545 static Lisp_Object Qsubfeatures
;
2547 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2548 doc
: /* Return t if FEATURE is present in this Emacs.
2550 Use this to conditionalize execution of lisp code based on the
2551 presence or absence of Emacs or environment extensions.
2552 Use `provide' to declare that a feature is available. This function
2553 looks at the value of the variable `features'. The optional argument
2554 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2555 (Lisp_Object feature
, Lisp_Object subfeature
)
2557 register Lisp_Object tem
;
2558 CHECK_SYMBOL (feature
);
2559 tem
= Fmemq (feature
, Vfeatures
);
2560 if (!NILP (tem
) && !NILP (subfeature
))
2561 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2562 return (NILP (tem
)) ? Qnil
: Qt
;
2565 DEFUE ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2566 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2567 The optional argument SUBFEATURES should be a list of symbols listing
2568 particular subfeatures supported in this version of FEATURE. */)
2569 (Lisp_Object feature
, Lisp_Object subfeatures
)
2571 register Lisp_Object tem
;
2572 CHECK_SYMBOL (feature
);
2573 CHECK_LIST (subfeatures
);
2574 if (!NILP (Vautoload_queue
))
2575 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2577 tem
= Fmemq (feature
, Vfeatures
);
2579 Vfeatures
= Fcons (feature
, Vfeatures
);
2580 if (!NILP (subfeatures
))
2581 Fput (feature
, Qsubfeatures
, subfeatures
);
2582 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2584 /* Run any load-hooks for this file. */
2585 tem
= Fassq (feature
, Vafter_load_alist
);
2587 Fprogn (XCDR (tem
));
2592 /* `require' and its subroutines. */
2594 /* List of features currently being require'd, innermost first. */
2596 static Lisp_Object require_nesting_list
;
2599 require_unwind (Lisp_Object old_value
)
2601 return require_nesting_list
= old_value
;
2604 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2605 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2606 If FEATURE is not a member of the list `features', then the feature
2607 is not loaded; so load the file FILENAME.
2608 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2609 and `load' will try to load this name appended with the suffix `.elc' or
2610 `.el', in that order. The name without appended suffix will not be used.
2611 If the optional third argument NOERROR is non-nil,
2612 then return nil if the file is not found instead of signaling an error.
2613 Normally the return value is FEATURE.
2614 The normal messages at start and end of loading FILENAME are suppressed. */)
2615 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2617 register Lisp_Object tem
;
2618 struct gcpro gcpro1
, gcpro2
;
2619 int from_file
= load_in_progress
;
2621 CHECK_SYMBOL (feature
);
2623 /* Record the presence of `require' in this file
2624 even if the feature specified is already loaded.
2625 But not more than once in any file,
2626 and not when we aren't loading or reading from a file. */
2628 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2629 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2634 tem
= Fcons (Qrequire
, feature
);
2635 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2636 LOADHIST_ATTACH (tem
);
2638 tem
= Fmemq (feature
, Vfeatures
);
2642 int count
= SPECPDL_INDEX ();
2645 /* This is to make sure that loadup.el gives a clear picture
2646 of what files are preloaded and when. */
2647 if (! NILP (Vpurify_flag
))
2648 error ("(require %s) while preparing to dump",
2649 SDATA (SYMBOL_NAME (feature
)));
2651 /* A certain amount of recursive `require' is legitimate,
2652 but if we require the same feature recursively 3 times,
2654 tem
= require_nesting_list
;
2655 while (! NILP (tem
))
2657 if (! NILP (Fequal (feature
, XCAR (tem
))))
2662 error ("Recursive `require' for feature `%s'",
2663 SDATA (SYMBOL_NAME (feature
)));
2665 /* Update the list for any nested `require's that occur. */
2666 record_unwind_protect (require_unwind
, require_nesting_list
);
2667 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2669 /* Value saved here is to be restored into Vautoload_queue */
2670 record_unwind_protect (un_autoload
, Vautoload_queue
);
2671 Vautoload_queue
= Qt
;
2673 /* Load the file. */
2674 GCPRO2 (feature
, filename
);
2675 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2676 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2679 /* If load failed entirely, return nil. */
2681 return unbind_to (count
, Qnil
);
2683 tem
= Fmemq (feature
, Vfeatures
);
2685 error ("Required feature `%s' was not provided",
2686 SDATA (SYMBOL_NAME (feature
)));
2688 /* Once loading finishes, don't undo it. */
2689 Vautoload_queue
= Qt
;
2690 feature
= unbind_to (count
, feature
);
2696 /* Primitives for work of the "widget" library.
2697 In an ideal world, this section would not have been necessary.
2698 However, lisp function calls being as slow as they are, it turns
2699 out that some functions in the widget library (wid-edit.el) are the
2700 bottleneck of Widget operation. Here is their translation to C,
2701 for the sole reason of efficiency. */
2703 DEFUE ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2704 doc
: /* Return non-nil if PLIST has the property PROP.
2705 PLIST is a property list, which is a list of the form
2706 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2707 Unlike `plist-get', this allows you to distinguish between a missing
2708 property and a property with the value nil.
2709 The value is actually the tail of PLIST whose car is PROP. */)
2710 (Lisp_Object plist
, Lisp_Object prop
)
2712 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2715 plist
= XCDR (plist
);
2716 plist
= CDR (plist
);
2721 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2722 doc
: /* In WIDGET, set PROPERTY to VALUE.
2723 The value can later be retrieved with `widget-get'. */)
2724 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2726 CHECK_CONS (widget
);
2727 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2731 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2732 doc
: /* In WIDGET, get the value of PROPERTY.
2733 The value could either be specified when the widget was created, or
2734 later with `widget-put'. */)
2735 (Lisp_Object widget
, Lisp_Object property
)
2743 CHECK_CONS (widget
);
2744 tmp
= Fplist_member (XCDR (widget
), property
);
2750 tmp
= XCAR (widget
);
2753 widget
= Fget (tmp
, Qwidget_type
);
2757 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2758 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2759 ARGS are passed as extra arguments to the function.
2760 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2761 (size_t nargs
, Lisp_Object
*args
)
2763 /* This function can GC. */
2764 Lisp_Object newargs
[3];
2765 struct gcpro gcpro1
, gcpro2
;
2768 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2769 newargs
[1] = args
[0];
2770 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2771 GCPRO2 (newargs
[0], newargs
[2]);
2772 result
= Fapply (3, newargs
);
2777 #ifdef HAVE_LANGINFO_CODESET
2778 #include <langinfo.h>
2781 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2782 doc
: /* Access locale data ITEM for the current C locale, if available.
2783 ITEM should be one of the following:
2785 `codeset', returning the character set as a string (locale item CODESET);
2787 `days', returning a 7-element vector of day names (locale items DAY_n);
2789 `months', returning a 12-element vector of month names (locale items MON_n);
2791 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2792 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2794 If the system can't provide such information through a call to
2795 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2797 See also Info node `(libc)Locales'.
2799 The data read from the system are decoded using `locale-coding-system'. */)
2803 #ifdef HAVE_LANGINFO_CODESET
2805 if (EQ (item
, Qcodeset
))
2807 str
= nl_langinfo (CODESET
);
2808 return build_string (str
);
2811 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2813 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2814 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2816 struct gcpro gcpro1
;
2818 synchronize_system_time_locale ();
2819 for (i
= 0; i
< 7; i
++)
2821 str
= nl_langinfo (days
[i
]);
2822 val
= make_unibyte_string (str
, strlen (str
));
2823 /* Fixme: Is this coding system necessarily right, even if
2824 it is consistent with CODESET? If not, what to do? */
2825 Faset (v
, make_number (i
),
2826 code_convert_string_norecord (val
, Vlocale_coding_system
,
2834 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2836 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2837 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2838 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2840 struct gcpro gcpro1
;
2842 synchronize_system_time_locale ();
2843 for (i
= 0; i
< 12; i
++)
2845 str
= nl_langinfo (months
[i
]);
2846 val
= make_unibyte_string (str
, strlen (str
));
2847 Faset (v
, make_number (i
),
2848 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2854 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2855 but is in the locale files. This could be used by ps-print. */
2857 else if (EQ (item
, Qpaper
))
2859 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2860 make_number (nl_langinfo (PAPER_HEIGHT
)));
2862 #endif /* PAPER_WIDTH */
2863 #endif /* HAVE_LANGINFO_CODESET*/
2867 /* base64 encode/decode functions (RFC 2045).
2868 Based on code from GNU recode. */
2870 #define MIME_LINE_LENGTH 76
2872 #define IS_ASCII(Character) \
2874 #define IS_BASE64(Character) \
2875 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2876 #define IS_BASE64_IGNORABLE(Character) \
2877 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2878 || (Character) == '\f' || (Character) == '\r')
2880 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2881 character or return retval if there are no characters left to
2883 #define READ_QUADRUPLET_BYTE(retval) \
2888 if (nchars_return) \
2889 *nchars_return = nchars; \
2894 while (IS_BASE64_IGNORABLE (c))
2896 /* Table of characters coding the 64 values. */
2897 static const char base64_value_to_char
[64] =
2899 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2900 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2901 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2902 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2903 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2904 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2905 '8', '9', '+', '/' /* 60-63 */
2908 /* Table of base64 values for first 128 characters. */
2909 static const short base64_char_to_value
[128] =
2911 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2912 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2913 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2914 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2915 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2916 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2917 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2918 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2919 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2920 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2921 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2922 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2923 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2926 /* The following diagram shows the logical steps by which three octets
2927 get transformed into four base64 characters.
2929 .--------. .--------. .--------.
2930 |aaaaaabb| |bbbbcccc| |ccdddddd|
2931 `--------' `--------' `--------'
2933 .--------+--------+--------+--------.
2934 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2935 `--------+--------+--------+--------'
2937 .--------+--------+--------+--------.
2938 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2939 `--------+--------+--------+--------'
2941 The octets are divided into 6 bit chunks, which are then encoded into
2942 base64 characters. */
2945 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2946 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2949 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2951 doc
: /* Base64-encode the region between BEG and END.
2952 Return the length of the encoded text.
2953 Optional third argument NO-LINE-BREAK means do not break long lines
2954 into shorter lines. */)
2955 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2958 EMACS_INT allength
, length
;
2959 EMACS_INT ibeg
, iend
, encoded_length
;
2960 EMACS_INT old_pos
= PT
;
2963 validate_region (&beg
, &end
);
2965 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2966 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2967 move_gap_both (XFASTINT (beg
), ibeg
);
2969 /* We need to allocate enough room for encoding the text.
2970 We need 33 1/3% more space, plus a newline every 76
2971 characters, and then we round up. */
2972 length
= iend
- ibeg
;
2973 allength
= length
+ length
/3 + 1;
2974 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2976 SAFE_ALLOCA (encoded
, char *, allength
);
2977 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2978 encoded
, length
, NILP (no_line_break
),
2979 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2980 if (encoded_length
> allength
)
2983 if (encoded_length
< 0)
2985 /* The encoding wasn't possible. */
2987 error ("Multibyte character in data for base64 encoding");
2990 /* Now we have encoded the region, so we insert the new contents
2991 and delete the old. (Insert first in order to preserve markers.) */
2992 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2993 insert (encoded
, encoded_length
);
2995 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2997 /* If point was outside of the region, restore it exactly; else just
2998 move to the beginning of the region. */
2999 if (old_pos
>= XFASTINT (end
))
3000 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3001 else if (old_pos
> XFASTINT (beg
))
3002 old_pos
= XFASTINT (beg
);
3005 /* We return the length of the encoded text. */
3006 return make_number (encoded_length
);
3009 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3011 doc
: /* Base64-encode STRING and return the result.
3012 Optional second argument NO-LINE-BREAK means do not break long lines
3013 into shorter lines. */)
3014 (Lisp_Object string
, Lisp_Object no_line_break
)
3016 EMACS_INT allength
, length
, encoded_length
;
3018 Lisp_Object encoded_string
;
3021 CHECK_STRING (string
);
3023 /* We need to allocate enough room for encoding the text.
3024 We need 33 1/3% more space, plus a newline every 76
3025 characters, and then we round up. */
3026 length
= SBYTES (string
);
3027 allength
= length
+ length
/3 + 1;
3028 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3030 /* We need to allocate enough room for decoding the text. */
3031 SAFE_ALLOCA (encoded
, char *, allength
);
3033 encoded_length
= base64_encode_1 (SSDATA (string
),
3034 encoded
, length
, NILP (no_line_break
),
3035 STRING_MULTIBYTE (string
));
3036 if (encoded_length
> allength
)
3039 if (encoded_length
< 0)
3041 /* The encoding wasn't possible. */
3043 error ("Multibyte character in data for base64 encoding");
3046 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3049 return encoded_string
;
3053 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3054 int line_break
, int multibyte
)
3067 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3068 if (CHAR_BYTE8_P (c
))
3069 c
= CHAR_TO_BYTE8 (c
);
3077 /* Wrap line every 76 characters. */
3081 if (counter
< MIME_LINE_LENGTH
/ 4)
3090 /* Process first byte of a triplet. */
3092 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3093 value
= (0x03 & c
) << 4;
3095 /* Process second byte of a triplet. */
3099 *e
++ = base64_value_to_char
[value
];
3107 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3108 if (CHAR_BYTE8_P (c
))
3109 c
= CHAR_TO_BYTE8 (c
);
3117 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3118 value
= (0x0f & c
) << 2;
3120 /* Process third byte of a triplet. */
3124 *e
++ = base64_value_to_char
[value
];
3131 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3132 if (CHAR_BYTE8_P (c
))
3133 c
= CHAR_TO_BYTE8 (c
);
3141 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3142 *e
++ = base64_value_to_char
[0x3f & c
];
3149 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3151 doc
: /* Base64-decode the region between BEG and END.
3152 Return the length of the decoded text.
3153 If the region can't be decoded, signal an error and don't modify the buffer. */)
3154 (Lisp_Object beg
, Lisp_Object end
)
3156 EMACS_INT ibeg
, iend
, length
, allength
;
3158 EMACS_INT old_pos
= PT
;
3159 EMACS_INT decoded_length
;
3160 EMACS_INT inserted_chars
;
3161 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3164 validate_region (&beg
, &end
);
3166 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3167 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3169 length
= iend
- ibeg
;
3171 /* We need to allocate enough room for decoding the text. If we are
3172 working on a multibyte buffer, each decoded code may occupy at
3174 allength
= multibyte
? length
* 2 : length
;
3175 SAFE_ALLOCA (decoded
, char *, allength
);
3177 move_gap_both (XFASTINT (beg
), ibeg
);
3178 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3180 multibyte
, &inserted_chars
);
3181 if (decoded_length
> allength
)
3184 if (decoded_length
< 0)
3186 /* The decoding wasn't possible. */
3188 error ("Invalid base64 data");
3191 /* Now we have decoded the region, so we insert the new contents
3192 and delete the old. (Insert first in order to preserve markers.) */
3193 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3194 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3197 /* Delete the original text. */
3198 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3199 iend
+ decoded_length
, 1);
3201 /* If point was outside of the region, restore it exactly; else just
3202 move to the beginning of the region. */
3203 if (old_pos
>= XFASTINT (end
))
3204 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3205 else if (old_pos
> XFASTINT (beg
))
3206 old_pos
= XFASTINT (beg
);
3207 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3209 return make_number (inserted_chars
);
3212 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3214 doc
: /* Base64-decode STRING and return the result. */)
3215 (Lisp_Object string
)
3218 EMACS_INT length
, decoded_length
;
3219 Lisp_Object decoded_string
;
3222 CHECK_STRING (string
);
3224 length
= SBYTES (string
);
3225 /* We need to allocate enough room for decoding the text. */
3226 SAFE_ALLOCA (decoded
, char *, length
);
3228 /* The decoded result should be unibyte. */
3229 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3231 if (decoded_length
> length
)
3233 else if (decoded_length
>= 0)
3234 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3236 decoded_string
= Qnil
;
3239 if (!STRINGP (decoded_string
))
3240 error ("Invalid base64 data");
3242 return decoded_string
;
3245 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3246 MULTIBYTE is nonzero, the decoded result should be in multibyte
3247 form. If NCHARS_RETRUN is not NULL, store the number of produced
3248 characters in *NCHARS_RETURN. */
3251 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3252 int multibyte
, EMACS_INT
*nchars_return
)
3254 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3257 unsigned long value
;
3258 EMACS_INT nchars
= 0;
3262 /* Process first byte of a quadruplet. */
3264 READ_QUADRUPLET_BYTE (e
-to
);
3268 value
= base64_char_to_value
[c
] << 18;
3270 /* Process second byte of a quadruplet. */
3272 READ_QUADRUPLET_BYTE (-1);
3276 value
|= base64_char_to_value
[c
] << 12;
3278 c
= (unsigned char) (value
>> 16);
3279 if (multibyte
&& c
>= 128)
3280 e
+= BYTE8_STRING (c
, e
);
3285 /* Process third byte of a quadruplet. */
3287 READ_QUADRUPLET_BYTE (-1);
3291 READ_QUADRUPLET_BYTE (-1);
3300 value
|= base64_char_to_value
[c
] << 6;
3302 c
= (unsigned char) (0xff & value
>> 8);
3303 if (multibyte
&& c
>= 128)
3304 e
+= BYTE8_STRING (c
, e
);
3309 /* Process fourth byte of a quadruplet. */
3311 READ_QUADRUPLET_BYTE (-1);
3318 value
|= base64_char_to_value
[c
];
3320 c
= (unsigned char) (0xff & value
);
3321 if (multibyte
&& c
>= 128)
3322 e
+= BYTE8_STRING (c
, e
);
3331 /***********************************************************************
3333 ***** Hash Tables *****
3335 ***********************************************************************/
3337 /* Implemented by gerd@gnu.org. This hash table implementation was
3338 inspired by CMUCL hash tables. */
3342 1. For small tables, association lists are probably faster than
3343 hash tables because they have lower overhead.
3345 For uses of hash tables where the O(1) behavior of table
3346 operations is not a requirement, it might therefore be a good idea
3347 not to hash. Instead, we could just do a linear search in the
3348 key_and_value vector of the hash table. This could be done
3349 if a `:linear-search t' argument is given to make-hash-table. */
3352 /* The list of all weak hash tables. Don't staticpro this one. */
3354 static struct Lisp_Hash_Table
*weak_hash_tables
;
3356 /* Various symbols. */
3358 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3359 Lisp_Object Qeq
, Qeql
, Qequal
;
3360 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3361 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3363 /* Function prototypes. */
3365 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3366 static size_t get_key_arg (Lisp_Object
, size_t, Lisp_Object
*, char *);
3367 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3368 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3369 Lisp_Object
, unsigned);
3370 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3371 Lisp_Object
, unsigned);
3372 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3373 unsigned, Lisp_Object
, unsigned);
3374 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3375 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3376 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3377 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3379 static unsigned sxhash_string (unsigned char *, int);
3380 static unsigned sxhash_list (Lisp_Object
, int);
3381 static unsigned sxhash_vector (Lisp_Object
, int);
3382 static unsigned sxhash_bool_vector (Lisp_Object
);
3383 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3387 /***********************************************************************
3389 ***********************************************************************/
3391 /* If OBJ is a Lisp hash table, return a pointer to its struct
3392 Lisp_Hash_Table. Otherwise, signal an error. */
3394 static struct Lisp_Hash_Table
*
3395 check_hash_table (Lisp_Object obj
)
3397 CHECK_HASH_TABLE (obj
);
3398 return XHASH_TABLE (obj
);
3402 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3406 next_almost_prime (int n
)
3418 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3419 which USED[I] is non-zero. If found at index I in ARGS, set
3420 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3421 0. This function is used to extract a keyword/argument pair from
3422 a DEFUN parameter list. */
3425 get_key_arg (Lisp_Object key
, size_t nargs
, Lisp_Object
*args
, char *used
)
3429 for (i
= 1; i
< nargs
; i
++)
3430 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3441 /* Return a Lisp vector which has the same contents as VEC but has
3442 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3443 vector that are not copied from VEC are set to INIT. */
3446 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3448 struct Lisp_Vector
*v
;
3451 xassert (VECTORP (vec
));
3452 old_size
= ASIZE (vec
);
3453 xassert (new_size
>= old_size
);
3455 v
= allocate_vector (new_size
);
3456 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3457 for (i
= old_size
; i
< new_size
; ++i
)
3458 v
->contents
[i
] = init
;
3459 XSETVECTOR (vec
, v
);
3464 /***********************************************************************
3466 ***********************************************************************/
3468 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3469 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3470 KEY2 are the same. */
3473 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3475 return (FLOATP (key1
)
3477 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3481 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3482 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3483 KEY2 are the same. */
3486 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3488 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3492 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3493 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3494 if KEY1 and KEY2 are the same. */
3497 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3501 Lisp_Object args
[3];
3503 args
[0] = h
->user_cmp_function
;
3506 return !NILP (Ffuncall (3, args
));
3513 /* Value is a hash code for KEY for use in hash table H which uses
3514 `eq' to compare keys. The hash code returned is guaranteed to fit
3515 in a Lisp integer. */
3518 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3520 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3521 xassert ((hash
& ~INTMASK
) == 0);
3526 /* Value is a hash code for KEY for use in hash table H which uses
3527 `eql' to compare keys. The hash code returned is guaranteed to fit
3528 in a Lisp integer. */
3531 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3535 hash
= sxhash (key
, 0);
3537 hash
= XUINT (key
) ^ XTYPE (key
);
3538 xassert ((hash
& ~INTMASK
) == 0);
3543 /* Value is a hash code for KEY for use in hash table H which uses
3544 `equal' to compare keys. The hash code returned is guaranteed to fit
3545 in a Lisp integer. */
3548 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3550 unsigned hash
= sxhash (key
, 0);
3551 xassert ((hash
& ~INTMASK
) == 0);
3556 /* Value is a hash code for KEY for use in hash table H which uses as
3557 user-defined function to compare keys. The hash code returned is
3558 guaranteed to fit in a Lisp integer. */
3561 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3563 Lisp_Object args
[2], hash
;
3565 args
[0] = h
->user_hash_function
;
3567 hash
= Ffuncall (2, args
);
3568 if (!INTEGERP (hash
))
3569 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3570 return XUINT (hash
);
3574 /* Create and initialize a new hash table.
3576 TEST specifies the test the hash table will use to compare keys.
3577 It must be either one of the predefined tests `eq', `eql' or
3578 `equal' or a symbol denoting a user-defined test named TEST with
3579 test and hash functions USER_TEST and USER_HASH.
3581 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3583 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3584 new size when it becomes full is computed by adding REHASH_SIZE to
3585 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3586 table's new size is computed by multiplying its old size with
3589 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3590 be resized when the ratio of (number of entries in the table) /
3591 (table size) is >= REHASH_THRESHOLD.
3593 WEAK specifies the weakness of the table. If non-nil, it must be
3594 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3597 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3598 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3599 Lisp_Object user_test
, Lisp_Object user_hash
)
3601 struct Lisp_Hash_Table
*h
;
3603 int index_size
, i
, sz
;
3605 /* Preconditions. */
3606 xassert (SYMBOLP (test
));
3607 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3608 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3609 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3610 xassert (FLOATP (rehash_threshold
)
3611 && XFLOATINT (rehash_threshold
) > 0
3612 && XFLOATINT (rehash_threshold
) <= 1.0);
3614 if (XFASTINT (size
) == 0)
3615 size
= make_number (1);
3617 /* Allocate a table and initialize it. */
3618 h
= allocate_hash_table ();
3620 /* Initialize hash table slots. */
3621 sz
= XFASTINT (size
);
3624 if (EQ (test
, Qeql
))
3626 h
->cmpfn
= cmpfn_eql
;
3627 h
->hashfn
= hashfn_eql
;
3629 else if (EQ (test
, Qeq
))
3632 h
->hashfn
= hashfn_eq
;
3634 else if (EQ (test
, Qequal
))
3636 h
->cmpfn
= cmpfn_equal
;
3637 h
->hashfn
= hashfn_equal
;
3641 h
->user_cmp_function
= user_test
;
3642 h
->user_hash_function
= user_hash
;
3643 h
->cmpfn
= cmpfn_user_defined
;
3644 h
->hashfn
= hashfn_user_defined
;
3648 h
->rehash_threshold
= rehash_threshold
;
3649 h
->rehash_size
= rehash_size
;
3651 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3652 h
->hash
= Fmake_vector (size
, Qnil
);
3653 h
->next
= Fmake_vector (size
, Qnil
);
3654 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3655 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3656 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3658 /* Set up the free list. */
3659 for (i
= 0; i
< sz
- 1; ++i
)
3660 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3661 h
->next_free
= make_number (0);
3663 XSET_HASH_TABLE (table
, h
);
3664 xassert (HASH_TABLE_P (table
));
3665 xassert (XHASH_TABLE (table
) == h
);
3667 /* Maybe add this hash table to the list of all weak hash tables. */
3669 h
->next_weak
= NULL
;
3672 h
->next_weak
= weak_hash_tables
;
3673 weak_hash_tables
= h
;
3680 /* Return a copy of hash table H1. Keys and values are not copied,
3681 only the table itself is. */
3684 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3687 struct Lisp_Hash_Table
*h2
;
3688 struct Lisp_Vector
*next
;
3690 h2
= allocate_hash_table ();
3691 next
= h2
->vec_next
;
3692 memcpy (h2
, h1
, sizeof *h2
);
3693 h2
->vec_next
= next
;
3694 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3695 h2
->hash
= Fcopy_sequence (h1
->hash
);
3696 h2
->next
= Fcopy_sequence (h1
->next
);
3697 h2
->index
= Fcopy_sequence (h1
->index
);
3698 XSET_HASH_TABLE (table
, h2
);
3700 /* Maybe add this hash table to the list of all weak hash tables. */
3701 if (!NILP (h2
->weak
))
3703 h2
->next_weak
= weak_hash_tables
;
3704 weak_hash_tables
= h2
;
3711 /* Resize hash table H if it's too full. If H cannot be resized
3712 because it's already too large, throw an error. */
3715 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3717 if (NILP (h
->next_free
))
3719 int old_size
= HASH_TABLE_SIZE (h
);
3720 int i
, new_size
, index_size
;
3723 if (INTEGERP (h
->rehash_size
))
3724 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3726 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3727 new_size
= max (old_size
+ 1, new_size
);
3728 index_size
= next_almost_prime ((int)
3730 / XFLOATINT (h
->rehash_threshold
)));
3731 /* Assignment to EMACS_INT stops GCC whining about limited range
3733 nsize
= max (index_size
, 2 * new_size
);
3734 if (nsize
> MOST_POSITIVE_FIXNUM
)
3735 error ("Hash table too large to resize");
3737 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3738 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3739 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3740 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3742 /* Update the free list. Do it so that new entries are added at
3743 the end of the free list. This makes some operations like
3745 for (i
= old_size
; i
< new_size
- 1; ++i
)
3746 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3748 if (!NILP (h
->next_free
))
3750 Lisp_Object last
, next
;
3752 last
= h
->next_free
;
3753 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3757 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3760 XSETFASTINT (h
->next_free
, old_size
);
3763 for (i
= 0; i
< old_size
; ++i
)
3764 if (!NILP (HASH_HASH (h
, i
)))
3766 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3767 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3768 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3769 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3775 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3776 the hash code of KEY. Value is the index of the entry in H
3777 matching KEY, or -1 if not found. */
3780 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3783 int start_of_bucket
;
3786 hash_code
= h
->hashfn (h
, key
);
3790 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3791 idx
= HASH_INDEX (h
, start_of_bucket
);
3793 /* We need not gcpro idx since it's either an integer or nil. */
3796 int i
= XFASTINT (idx
);
3797 if (EQ (key
, HASH_KEY (h
, i
))
3799 && h
->cmpfn (h
, key
, hash_code
,
3800 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3802 idx
= HASH_NEXT (h
, i
);
3805 return NILP (idx
) ? -1 : XFASTINT (idx
);
3809 /* Put an entry into hash table H that associates KEY with VALUE.
3810 HASH is a previously computed hash code of KEY.
3811 Value is the index of the entry in H matching KEY. */
3814 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3816 int start_of_bucket
, i
;
3818 xassert ((hash
& ~INTMASK
) == 0);
3820 /* Increment count after resizing because resizing may fail. */
3821 maybe_resize_hash_table (h
);
3824 /* Store key/value in the key_and_value vector. */
3825 i
= XFASTINT (h
->next_free
);
3826 h
->next_free
= HASH_NEXT (h
, i
);
3827 HASH_KEY (h
, i
) = key
;
3828 HASH_VALUE (h
, i
) = value
;
3830 /* Remember its hash code. */
3831 HASH_HASH (h
, i
) = make_number (hash
);
3833 /* Add new entry to its collision chain. */
3834 start_of_bucket
= hash
% ASIZE (h
->index
);
3835 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3836 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3841 /* Remove the entry matching KEY from hash table H, if there is one. */
3844 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3847 int start_of_bucket
;
3848 Lisp_Object idx
, prev
;
3850 hash_code
= h
->hashfn (h
, key
);
3851 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3852 idx
= HASH_INDEX (h
, start_of_bucket
);
3855 /* We need not gcpro idx, prev since they're either integers or nil. */
3858 int i
= XFASTINT (idx
);
3860 if (EQ (key
, HASH_KEY (h
, i
))
3862 && h
->cmpfn (h
, key
, hash_code
,
3863 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3865 /* Take entry out of collision chain. */
3867 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3869 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3871 /* Clear slots in key_and_value and add the slots to
3873 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3874 HASH_NEXT (h
, i
) = h
->next_free
;
3875 h
->next_free
= make_number (i
);
3877 xassert (h
->count
>= 0);
3883 idx
= HASH_NEXT (h
, i
);
3889 /* Clear hash table H. */
3892 hash_clear (struct Lisp_Hash_Table
*h
)
3896 int i
, size
= HASH_TABLE_SIZE (h
);
3898 for (i
= 0; i
< size
; ++i
)
3900 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3901 HASH_KEY (h
, i
) = Qnil
;
3902 HASH_VALUE (h
, i
) = Qnil
;
3903 HASH_HASH (h
, i
) = Qnil
;
3906 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3907 ASET (h
->index
, i
, Qnil
);
3909 h
->next_free
= make_number (0);
3916 /************************************************************************
3918 ************************************************************************/
3921 init_weak_hash_tables (void)
3923 weak_hash_tables
= NULL
;
3926 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3927 entries from the table that don't survive the current GC.
3928 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3929 non-zero if anything was marked. */
3932 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3934 int bucket
, n
, marked
;
3936 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3939 for (bucket
= 0; bucket
< n
; ++bucket
)
3941 Lisp_Object idx
, next
, prev
;
3943 /* Follow collision chain, removing entries that
3944 don't survive this garbage collection. */
3946 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3948 int i
= XFASTINT (idx
);
3949 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3950 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3953 if (EQ (h
->weak
, Qkey
))
3954 remove_p
= !key_known_to_survive_p
;
3955 else if (EQ (h
->weak
, Qvalue
))
3956 remove_p
= !value_known_to_survive_p
;
3957 else if (EQ (h
->weak
, Qkey_or_value
))
3958 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3959 else if (EQ (h
->weak
, Qkey_and_value
))
3960 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3964 next
= HASH_NEXT (h
, i
);
3966 if (remove_entries_p
)
3970 /* Take out of collision chain. */
3972 HASH_INDEX (h
, bucket
) = next
;
3974 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3976 /* Add to free list. */
3977 HASH_NEXT (h
, i
) = h
->next_free
;
3980 /* Clear key, value, and hash. */
3981 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3982 HASH_HASH (h
, i
) = Qnil
;
3995 /* Make sure key and value survive. */
3996 if (!key_known_to_survive_p
)
3998 mark_object (HASH_KEY (h
, i
));
4002 if (!value_known_to_survive_p
)
4004 mark_object (HASH_VALUE (h
, i
));
4015 /* Remove elements from weak hash tables that don't survive the
4016 current garbage collection. Remove weak tables that don't survive
4017 from Vweak_hash_tables. Called from gc_sweep. */
4020 sweep_weak_hash_tables (void)
4022 struct Lisp_Hash_Table
*h
, *used
, *next
;
4025 /* Mark all keys and values that are in use. Keep on marking until
4026 there is no more change. This is necessary for cases like
4027 value-weak table A containing an entry X -> Y, where Y is used in a
4028 key-weak table B, Z -> Y. If B comes after A in the list of weak
4029 tables, X -> Y might be removed from A, although when looking at B
4030 one finds that it shouldn't. */
4034 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4036 if (h
->size
& ARRAY_MARK_FLAG
)
4037 marked
|= sweep_weak_table (h
, 0);
4042 /* Remove tables and entries that aren't used. */
4043 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4045 next
= h
->next_weak
;
4047 if (h
->size
& ARRAY_MARK_FLAG
)
4049 /* TABLE is marked as used. Sweep its contents. */
4051 sweep_weak_table (h
, 1);
4053 /* Add table to the list of used weak hash tables. */
4054 h
->next_weak
= used
;
4059 weak_hash_tables
= used
;
4064 /***********************************************************************
4065 Hash Code Computation
4066 ***********************************************************************/
4068 /* Maximum depth up to which to dive into Lisp structures. */
4070 #define SXHASH_MAX_DEPTH 3
4072 /* Maximum length up to which to take list and vector elements into
4075 #define SXHASH_MAX_LEN 7
4077 /* Combine two integers X and Y for hashing. */
4079 #define SXHASH_COMBINE(X, Y) \
4080 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4084 /* Return a hash for string PTR which has length LEN. The hash
4085 code returned is guaranteed to fit in a Lisp integer. */
4088 sxhash_string (unsigned char *ptr
, int len
)
4090 unsigned char *p
= ptr
;
4091 unsigned char *end
= p
+ len
;
4100 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4103 return hash
& INTMASK
;
4107 /* Return a hash for list LIST. DEPTH is the current depth in the
4108 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4111 sxhash_list (Lisp_Object list
, int depth
)
4116 if (depth
< SXHASH_MAX_DEPTH
)
4118 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4119 list
= XCDR (list
), ++i
)
4121 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4122 hash
= SXHASH_COMBINE (hash
, hash2
);
4127 unsigned hash2
= sxhash (list
, depth
+ 1);
4128 hash
= SXHASH_COMBINE (hash
, hash2
);
4135 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4136 the Lisp structure. */
4139 sxhash_vector (Lisp_Object vec
, int depth
)
4141 unsigned hash
= ASIZE (vec
);
4144 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4145 for (i
= 0; i
< n
; ++i
)
4147 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4148 hash
= SXHASH_COMBINE (hash
, hash2
);
4155 /* Return a hash for bool-vector VECTOR. */
4158 sxhash_bool_vector (Lisp_Object vec
)
4160 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4163 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4164 for (i
= 0; i
< n
; ++i
)
4165 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4171 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4172 structure. Value is an unsigned integer clipped to INTMASK. */
4175 sxhash (Lisp_Object obj
, int depth
)
4179 if (depth
> SXHASH_MAX_DEPTH
)
4182 switch (XTYPE (obj
))
4193 obj
= SYMBOL_NAME (obj
);
4197 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4200 /* This can be everything from a vector to an overlay. */
4201 case Lisp_Vectorlike
:
4203 /* According to the CL HyperSpec, two arrays are equal only if
4204 they are `eq', except for strings and bit-vectors. In
4205 Emacs, this works differently. We have to compare element
4207 hash
= sxhash_vector (obj
, depth
);
4208 else if (BOOL_VECTOR_P (obj
))
4209 hash
= sxhash_bool_vector (obj
);
4211 /* Others are `equal' if they are `eq', so let's take their
4217 hash
= sxhash_list (obj
, depth
);
4222 double val
= XFLOAT_DATA (obj
);
4223 unsigned char *p
= (unsigned char *) &val
;
4225 for (hash
= 0, i
= 0; i
< sizeof val
; i
++)
4226 hash
= SXHASH_COMBINE (hash
, p
[i
]);
4234 return hash
& INTMASK
;
4239 /***********************************************************************
4241 ***********************************************************************/
4244 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4245 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4248 unsigned hash
= sxhash (obj
, 0);
4249 return make_number (hash
);
4253 DEFUE ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4254 doc
: /* Create and return a new hash table.
4256 Arguments are specified as keyword/argument pairs. The following
4257 arguments are defined:
4259 :test TEST -- TEST must be a symbol that specifies how to compare
4260 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4261 `equal'. User-supplied test and hash functions can be specified via
4262 `define-hash-table-test'.
4264 :size SIZE -- A hint as to how many elements will be put in the table.
4267 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4268 fills up. If REHASH-SIZE is an integer, increase the size by that
4269 amount. If it is a float, it must be > 1.0, and the new size is the
4270 old size multiplied by that factor. Default is 1.5.
4272 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4273 Resize the hash table when the ratio (number of entries / table size)
4274 is greater than or equal to THRESHOLD. Default is 0.8.
4276 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4277 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4278 returned is a weak table. Key/value pairs are removed from a weak
4279 hash table when there are no non-weak references pointing to their
4280 key, value, one of key or value, or both key and value, depending on
4281 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4284 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4285 (size_t nargs
, Lisp_Object
*args
)
4287 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4288 Lisp_Object user_test
, user_hash
;
4292 /* The vector `used' is used to keep track of arguments that
4293 have been consumed. */
4294 used
= (char *) alloca (nargs
* sizeof *used
);
4295 memset (used
, 0, nargs
* sizeof *used
);
4297 /* See if there's a `:test TEST' among the arguments. */
4298 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4299 test
= i
? args
[i
] : Qeql
;
4300 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4302 /* See if it is a user-defined test. */
4305 prop
= Fget (test
, Qhash_table_test
);
4306 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4307 signal_error ("Invalid hash table test", test
);
4308 user_test
= XCAR (prop
);
4309 user_hash
= XCAR (XCDR (prop
));
4312 user_test
= user_hash
= Qnil
;
4314 /* See if there's a `:size SIZE' argument. */
4315 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4316 size
= i
? args
[i
] : Qnil
;
4318 size
= make_number (DEFAULT_HASH_SIZE
);
4319 else if (!INTEGERP (size
) || XINT (size
) < 0)
4320 signal_error ("Invalid hash table size", size
);
4322 /* Look for `:rehash-size SIZE'. */
4323 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4324 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4325 if (!NUMBERP (rehash_size
)
4326 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4327 || XFLOATINT (rehash_size
) <= 1.0)
4328 signal_error ("Invalid hash table rehash size", rehash_size
);
4330 /* Look for `:rehash-threshold THRESHOLD'. */
4331 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4332 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4333 if (!FLOATP (rehash_threshold
)
4334 || XFLOATINT (rehash_threshold
) <= 0.0
4335 || XFLOATINT (rehash_threshold
) > 1.0)
4336 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4338 /* Look for `:weakness WEAK'. */
4339 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4340 weak
= i
? args
[i
] : Qnil
;
4342 weak
= Qkey_and_value
;
4345 && !EQ (weak
, Qvalue
)
4346 && !EQ (weak
, Qkey_or_value
)
4347 && !EQ (weak
, Qkey_and_value
))
4348 signal_error ("Invalid hash table weakness", weak
);
4350 /* Now, all args should have been used up, or there's a problem. */
4351 for (i
= 0; i
< nargs
; ++i
)
4353 signal_error ("Invalid argument list", args
[i
]);
4355 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4356 user_test
, user_hash
);
4360 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4361 doc
: /* Return a copy of hash table TABLE. */)
4364 return copy_hash_table (check_hash_table (table
));
4368 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4369 doc
: /* Return the number of elements in TABLE. */)
4372 return make_number (check_hash_table (table
)->count
);
4376 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4377 Shash_table_rehash_size
, 1, 1, 0,
4378 doc
: /* Return the current rehash size of TABLE. */)
4381 return check_hash_table (table
)->rehash_size
;
4385 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4386 Shash_table_rehash_threshold
, 1, 1, 0,
4387 doc
: /* Return the current rehash threshold of TABLE. */)
4390 return check_hash_table (table
)->rehash_threshold
;
4394 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4395 doc
: /* Return the size of TABLE.
4396 The size can be used as an argument to `make-hash-table' to create
4397 a hash table than can hold as many elements as TABLE holds
4398 without need for resizing. */)
4401 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4402 return make_number (HASH_TABLE_SIZE (h
));
4406 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4407 doc
: /* Return the test TABLE uses. */)
4410 return check_hash_table (table
)->test
;
4414 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4416 doc
: /* Return the weakness of TABLE. */)
4419 return check_hash_table (table
)->weak
;
4423 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4424 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4427 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4431 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4432 doc
: /* Clear hash table TABLE and return it. */)
4435 hash_clear (check_hash_table (table
));
4436 /* Be compatible with XEmacs. */
4441 DEFUE ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4442 doc
: /* Look up KEY in TABLE and return its associated value.
4443 If KEY is not found, return DFLT which defaults to nil. */)
4444 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4446 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4447 int i
= hash_lookup (h
, key
, NULL
);
4448 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4452 DEFUE ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4453 doc
: /* Associate KEY with VALUE in hash table TABLE.
4454 If KEY is already present in table, replace its current value with
4456 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4458 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4462 i
= hash_lookup (h
, key
, &hash
);
4464 HASH_VALUE (h
, i
) = value
;
4466 hash_put (h
, key
, value
, hash
);
4472 DEFUE ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4473 doc
: /* Remove KEY from TABLE. */)
4474 (Lisp_Object key
, Lisp_Object table
)
4476 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4477 hash_remove_from_table (h
, key
);
4482 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4483 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4484 FUNCTION is called with two arguments, KEY and VALUE. */)
4485 (Lisp_Object function
, Lisp_Object table
)
4487 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4488 Lisp_Object args
[3];
4491 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4492 if (!NILP (HASH_HASH (h
, i
)))
4495 args
[1] = HASH_KEY (h
, i
);
4496 args
[2] = HASH_VALUE (h
, i
);
4504 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4505 Sdefine_hash_table_test
, 3, 3, 0,
4506 doc
: /* Define a new hash table test with name NAME, a symbol.
4508 In hash tables created with NAME specified as test, use TEST to
4509 compare keys, and HASH for computing hash codes of keys.
4511 TEST must be a function taking two arguments and returning non-nil if
4512 both arguments are the same. HASH must be a function taking one
4513 argument and return an integer that is the hash code of the argument.
4514 Hash code computation should use the whole value range of integers,
4515 including negative integers. */)
4516 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4518 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4523 /************************************************************************
4525 ************************************************************************/
4529 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4530 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4532 A message digest is a cryptographic checksum of a document, and the
4533 algorithm to calculate it is defined in RFC 1321.
4535 The two optional arguments START and END are character positions
4536 specifying for which part of OBJECT the message digest should be
4537 computed. If nil or omitted, the digest is computed for the whole
4540 The MD5 message digest is computed from the result of encoding the
4541 text in a coding system, not directly from the internal Emacs form of
4542 the text. The optional fourth argument CODING-SYSTEM specifies which
4543 coding system to encode the text with. It should be the same coding
4544 system that you used or will use when actually writing the text into a
4547 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4548 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4549 system would be chosen by default for writing this text into a file.
4551 If OBJECT is a string, the most preferred coding system (see the
4552 command `prefer-coding-system') is used.
4554 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4555 guesswork fails. Normally, an error is signaled in such case. */)
4556 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4558 unsigned char digest
[16];
4562 EMACS_INT size_byte
= 0;
4563 EMACS_INT start_char
= 0, end_char
= 0;
4564 EMACS_INT start_byte
= 0, end_byte
= 0;
4565 register EMACS_INT b
, e
;
4566 register struct buffer
*bp
;
4569 if (STRINGP (object
))
4571 if (NILP (coding_system
))
4573 /* Decide the coding-system to encode the data with. */
4575 if (STRING_MULTIBYTE (object
))
4576 /* use default, we can't guess correct value */
4577 coding_system
= preferred_coding_system ();
4579 coding_system
= Qraw_text
;
4582 if (NILP (Fcoding_system_p (coding_system
)))
4584 /* Invalid coding system. */
4586 if (!NILP (noerror
))
4587 coding_system
= Qraw_text
;
4589 xsignal1 (Qcoding_system_error
, coding_system
);
4592 if (STRING_MULTIBYTE (object
))
4593 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4595 size
= SCHARS (object
);
4596 size_byte
= SBYTES (object
);
4600 CHECK_NUMBER (start
);
4602 start_char
= XINT (start
);
4607 start_byte
= string_char_to_byte (object
, start_char
);
4613 end_byte
= size_byte
;
4619 end_char
= XINT (end
);
4624 end_byte
= string_char_to_byte (object
, end_char
);
4627 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4628 args_out_of_range_3 (object
, make_number (start_char
),
4629 make_number (end_char
));
4633 struct buffer
*prev
= current_buffer
;
4635 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4637 CHECK_BUFFER (object
);
4639 bp
= XBUFFER (object
);
4640 if (bp
!= current_buffer
)
4641 set_buffer_internal (bp
);
4647 CHECK_NUMBER_COERCE_MARKER (start
);
4655 CHECK_NUMBER_COERCE_MARKER (end
);
4660 temp
= b
, b
= e
, e
= temp
;
4662 if (!(BEGV
<= b
&& e
<= ZV
))
4663 args_out_of_range (start
, end
);
4665 if (NILP (coding_system
))
4667 /* Decide the coding-system to encode the data with.
4668 See fileio.c:Fwrite-region */
4670 if (!NILP (Vcoding_system_for_write
))
4671 coding_system
= Vcoding_system_for_write
;
4674 int force_raw_text
= 0;
4676 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4677 if (NILP (coding_system
)
4678 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4680 coding_system
= Qnil
;
4681 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4685 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4687 /* Check file-coding-system-alist. */
4688 Lisp_Object args
[4], val
;
4690 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4691 args
[3] = Fbuffer_file_name(object
);
4692 val
= Ffind_operation_coding_system (4, args
);
4693 if (CONSP (val
) && !NILP (XCDR (val
)))
4694 coding_system
= XCDR (val
);
4697 if (NILP (coding_system
)
4698 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4700 /* If we still have not decided a coding system, use the
4701 default value of buffer-file-coding-system. */
4702 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4706 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4707 /* Confirm that VAL can surely encode the current region. */
4708 coding_system
= call4 (Vselect_safe_coding_system_function
,
4709 make_number (b
), make_number (e
),
4710 coding_system
, Qnil
);
4713 coding_system
= Qraw_text
;
4716 if (NILP (Fcoding_system_p (coding_system
)))
4718 /* Invalid coding system. */
4720 if (!NILP (noerror
))
4721 coding_system
= Qraw_text
;
4723 xsignal1 (Qcoding_system_error
, coding_system
);
4727 object
= make_buffer_string (b
, e
, 0);
4728 if (prev
!= current_buffer
)
4729 set_buffer_internal (prev
);
4730 /* Discard the unwind protect for recovering the current
4734 if (STRING_MULTIBYTE (object
))
4735 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4738 md5_buffer (SSDATA (object
) + start_byte
,
4739 SBYTES (object
) - (size_byte
- end_byte
),
4742 for (i
= 0; i
< 16; i
++)
4743 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4746 return make_string (value
, 32);
4753 /* Hash table stuff. */
4754 Qhash_table_p
= intern_c_string ("hash-table-p");
4755 staticpro (&Qhash_table_p
);
4756 Qeq
= intern_c_string ("eq");
4758 Qeql
= intern_c_string ("eql");
4760 Qequal
= intern_c_string ("equal");
4761 staticpro (&Qequal
);
4762 QCtest
= intern_c_string (":test");
4763 staticpro (&QCtest
);
4764 QCsize
= intern_c_string (":size");
4765 staticpro (&QCsize
);
4766 QCrehash_size
= intern_c_string (":rehash-size");
4767 staticpro (&QCrehash_size
);
4768 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4769 staticpro (&QCrehash_threshold
);
4770 QCweakness
= intern_c_string (":weakness");
4771 staticpro (&QCweakness
);
4772 Qkey
= intern_c_string ("key");
4774 Qvalue
= intern_c_string ("value");
4775 staticpro (&Qvalue
);
4776 Qhash_table_test
= intern_c_string ("hash-table-test");
4777 staticpro (&Qhash_table_test
);
4778 Qkey_or_value
= intern_c_string ("key-or-value");
4779 staticpro (&Qkey_or_value
);
4780 Qkey_and_value
= intern_c_string ("key-and-value");
4781 staticpro (&Qkey_and_value
);
4784 defsubr (&Smake_hash_table
);
4785 defsubr (&Scopy_hash_table
);
4786 defsubr (&Shash_table_count
);
4787 defsubr (&Shash_table_rehash_size
);
4788 defsubr (&Shash_table_rehash_threshold
);
4789 defsubr (&Shash_table_size
);
4790 defsubr (&Shash_table_test
);
4791 defsubr (&Shash_table_weakness
);
4792 defsubr (&Shash_table_p
);
4793 defsubr (&Sclrhash
);
4794 defsubr (&Sgethash
);
4795 defsubr (&Sputhash
);
4796 defsubr (&Sremhash
);
4797 defsubr (&Smaphash
);
4798 defsubr (&Sdefine_hash_table_test
);
4800 Qstring_lessp
= intern_c_string ("string-lessp");
4801 staticpro (&Qstring_lessp
);
4802 Qprovide
= intern_c_string ("provide");
4803 staticpro (&Qprovide
);
4804 Qrequire
= intern_c_string ("require");
4805 staticpro (&Qrequire
);
4806 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4807 staticpro (&Qyes_or_no_p_history
);
4808 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4809 staticpro (&Qcursor_in_echo_area
);
4810 Qwidget_type
= intern_c_string ("widget-type");
4811 staticpro (&Qwidget_type
);
4813 staticpro (&string_char_byte_cache_string
);
4814 string_char_byte_cache_string
= Qnil
;
4816 require_nesting_list
= Qnil
;
4817 staticpro (&require_nesting_list
);
4819 Fset (Qyes_or_no_p_history
, Qnil
);
4821 DEFVAR_LISP ("features", Vfeatures
,
4822 doc
: /* A list of symbols which are the features of the executing Emacs.
4823 Used by `featurep' and `require', and altered by `provide'. */);
4824 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4825 Qsubfeatures
= intern_c_string ("subfeatures");
4826 staticpro (&Qsubfeatures
);
4828 #ifdef HAVE_LANGINFO_CODESET
4829 Qcodeset
= intern_c_string ("codeset");
4830 staticpro (&Qcodeset
);
4831 Qdays
= intern_c_string ("days");
4833 Qmonths
= intern_c_string ("months");
4834 staticpro (&Qmonths
);
4835 Qpaper
= intern_c_string ("paper");
4836 staticpro (&Qpaper
);
4837 #endif /* HAVE_LANGINFO_CODESET */
4839 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4840 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4841 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4842 invoked by mouse clicks and mouse menu items.
4844 On some platforms, file selection dialogs are also enabled if this is
4848 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4849 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4850 This applies to commands from menus and tool bar buttons even when
4851 they are initiated from the keyboard. If `use-dialog-box' is nil,
4852 that disables the use of a file dialog, regardless of the value of
4854 use_file_dialog
= 1;
4856 defsubr (&Sidentity
);
4859 defsubr (&Ssafe_length
);
4860 defsubr (&Sstring_bytes
);
4861 defsubr (&Sstring_equal
);
4862 defsubr (&Scompare_strings
);
4863 defsubr (&Sstring_lessp
);
4866 defsubr (&Svconcat
);
4867 defsubr (&Scopy_sequence
);
4868 defsubr (&Sstring_make_multibyte
);
4869 defsubr (&Sstring_make_unibyte
);
4870 defsubr (&Sstring_as_multibyte
);
4871 defsubr (&Sstring_as_unibyte
);
4872 defsubr (&Sstring_to_multibyte
);
4873 defsubr (&Sstring_to_unibyte
);
4874 defsubr (&Scopy_alist
);
4875 defsubr (&Ssubstring
);
4876 defsubr (&Ssubstring_no_properties
);
4889 defsubr (&Snreverse
);
4890 defsubr (&Sreverse
);
4892 defsubr (&Splist_get
);
4894 defsubr (&Splist_put
);
4896 defsubr (&Slax_plist_get
);
4897 defsubr (&Slax_plist_put
);
4900 defsubr (&Sequal_including_properties
);
4901 defsubr (&Sfillarray
);
4902 defsubr (&Sclear_string
);
4906 defsubr (&Smapconcat
);
4907 defsubr (&Syes_or_no_p
);
4908 defsubr (&Sload_average
);
4909 defsubr (&Sfeaturep
);
4910 defsubr (&Srequire
);
4911 defsubr (&Sprovide
);
4912 defsubr (&Splist_member
);
4913 defsubr (&Swidget_put
);
4914 defsubr (&Swidget_get
);
4915 defsubr (&Swidget_apply
);
4916 defsubr (&Sbase64_encode_region
);
4917 defsubr (&Sbase64_decode_region
);
4918 defsubr (&Sbase64_encode_string
);
4919 defsubr (&Sbase64_decode_string
);
4921 defsubr (&Slocale_info
);