1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 03, 2004
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 2, or (at your option)
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; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
41 #include "character.h"
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, MAX_CHAR
);
151 else if (BOOL_VECTOR_P (sequence
))
152 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
153 else if (COMPILEDP (sequence
))
154 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
155 else if (CONSP (sequence
))
158 while (CONSP (sequence
))
160 sequence
= XCDR (sequence
);
163 if (!CONSP (sequence
))
166 sequence
= XCDR (sequence
);
171 if (!NILP (sequence
))
172 wrong_type_argument (Qlistp
, sequence
);
174 val
= make_number (i
);
176 else if (NILP (sequence
))
177 XSETFASTINT (val
, 0);
180 sequence
= wrong_type_argument (Qsequencep
, sequence
);
186 /* This does not check for quits. That is safe
187 since it must terminate. */
189 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
190 doc
: /* Return the length of a list, but avoid error or infinite loop.
191 This function never gets an error. If LIST is not really a list,
192 it returns 0. If LIST is circular, it returns a finite value
193 which is at least the number of distinct elements. */)
197 Lisp_Object tail
, halftail
, length
;
200 /* halftail is used to detect circular lists. */
202 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
204 if (EQ (tail
, halftail
) && len
!= 0)
208 halftail
= XCDR (halftail
);
211 XSETINT (length
, len
);
215 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
216 doc
: /* Return the number of bytes in STRING.
217 If STRING is a multibyte string, this is greater than the length of STRING. */)
221 CHECK_STRING (string
);
222 return make_number (SBYTES (string
));
225 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
226 doc
: /* Return t if two strings have identical contents.
227 Case is significant, but text properties are ignored.
228 Symbols are also allowed; their print names are used instead. */)
230 register Lisp_Object s1
, s2
;
233 s1
= SYMBOL_NAME (s1
);
235 s2
= SYMBOL_NAME (s2
);
239 if (SCHARS (s1
) != SCHARS (s2
)
240 || SBYTES (s1
) != SBYTES (s2
)
241 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
246 DEFUN ("compare-strings", Fcompare_strings
,
247 Scompare_strings
, 6, 7, 0,
248 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
249 In string STR1, skip the first START1 characters and stop at END1.
250 In string STR2, skip the first START2 characters and stop at END2.
251 END1 and END2 default to the full lengths of the respective strings.
253 Case is significant in this comparison if IGNORE-CASE is nil.
254 Unibyte strings are converted to multibyte for comparison.
256 The value is t if the strings (or specified portions) match.
257 If string STR1 is less, the value is a negative number N;
258 - 1 - N is the number of characters that match at the beginning.
259 If string STR1 is greater, the value is a positive number N;
260 N - 1 is the number of characters that match at the beginning. */)
261 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
262 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
264 register int end1_char
, end2_char
;
265 register int i1
, i1_byte
, i2
, i2_byte
;
270 start1
= make_number (0);
272 start2
= make_number (0);
273 CHECK_NATNUM (start1
);
274 CHECK_NATNUM (start2
);
283 i1_byte
= string_char_to_byte (str1
, i1
);
284 i2_byte
= string_char_to_byte (str2
, i2
);
286 end1_char
= SCHARS (str1
);
287 if (! NILP (end1
) && end1_char
> XINT (end1
))
288 end1_char
= XINT (end1
);
290 end2_char
= SCHARS (str2
);
291 if (! NILP (end2
) && end2_char
> XINT (end2
))
292 end2_char
= XINT (end2
);
294 while (i1
< end1_char
&& i2
< end2_char
)
296 /* When we find a mismatch, we must compare the
297 characters, not just the bytes. */
300 if (STRING_MULTIBYTE (str1
))
301 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
304 c1
= SREF (str1
, i1
++);
305 c1
= unibyte_char_to_multibyte (c1
);
308 if (STRING_MULTIBYTE (str2
))
309 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
312 c2
= SREF (str2
, i2
++);
313 c2
= unibyte_char_to_multibyte (c2
);
319 if (! NILP (ignore_case
))
323 tem
= Fupcase (make_number (c1
));
325 tem
= Fupcase (make_number (c2
));
332 /* Note that I1 has already been incremented
333 past the character that we are comparing;
334 hence we don't add or subtract 1 here. */
336 return make_number (- i1
+ XINT (start1
));
338 return make_number (i1
- XINT (start1
));
342 return make_number (i1
- XINT (start1
) + 1);
344 return make_number (- i1
+ XINT (start1
) - 1);
349 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
350 doc
: /* Return t if first arg string is less than second in lexicographic order.
352 Symbols are also allowed; their print names are used instead. */)
354 register Lisp_Object s1
, s2
;
357 register int i1
, i1_byte
, i2
, i2_byte
;
360 s1
= SYMBOL_NAME (s1
);
362 s2
= SYMBOL_NAME (s2
);
366 i1
= i1_byte
= i2
= i2_byte
= 0;
369 if (end
> SCHARS (s2
))
374 /* When we find a mismatch, we must compare the
375 characters, not just the bytes. */
378 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
379 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
382 return c1
< c2
? Qt
: Qnil
;
384 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
387 static Lisp_Object
concat ();
398 return concat (2, args
, Lisp_String
, 0);
400 return concat (2, &s1
, Lisp_String
, 0);
401 #endif /* NO_ARG_ARRAY */
407 Lisp_Object s1
, s2
, s3
;
414 return concat (3, args
, Lisp_String
, 0);
416 return concat (3, &s1
, Lisp_String
, 0);
417 #endif /* NO_ARG_ARRAY */
420 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
421 doc
: /* Concatenate all the arguments and make the result a list.
422 The result is a list whose elements are the elements of all the arguments.
423 Each argument may be a list, vector or string.
424 The last argument is not copied, just used as the tail of the new list.
425 usage: (append &rest SEQUENCES) */)
430 return concat (nargs
, args
, Lisp_Cons
, 1);
433 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
434 doc
: /* Concatenate all the arguments and make the result a string.
435 The result is a string whose elements are the elements of all the arguments.
436 Each argument may be a string or a list or vector of characters (integers).
437 usage: (concat &rest SEQUENCES) */)
442 return concat (nargs
, args
, Lisp_String
, 0);
445 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
446 doc
: /* Concatenate all the arguments and make the result a vector.
447 The result is a vector whose elements are the elements of all the arguments.
448 Each argument may be a list, vector or string.
449 usage: (vconcat &rest SEQUENCES) */)
454 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
458 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
459 doc
: /* Return a copy of a list, vector, string or char-table.
460 The elements of a list or vector are not copied; they are shared
461 with the original. */)
465 if (NILP (arg
)) return arg
;
467 if (CHAR_TABLE_P (arg
))
469 return copy_char_table (arg
);
472 if (BOOL_VECTOR_P (arg
))
476 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
477 / BOOL_VECTOR_BITS_PER_CHAR
);
479 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
480 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
485 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
486 arg
= wrong_type_argument (Qsequencep
, arg
);
487 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
490 /* This structure holds information of an argument of `concat' that is
491 a string and has text properties to be copied. */
494 int argnum
; /* refer to ARGS (arguments of `concat') */
495 int from
; /* refer to ARGS[argnum] (argument string) */
496 int to
; /* refer to VAL (the target string) */
500 concat (nargs
, args
, target_type
, last_special
)
503 enum Lisp_Type target_type
;
507 register Lisp_Object tail
;
508 register Lisp_Object
this;
510 int toindex_byte
= 0;
511 register int result_len
;
512 register int result_len_byte
;
514 Lisp_Object last_tail
;
517 /* When we make a multibyte string, we can't copy text properties
518 while concatinating each string because the length of resulting
519 string can't be decided until we finish the whole concatination.
520 So, we record strings that have text properties to be copied
521 here, and copy the text properties after the concatination. */
522 struct textprop_rec
*textprops
= NULL
;
523 /* Number of elments in textprops. */
524 int num_textprops
= 0;
528 /* In append, the last arg isn't treated like the others */
529 if (last_special
&& nargs
> 0)
532 last_tail
= args
[nargs
];
537 /* Canonicalize each argument. */
538 for (argnum
= 0; argnum
< nargs
; argnum
++)
541 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
542 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
544 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
548 /* Compute total length in chars of arguments in RESULT_LEN.
549 If desired output is a string, also compute length in bytes
550 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
551 whether the result should be a multibyte string. */
555 for (argnum
= 0; argnum
< nargs
; argnum
++)
559 len
= XFASTINT (Flength (this));
560 if (target_type
== Lisp_String
)
562 /* We must count the number of bytes needed in the string
563 as well as the number of characters. */
569 for (i
= 0; i
< len
; i
++)
571 ch
= XVECTOR (this)->contents
[i
];
572 if (! CHARACTERP (ch
))
573 wrong_type_argument (Qcharacterp
, ch
);
574 this_len_byte
= CHAR_BYTES (XINT (ch
));
575 result_len_byte
+= this_len_byte
;
576 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
579 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
580 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
581 else if (CONSP (this))
582 for (; CONSP (this); this = XCDR (this))
585 if (! CHARACTERP (ch
))
586 wrong_type_argument (Qcharacterp
, ch
);
587 this_len_byte
= CHAR_BYTES (XINT (ch
));
588 result_len_byte
+= this_len_byte
;
589 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
592 else if (STRINGP (this))
594 if (STRING_MULTIBYTE (this))
597 result_len_byte
+= SBYTES (this);
600 result_len_byte
+= count_size_as_multibyte (SDATA (this),
608 if (! some_multibyte
)
609 result_len_byte
= result_len
;
611 /* Create the output object. */
612 if (target_type
== Lisp_Cons
)
613 val
= Fmake_list (make_number (result_len
), Qnil
);
614 else if (target_type
== Lisp_Vectorlike
)
615 val
= Fmake_vector (make_number (result_len
), Qnil
);
616 else if (some_multibyte
)
617 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
619 val
= make_uninit_string (result_len
);
621 /* In `append', if all but last arg are nil, return last arg. */
622 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
625 /* Copy the contents of the args into the result. */
627 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
629 toindex
= 0, toindex_byte
= 0;
634 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
636 for (argnum
= 0; argnum
< nargs
; argnum
++)
640 register unsigned int thisindex
= 0;
641 register unsigned int thisindex_byte
= 0;
645 thislen
= Flength (this), thisleni
= XINT (thislen
);
647 /* Between strings of the same kind, copy fast. */
648 if (STRINGP (this) && STRINGP (val
)
649 && STRING_MULTIBYTE (this) == some_multibyte
)
651 int thislen_byte
= SBYTES (this);
653 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
655 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
657 textprops
[num_textprops
].argnum
= argnum
;
658 textprops
[num_textprops
].from
= 0;
659 textprops
[num_textprops
++].to
= toindex
;
661 toindex_byte
+= thislen_byte
;
663 STRING_SET_CHARS (val
, SCHARS (val
));
665 /* Copy a single-byte string to a multibyte string. */
666 else if (STRINGP (this) && STRINGP (val
))
668 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
670 textprops
[num_textprops
].argnum
= argnum
;
671 textprops
[num_textprops
].from
= 0;
672 textprops
[num_textprops
++].to
= toindex
;
674 toindex_byte
+= copy_text (SDATA (this),
675 SDATA (val
) + toindex_byte
,
676 SCHARS (this), 0, 1);
680 /* Copy element by element. */
683 register Lisp_Object elt
;
685 /* Fetch next element of `this' arg into `elt', or break if
686 `this' is exhausted. */
687 if (NILP (this)) break;
689 elt
= XCAR (this), this = XCDR (this);
690 else if (thisindex
>= thisleni
)
692 else if (STRINGP (this))
695 if (STRING_MULTIBYTE (this))
697 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
700 XSETFASTINT (elt
, c
);
704 XSETFASTINT (elt
, SREF (this, thisindex
++));
706 && XINT (elt
) >= 0200
707 && XINT (elt
) < 0400)
709 c
= unibyte_char_to_multibyte (XINT (elt
));
714 else if (BOOL_VECTOR_P (this))
717 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
718 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
725 elt
= XVECTOR (this)->contents
[thisindex
++];
727 /* Store this element into the result. */
734 else if (VECTORP (val
))
735 XVECTOR (val
)->contents
[toindex
++] = elt
;
740 toindex_byte
+= CHAR_STRING (XINT (elt
),
741 SDATA (val
) + toindex_byte
);
743 SSET (val
, toindex_byte
++, XINT (elt
));
749 XSETCDR (prev
, last_tail
);
751 if (num_textprops
> 0)
754 int last_to_end
= -1;
756 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
758 this = args
[textprops
[argnum
].argnum
];
759 props
= text_property_list (this,
761 make_number (SCHARS (this)),
763 /* If successive arguments have properites, be sure that the
764 value of `composition' property be the copy. */
765 if (last_to_end
== textprops
[argnum
].to
)
766 make_composition_value_copy (props
);
767 add_text_properties_from_list (val
, props
,
768 make_number (textprops
[argnum
].to
));
769 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
775 static Lisp_Object string_char_byte_cache_string
;
776 static int string_char_byte_cache_charpos
;
777 static int string_char_byte_cache_bytepos
;
780 clear_string_char_byte_cache ()
782 string_char_byte_cache_string
= Qnil
;
785 /* Return the character index corresponding to CHAR_INDEX in STRING. */
788 string_char_to_byte (string
, char_index
)
793 int best_below
, best_below_byte
;
794 int best_above
, best_above_byte
;
796 best_below
= best_below_byte
= 0;
797 best_above
= SCHARS (string
);
798 best_above_byte
= SBYTES (string
);
799 if (best_above
== best_above_byte
)
802 if (EQ (string
, string_char_byte_cache_string
))
804 if (string_char_byte_cache_charpos
< char_index
)
806 best_below
= string_char_byte_cache_charpos
;
807 best_below_byte
= string_char_byte_cache_bytepos
;
811 best_above
= string_char_byte_cache_charpos
;
812 best_above_byte
= string_char_byte_cache_bytepos
;
816 if (char_index
- best_below
< best_above
- char_index
)
818 unsigned char *p
= SDATA (string
) + best_below_byte
;
820 while (best_below
< char_index
)
822 p
+= BYTES_BY_CHAR_HEAD (*p
);
825 i_byte
= p
- SDATA (string
);
829 unsigned char *p
= SDATA (string
) + best_above_byte
;
831 while (best_above
> char_index
)
834 while (!CHAR_HEAD_P (*p
)) p
--;
837 i_byte
= p
- SDATA (string
);
840 string_char_byte_cache_bytepos
= i_byte
;
841 string_char_byte_cache_charpos
= char_index
;
842 string_char_byte_cache_string
= string
;
847 /* Return the character index corresponding to BYTE_INDEX in STRING. */
850 string_byte_to_char (string
, byte_index
)
855 int best_below
, best_below_byte
;
856 int best_above
, best_above_byte
;
858 best_below
= best_below_byte
= 0;
859 best_above
= SCHARS (string
);
860 best_above_byte
= SBYTES (string
);
861 if (best_above
== best_above_byte
)
864 if (EQ (string
, string_char_byte_cache_string
))
866 if (string_char_byte_cache_bytepos
< byte_index
)
868 best_below
= string_char_byte_cache_charpos
;
869 best_below_byte
= string_char_byte_cache_bytepos
;
873 best_above
= string_char_byte_cache_charpos
;
874 best_above_byte
= string_char_byte_cache_bytepos
;
878 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
880 unsigned char *p
= SDATA (string
) + best_below_byte
;
881 unsigned char *pend
= SDATA (string
) + byte_index
;
885 p
+= BYTES_BY_CHAR_HEAD (*p
);
889 i_byte
= p
- SDATA (string
);
893 unsigned char *p
= SDATA (string
) + best_above_byte
;
894 unsigned char *pbeg
= SDATA (string
) + byte_index
;
899 while (!CHAR_HEAD_P (*p
)) p
--;
903 i_byte
= p
- SDATA (string
);
906 string_char_byte_cache_bytepos
= i_byte
;
907 string_char_byte_cache_charpos
= i
;
908 string_char_byte_cache_string
= string
;
913 /* Convert STRING to a multibyte string. */
916 string_make_multibyte (string
)
924 if (STRING_MULTIBYTE (string
))
927 nbytes
= count_size_as_multibyte (SDATA (string
),
929 /* If all the chars are ASCII, they won't need any more bytes
930 once converted. In that case, we can return STRING itself. */
931 if (nbytes
== SBYTES (string
))
934 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
935 copy_text (SDATA (string
), buf
, SBYTES (string
),
938 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
945 /* Convert STRING (if unibyte) to a multibyte string without changing
946 the number of characters. Characters 0200 trough 0237 are
947 converted to eight-bit characters. */
950 string_to_multibyte (string
)
958 if (STRING_MULTIBYTE (string
))
961 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
962 /* If all the chars are ASCII, they won't need any more bytes once
964 if (nbytes
== SBYTES (string
))
965 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
967 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
968 bcopy (SDATA (string
), buf
, SBYTES (string
));
969 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
971 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
978 /* Convert STRING to a single-byte string. */
981 string_make_unibyte (string
)
989 if (! STRING_MULTIBYTE (string
))
992 nchars
= SCHARS (string
);
994 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
995 copy_text (SDATA (string
), buf
, SBYTES (string
),
998 ret
= make_unibyte_string (buf
, nchars
);
1004 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1006 doc
: /* Return the multibyte equivalent of STRING.
1007 If STRING is unibyte and contains non-ASCII characters, the function
1008 `unibyte-char-to-multibyte' is used to convert each unibyte character
1009 to a multibyte character. In this case, the returned string is a
1010 newly created string with no text properties. If STRING is multibyte
1011 or entirely ASCII, it is returned unchanged. In particular, when
1012 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1013 \(When the characters are all ASCII, Emacs primitives will treat the
1014 string the same way whether it is unibyte or multibyte.) */)
1018 CHECK_STRING (string
);
1020 return string_make_multibyte (string
);
1023 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1025 doc
: /* Return the unibyte equivalent of STRING.
1026 Multibyte character codes are converted to unibyte according to
1027 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1028 If the lookup in the translation table fails, this function takes just
1029 the low 8 bits of each character. */)
1033 CHECK_STRING (string
);
1035 return string_make_unibyte (string
);
1038 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1040 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1041 If STRING is unibyte, the result is STRING itself.
1042 Otherwise it is a newly created string, with no text properties.
1043 If STRING is multibyte and contains a character of charset
1044 `eight-bit', it is converted to the corresponding single byte. */)
1048 CHECK_STRING (string
);
1050 if (STRING_MULTIBYTE (string
))
1052 int bytes
= SBYTES (string
);
1053 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1055 bcopy (SDATA (string
), str
, bytes
);
1056 bytes
= str_as_unibyte (str
, bytes
);
1057 string
= make_unibyte_string (str
, bytes
);
1063 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1065 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1066 If STRING is multibyte, the result is STRING itself.
1067 Otherwise it is a newly created string, with no text properties.
1069 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1070 part of a correct utf-8 sequence), it is converted to the corresponding
1071 multibyte character of charset `eight-bit'.
1072 See also `string-to-multibyte'. */)
1076 CHECK_STRING (string
);
1078 if (! STRING_MULTIBYTE (string
))
1080 Lisp_Object new_string
;
1083 parse_str_as_multibyte (SDATA (string
),
1086 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1087 bcopy (SDATA (string
), SDATA (new_string
),
1089 if (nbytes
!= SBYTES (string
))
1090 str_as_multibyte (SDATA (new_string
), nbytes
,
1091 SBYTES (string
), NULL
);
1092 string
= new_string
;
1093 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1098 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1100 doc
: /* Return a multibyte string with the same individual chars as STRING.
1101 If STRING is multibyte, the result is STRING itself.
1102 Otherwise it is a newly created string, with no text properties.
1104 If STRING is unibyte and contains an 8-bit byte, it is converted to
1105 the corresponding multibyte character of charset `eight-bit'.
1107 This differs from `string-as-multibyte' by converting each byte of a correct
1108 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1109 correct sequence. */)
1113 CHECK_STRING (string
);
1115 return string_to_multibyte (string
);
1119 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1120 doc
: /* Return a copy of ALIST.
1121 This is an alist which represents the same mapping from objects to objects,
1122 but does not share the alist structure with ALIST.
1123 The objects mapped (cars and cdrs of elements of the alist)
1124 are shared, however.
1125 Elements of ALIST that are not conses are also shared. */)
1129 register Lisp_Object tem
;
1134 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1135 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1137 register Lisp_Object car
;
1141 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1146 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1147 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1148 TO may be nil or omitted; then the substring runs to the end of STRING.
1149 FROM and TO start at 0. If either is negative, it counts from the end.
1151 This function allows vectors as well as strings. */)
1154 register Lisp_Object from
, to
;
1159 int from_char
, to_char
;
1160 int from_byte
= 0, to_byte
= 0;
1162 if (! (STRINGP (string
) || VECTORP (string
)))
1163 wrong_type_argument (Qarrayp
, string
);
1165 CHECK_NUMBER (from
);
1167 if (STRINGP (string
))
1169 size
= SCHARS (string
);
1170 size_byte
= SBYTES (string
);
1173 size
= XVECTOR (string
)->size
;
1178 to_byte
= size_byte
;
1184 to_char
= XINT (to
);
1188 if (STRINGP (string
))
1189 to_byte
= string_char_to_byte (string
, to_char
);
1192 from_char
= XINT (from
);
1195 if (STRINGP (string
))
1196 from_byte
= string_char_to_byte (string
, from_char
);
1198 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1199 args_out_of_range_3 (string
, make_number (from_char
),
1200 make_number (to_char
));
1202 if (STRINGP (string
))
1204 res
= make_specified_string (SDATA (string
) + from_byte
,
1205 to_char
- from_char
, to_byte
- from_byte
,
1206 STRING_MULTIBYTE (string
));
1207 copy_text_properties (make_number (from_char
), make_number (to_char
),
1208 string
, make_number (0), res
, Qnil
);
1211 res
= Fvector (to_char
- from_char
,
1212 XVECTOR (string
)->contents
+ from_char
);
1218 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1219 doc
: /* Return a substring of STRING, without text properties.
1220 It starts at index FROM and ending before TO.
1221 TO may be nil or omitted; then the substring runs to the end of STRING.
1222 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1223 If FROM or TO is negative, it counts from the end.
1225 With one argument, just copy STRING without its properties. */)
1228 register Lisp_Object from
, to
;
1230 int size
, size_byte
;
1231 int from_char
, to_char
;
1232 int from_byte
, to_byte
;
1234 CHECK_STRING (string
);
1236 size
= SCHARS (string
);
1237 size_byte
= SBYTES (string
);
1240 from_char
= from_byte
= 0;
1243 CHECK_NUMBER (from
);
1244 from_char
= XINT (from
);
1248 from_byte
= string_char_to_byte (string
, from_char
);
1254 to_byte
= size_byte
;
1260 to_char
= XINT (to
);
1264 to_byte
= string_char_to_byte (string
, to_char
);
1267 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1268 args_out_of_range_3 (string
, make_number (from_char
),
1269 make_number (to_char
));
1271 return make_specified_string (SDATA (string
) + from_byte
,
1272 to_char
- from_char
, to_byte
- from_byte
,
1273 STRING_MULTIBYTE (string
));
1276 /* Extract a substring of STRING, giving start and end positions
1277 both in characters and in bytes. */
1280 substring_both (string
, from
, from_byte
, to
, to_byte
)
1282 int from
, from_byte
, to
, to_byte
;
1288 if (! (STRINGP (string
) || VECTORP (string
)))
1289 wrong_type_argument (Qarrayp
, string
);
1291 if (STRINGP (string
))
1293 size
= SCHARS (string
);
1294 size_byte
= SBYTES (string
);
1297 size
= XVECTOR (string
)->size
;
1299 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1300 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1302 if (STRINGP (string
))
1304 res
= make_specified_string (SDATA (string
) + from_byte
,
1305 to
- from
, to_byte
- from_byte
,
1306 STRING_MULTIBYTE (string
));
1307 copy_text_properties (make_number (from
), make_number (to
),
1308 string
, make_number (0), res
, Qnil
);
1311 res
= Fvector (to
- from
,
1312 XVECTOR (string
)->contents
+ from
);
1317 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1318 doc
: /* Take cdr N times on LIST, returns the result. */)
1321 register Lisp_Object list
;
1323 register int i
, num
;
1326 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1330 wrong_type_argument (Qlistp
, list
);
1336 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1337 doc
: /* Return the Nth element of LIST.
1338 N counts from zero. If LIST is not that long, nil is returned. */)
1340 Lisp_Object n
, list
;
1342 return Fcar (Fnthcdr (n
, list
));
1345 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1346 doc
: /* Return element of SEQUENCE at index N. */)
1348 register Lisp_Object sequence
, n
;
1353 if (CONSP (sequence
) || NILP (sequence
))
1354 return Fcar (Fnthcdr (n
, sequence
));
1355 else if (STRINGP (sequence
) || VECTORP (sequence
)
1356 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1357 return Faref (sequence
, n
);
1359 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1363 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1364 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1365 The value is actually the tail of LIST whose car is ELT. */)
1367 register Lisp_Object elt
;
1370 register Lisp_Object tail
;
1371 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1373 register Lisp_Object tem
;
1375 wrong_type_argument (Qlistp
, list
);
1377 if (! NILP (Fequal (elt
, tem
)))
1384 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1385 doc
: /* Return non-nil if ELT is an element of LIST.
1386 Comparison done with EQ. The value is actually the tail of LIST
1387 whose car is ELT. */)
1389 Lisp_Object elt
, list
;
1393 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1397 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1401 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1408 if (!CONSP (list
) && !NILP (list
))
1409 list
= wrong_type_argument (Qlistp
, list
);
1414 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1415 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1416 The value is actually the first element of LIST whose car is KEY.
1417 Elements of LIST that are not conses are ignored. */)
1419 Lisp_Object key
, list
;
1426 || (CONSP (XCAR (list
))
1427 && EQ (XCAR (XCAR (list
)), key
)))
1432 || (CONSP (XCAR (list
))
1433 && EQ (XCAR (XCAR (list
)), key
)))
1438 || (CONSP (XCAR (list
))
1439 && EQ (XCAR (XCAR (list
)), key
)))
1447 result
= XCAR (list
);
1448 else if (NILP (list
))
1451 result
= wrong_type_argument (Qlistp
, list
);
1456 /* Like Fassq but never report an error and do not allow quits.
1457 Use only on lists known never to be circular. */
1460 assq_no_quit (key
, list
)
1461 Lisp_Object key
, list
;
1464 && (!CONSP (XCAR (list
))
1465 || !EQ (XCAR (XCAR (list
)), key
)))
1468 return CONSP (list
) ? XCAR (list
) : Qnil
;
1471 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1472 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1473 The value is actually the first element of LIST whose car equals KEY. */)
1475 Lisp_Object key
, list
;
1477 Lisp_Object result
, car
;
1482 || (CONSP (XCAR (list
))
1483 && (car
= XCAR (XCAR (list
)),
1484 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1489 || (CONSP (XCAR (list
))
1490 && (car
= XCAR (XCAR (list
)),
1491 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1496 || (CONSP (XCAR (list
))
1497 && (car
= XCAR (XCAR (list
)),
1498 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1506 result
= XCAR (list
);
1507 else if (NILP (list
))
1510 result
= wrong_type_argument (Qlistp
, list
);
1515 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1516 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1517 The value is actually the first element of LIST whose cdr is KEY. */)
1519 register Lisp_Object key
;
1527 || (CONSP (XCAR (list
))
1528 && EQ (XCDR (XCAR (list
)), key
)))
1533 || (CONSP (XCAR (list
))
1534 && EQ (XCDR (XCAR (list
)), key
)))
1539 || (CONSP (XCAR (list
))
1540 && EQ (XCDR (XCAR (list
)), key
)))
1549 else if (CONSP (list
))
1550 result
= XCAR (list
);
1552 result
= wrong_type_argument (Qlistp
, list
);
1557 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1558 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1559 The value is actually the first element of LIST whose cdr equals KEY. */)
1561 Lisp_Object key
, list
;
1563 Lisp_Object result
, cdr
;
1568 || (CONSP (XCAR (list
))
1569 && (cdr
= XCDR (XCAR (list
)),
1570 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1575 || (CONSP (XCAR (list
))
1576 && (cdr
= XCDR (XCAR (list
)),
1577 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1582 || (CONSP (XCAR (list
))
1583 && (cdr
= XCDR (XCAR (list
)),
1584 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1592 result
= XCAR (list
);
1593 else if (NILP (list
))
1596 result
= wrong_type_argument (Qlistp
, list
);
1601 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1602 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1603 The modified LIST is returned. Comparison is done with `eq'.
1604 If the first member of LIST is ELT, there is no way to remove it by side effect;
1605 therefore, write `(setq foo (delq element foo))'
1606 to be sure of changing the value of `foo'. */)
1608 register Lisp_Object elt
;
1611 register Lisp_Object tail
, prev
;
1612 register Lisp_Object tem
;
1616 while (!NILP (tail
))
1619 wrong_type_argument (Qlistp
, list
);
1626 Fsetcdr (prev
, XCDR (tail
));
1636 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1637 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1638 SEQ must be a list, a vector, or a string.
1639 The modified SEQ is returned. Comparison is done with `equal'.
1640 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1641 is not a side effect; it is simply using a different sequence.
1642 Therefore, write `(setq foo (delete element foo))'
1643 to be sure of changing the value of `foo'. */)
1645 Lisp_Object elt
, seq
;
1651 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1652 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1655 if (n
!= ASIZE (seq
))
1657 struct Lisp_Vector
*p
= allocate_vector (n
);
1659 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1660 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1661 p
->contents
[n
++] = AREF (seq
, i
);
1663 XSETVECTOR (seq
, p
);
1666 else if (STRINGP (seq
))
1668 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1671 for (i
= nchars
= nbytes
= ibyte
= 0;
1673 ++i
, ibyte
+= cbytes
)
1675 if (STRING_MULTIBYTE (seq
))
1677 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1678 SBYTES (seq
) - ibyte
);
1679 cbytes
= CHAR_BYTES (c
);
1687 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1694 if (nchars
!= SCHARS (seq
))
1698 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1699 if (!STRING_MULTIBYTE (seq
))
1700 STRING_SET_UNIBYTE (tem
);
1702 for (i
= nchars
= nbytes
= ibyte
= 0;
1704 ++i
, ibyte
+= cbytes
)
1706 if (STRING_MULTIBYTE (seq
))
1708 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1709 SBYTES (seq
) - ibyte
);
1710 cbytes
= CHAR_BYTES (c
);
1718 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1720 unsigned char *from
= SDATA (seq
) + ibyte
;
1721 unsigned char *to
= SDATA (tem
) + nbytes
;
1727 for (n
= cbytes
; n
--; )
1737 Lisp_Object tail
, prev
;
1739 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1742 wrong_type_argument (Qlistp
, seq
);
1744 if (!NILP (Fequal (elt
, XCAR (tail
))))
1749 Fsetcdr (prev
, XCDR (tail
));
1760 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1761 doc
: /* Reverse LIST by modifying cdr pointers.
1762 Return the reversed list. */)
1766 register Lisp_Object prev
, tail
, next
;
1768 if (NILP (list
)) return list
;
1771 while (!NILP (tail
))
1775 wrong_type_argument (Qlistp
, list
);
1777 Fsetcdr (tail
, prev
);
1784 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1785 doc
: /* Reverse LIST, copying. Return the reversed list.
1786 See also the function `nreverse', which is used more often. */)
1792 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1795 new = Fcons (XCAR (list
), new);
1798 wrong_type_argument (Qconsp
, list
);
1802 Lisp_Object
merge ();
1804 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1805 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1806 Returns the sorted list. LIST is modified by side effects.
1807 PREDICATE is called with two elements of LIST, and should return t
1808 if the first element is "less" than the second. */)
1810 Lisp_Object list
, predicate
;
1812 Lisp_Object front
, back
;
1813 register Lisp_Object len
, tem
;
1814 struct gcpro gcpro1
, gcpro2
;
1815 register int length
;
1818 len
= Flength (list
);
1819 length
= XINT (len
);
1823 XSETINT (len
, (length
/ 2) - 1);
1824 tem
= Fnthcdr (len
, list
);
1826 Fsetcdr (tem
, Qnil
);
1828 GCPRO2 (front
, back
);
1829 front
= Fsort (front
, predicate
);
1830 back
= Fsort (back
, predicate
);
1832 return merge (front
, back
, predicate
);
1836 merge (org_l1
, org_l2
, pred
)
1837 Lisp_Object org_l1
, org_l2
;
1841 register Lisp_Object tail
;
1843 register Lisp_Object l1
, l2
;
1844 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1851 /* It is sufficient to protect org_l1 and org_l2.
1852 When l1 and l2 are updated, we copy the new values
1853 back into the org_ vars. */
1854 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1874 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1890 Fsetcdr (tail
, tem
);
1896 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1897 doc
: /* Extract a value from a property list.
1898 PLIST is a property list, which is a list of the form
1899 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1900 corresponding to the given PROP, or nil if PROP is not
1901 one of the properties on the list. */)
1909 CONSP (tail
) && CONSP (XCDR (tail
));
1910 tail
= XCDR (XCDR (tail
)))
1912 if (EQ (prop
, XCAR (tail
)))
1913 return XCAR (XCDR (tail
));
1915 /* This function can be called asynchronously
1916 (setup_coding_system). Don't QUIT in that case. */
1917 if (!interrupt_input_blocked
)
1922 wrong_type_argument (Qlistp
, prop
);
1927 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1928 doc
: /* Return the value of SYMBOL's PROPNAME property.
1929 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1931 Lisp_Object symbol
, propname
;
1933 CHECK_SYMBOL (symbol
);
1934 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1937 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1938 doc
: /* Change value in PLIST of PROP to VAL.
1939 PLIST is a property list, which is a list of the form
1940 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1941 If PROP is already a property on the list, its value is set to VAL,
1942 otherwise the new PROP VAL pair is added. The new plist is returned;
1943 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1944 The PLIST is modified by side effects. */)
1947 register Lisp_Object prop
;
1950 register Lisp_Object tail
, prev
;
1951 Lisp_Object newcell
;
1953 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1954 tail
= XCDR (XCDR (tail
)))
1956 if (EQ (prop
, XCAR (tail
)))
1958 Fsetcar (XCDR (tail
), val
);
1965 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1969 Fsetcdr (XCDR (prev
), newcell
);
1973 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1974 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1975 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1976 (symbol
, propname
, value
)
1977 Lisp_Object symbol
, propname
, value
;
1979 CHECK_SYMBOL (symbol
);
1980 XSYMBOL (symbol
)->plist
1981 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1985 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1986 doc
: /* Extract a value from a property list, comparing with `equal'.
1987 PLIST is a property list, which is a list of the form
1988 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1989 corresponding to the given PROP, or nil if PROP is not
1990 one of the properties on the list. */)
1998 CONSP (tail
) && CONSP (XCDR (tail
));
1999 tail
= XCDR (XCDR (tail
)))
2001 if (! NILP (Fequal (prop
, XCAR (tail
))))
2002 return XCAR (XCDR (tail
));
2008 wrong_type_argument (Qlistp
, prop
);
2013 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2014 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2015 PLIST is a property list, which is a list of the form
2016 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2017 If PROP is already a property on the list, its value is set to VAL,
2018 otherwise the new PROP VAL pair is added. The new plist is returned;
2019 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2020 The PLIST is modified by side effects. */)
2023 register Lisp_Object prop
;
2026 register Lisp_Object tail
, prev
;
2027 Lisp_Object newcell
;
2029 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2030 tail
= XCDR (XCDR (tail
)))
2032 if (! NILP (Fequal (prop
, XCAR (tail
))))
2034 Fsetcar (XCDR (tail
), val
);
2041 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2045 Fsetcdr (XCDR (prev
), newcell
);
2049 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2050 doc
: /* Return t if the two args are the same Lisp object.
2051 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2053 Lisp_Object obj1
, obj2
;
2056 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2058 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2061 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2062 doc
: /* Return t if two Lisp objects have similar structure and contents.
2063 They must have the same data type.
2064 Conses are compared by comparing the cars and the cdrs.
2065 Vectors and strings are compared element by element.
2066 Numbers are compared by value, but integers cannot equal floats.
2067 (Use `=' if you want integers and floats to be able to be equal.)
2068 Symbols must match exactly. */)
2070 register Lisp_Object o1
, o2
;
2072 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2075 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2076 doc
: /* Return t if two Lisp objects have similar structure and contents.
2077 This is like `equal' except that it compares the text properties
2078 of strings. (`equal' ignores text properties.) */)
2080 register Lisp_Object o1
, o2
;
2082 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2085 /* DEPTH is current depth of recursion. Signal an error if it
2087 PROPS, if non-nil, means compare string text properties too. */
2090 internal_equal (o1
, o2
, depth
, props
)
2091 register Lisp_Object o1
, o2
;
2095 error ("Stack overflow in equal");
2101 if (XTYPE (o1
) != XTYPE (o2
))
2110 d1
= extract_float (o1
);
2111 d2
= extract_float (o2
);
2112 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2113 though they are not =. */
2114 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2118 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2125 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2129 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2131 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2134 o1
= XOVERLAY (o1
)->plist
;
2135 o2
= XOVERLAY (o2
)->plist
;
2140 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2141 && (XMARKER (o1
)->buffer
== 0
2142 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2146 case Lisp_Vectorlike
:
2149 EMACS_INT size
= XVECTOR (o1
)->size
;
2150 /* Pseudovectors have the type encoded in the size field, so this test
2151 actually checks that the objects have the same type as well as the
2153 if (XVECTOR (o2
)->size
!= size
)
2155 /* Boolvectors are compared much like strings. */
2156 if (BOOL_VECTOR_P (o1
))
2159 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2160 / BOOL_VECTOR_BITS_PER_CHAR
);
2162 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2164 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2169 if (WINDOW_CONFIGURATIONP (o1
))
2170 return compare_window_configurations (o1
, o2
, 0);
2172 /* Aside from them, only true vectors, char-tables, and compiled
2173 functions are sensible to compare, so eliminate the others now. */
2174 if (size
& PSEUDOVECTOR_FLAG
)
2176 if (!(size
& (PVEC_COMPILED
2177 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
)))
2179 size
&= PSEUDOVECTOR_SIZE_MASK
;
2181 for (i
= 0; i
< size
; i
++)
2184 v1
= XVECTOR (o1
)->contents
[i
];
2185 v2
= XVECTOR (o2
)->contents
[i
];
2186 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2194 if (SCHARS (o1
) != SCHARS (o2
))
2196 if (SBYTES (o1
) != SBYTES (o2
))
2198 if (bcmp (SDATA (o1
), SDATA (o2
),
2201 if (props
&& !compare_string_intervals (o1
, o2
))
2207 case Lisp_Type_Limit
:
2214 extern Lisp_Object
Fmake_char_internal ();
2216 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2217 doc
: /* Store each element of ARRAY with ITEM.
2218 ARRAY is a vector, string, char-table, or bool-vector. */)
2220 Lisp_Object array
, item
;
2222 register int size
, index
, charval
;
2224 if (VECTORP (array
))
2226 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2227 size
= XVECTOR (array
)->size
;
2228 for (index
= 0; index
< size
; index
++)
2231 else if (CHAR_TABLE_P (array
))
2235 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2236 XCHAR_TABLE (array
)->contents
[i
] = item
;
2237 XCHAR_TABLE (array
)->defalt
= item
;
2239 else if (STRINGP (array
))
2241 register unsigned char *p
= SDATA (array
);
2242 CHECK_NUMBER (item
);
2243 charval
= XINT (item
);
2244 size
= SCHARS (array
);
2245 if (STRING_MULTIBYTE (array
))
2247 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2248 int len
= CHAR_STRING (charval
, str
);
2249 int size_byte
= SBYTES (array
);
2250 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2253 if (size
!= size_byte
)
2256 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2257 if (len
!= this_len
)
2258 error ("Attempt to change byte length of a string");
2261 for (i
= 0; i
< size_byte
; i
++)
2262 *p
++ = str
[i
% len
];
2265 for (index
= 0; index
< size
; index
++)
2268 else if (BOOL_VECTOR_P (array
))
2270 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2272 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2273 / BOOL_VECTOR_BITS_PER_CHAR
);
2275 charval
= (! NILP (item
) ? -1 : 0);
2276 for (index
= 0; index
< size_in_chars
- 1; index
++)
2278 if (index
< size_in_chars
)
2280 /* Mask out bits beyond the vector size. */
2281 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2282 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2288 array
= wrong_type_argument (Qarrayp
, array
);
2294 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2296 doc
: /* Clear the contents of STRING.
2297 This makes STRING unibyte and may change its length. */)
2302 CHECK_STRING (string
);
2303 len
= SBYTES (string
);
2304 bzero (SDATA (string
), len
);
2305 STRING_SET_CHARS (string
, len
);
2306 STRING_SET_UNIBYTE (string
);
2316 Lisp_Object args
[2];
2319 return Fnconc (2, args
);
2321 return Fnconc (2, &s1
);
2322 #endif /* NO_ARG_ARRAY */
2325 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2326 doc
: /* Concatenate any number of lists by altering them.
2327 Only the last argument is not altered, and need not be a list.
2328 usage: (nconc &rest LISTS) */)
2333 register int argnum
;
2334 register Lisp_Object tail
, tem
, val
;
2338 for (argnum
= 0; argnum
< nargs
; argnum
++)
2341 if (NILP (tem
)) continue;
2346 if (argnum
+ 1 == nargs
) break;
2349 tem
= wrong_type_argument (Qlistp
, tem
);
2358 tem
= args
[argnum
+ 1];
2359 Fsetcdr (tail
, tem
);
2361 args
[argnum
+ 1] = tail
;
2367 /* This is the guts of all mapping functions.
2368 Apply FN to each element of SEQ, one by one,
2369 storing the results into elements of VALS, a C vector of Lisp_Objects.
2370 LENI is the length of VALS, which should also be the length of SEQ. */
2373 mapcar1 (leni
, vals
, fn
, seq
)
2376 Lisp_Object fn
, seq
;
2378 register Lisp_Object tail
;
2381 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2385 /* Don't let vals contain any garbage when GC happens. */
2386 for (i
= 0; i
< leni
; i
++)
2389 GCPRO3 (dummy
, fn
, seq
);
2391 gcpro1
.nvars
= leni
;
2395 /* We need not explicitly protect `tail' because it is used only on lists, and
2396 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2400 for (i
= 0; i
< leni
; i
++)
2402 dummy
= XVECTOR (seq
)->contents
[i
];
2403 dummy
= call1 (fn
, dummy
);
2408 else if (BOOL_VECTOR_P (seq
))
2410 for (i
= 0; i
< leni
; i
++)
2413 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2414 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2419 dummy
= call1 (fn
, dummy
);
2424 else if (STRINGP (seq
))
2428 for (i
= 0, i_byte
= 0; i
< leni
;)
2433 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2434 XSETFASTINT (dummy
, c
);
2435 dummy
= call1 (fn
, dummy
);
2437 vals
[i_before
] = dummy
;
2440 else /* Must be a list, since Flength did not get an error */
2443 for (i
= 0; i
< leni
; i
++)
2445 dummy
= call1 (fn
, Fcar (tail
));
2455 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2456 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2457 In between each pair of results, stick in SEPARATOR. Thus, " " as
2458 SEPARATOR results in spaces between the values returned by FUNCTION.
2459 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2460 (function
, sequence
, separator
)
2461 Lisp_Object function
, sequence
, separator
;
2466 register Lisp_Object
*args
;
2468 struct gcpro gcpro1
;
2472 len
= Flength (sequence
);
2473 if (CHAR_TABLE_P (sequence
))
2474 wrong_type_argument (Qlistp
, sequence
);
2476 nargs
= leni
+ leni
- 1;
2477 if (nargs
< 0) return build_string ("");
2479 SAFE_ALLOCA_LISP (args
, nargs
);
2482 mapcar1 (leni
, args
, function
, sequence
);
2485 for (i
= leni
- 1; i
>= 0; i
--)
2486 args
[i
+ i
] = args
[i
];
2488 for (i
= 1; i
< nargs
; i
+= 2)
2489 args
[i
] = separator
;
2491 ret
= Fconcat (nargs
, args
);
2492 SAFE_FREE_LISP (nargs
);
2497 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2498 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2499 The result is a list just as long as SEQUENCE.
2500 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2501 (function
, sequence
)
2502 Lisp_Object function
, sequence
;
2504 register Lisp_Object len
;
2506 register Lisp_Object
*args
;
2510 len
= Flength (sequence
);
2511 if (CHAR_TABLE_P (sequence
))
2512 wrong_type_argument (Qlistp
, sequence
);
2513 leni
= XFASTINT (len
);
2515 SAFE_ALLOCA_LISP (args
, leni
);
2517 mapcar1 (leni
, args
, function
, sequence
);
2519 ret
= Flist (leni
, args
);
2520 SAFE_FREE_LISP (leni
);
2525 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2526 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2527 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2528 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2529 (function
, sequence
)
2530 Lisp_Object function
, sequence
;
2534 leni
= XFASTINT (Flength (sequence
));
2535 if (CHAR_TABLE_P (sequence
))
2536 wrong_type_argument (Qlistp
, sequence
);
2537 mapcar1 (leni
, 0, function
, sequence
);
2542 /* Anything that calls this function must protect from GC! */
2544 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2545 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2546 Takes one argument, which is the string to display to ask the question.
2547 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2548 No confirmation of the answer is requested; a single character is enough.
2549 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2550 the bindings in `query-replace-map'; see the documentation of that variable
2551 for more information. In this case, the useful bindings are `act', `skip',
2552 `recenter', and `quit'.\)
2554 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2555 is nil and `use-dialog-box' is non-nil. */)
2559 register Lisp_Object obj
, key
, def
, map
;
2560 register int answer
;
2561 Lisp_Object xprompt
;
2562 Lisp_Object args
[2];
2563 struct gcpro gcpro1
, gcpro2
;
2564 int count
= SPECPDL_INDEX ();
2566 specbind (Qcursor_in_echo_area
, Qt
);
2568 map
= Fsymbol_value (intern ("query-replace-map"));
2570 CHECK_STRING (prompt
);
2572 GCPRO2 (prompt
, xprompt
);
2574 #ifdef HAVE_X_WINDOWS
2575 if (display_hourglass_p
)
2576 cancel_hourglass ();
2583 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2587 Lisp_Object pane
, menu
;
2588 redisplay_preserve_echo_area (3);
2589 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2590 Fcons (Fcons (build_string ("No"), Qnil
),
2592 menu
= Fcons (prompt
, pane
);
2593 obj
= Fx_popup_dialog (Qt
, menu
);
2594 answer
= !NILP (obj
);
2597 #endif /* HAVE_MENUS */
2598 cursor_in_echo_area
= 1;
2599 choose_minibuf_frame ();
2602 Lisp_Object pargs
[3];
2604 /* Colorize prompt according to `minibuffer-prompt' face. */
2605 pargs
[0] = build_string ("%s(y or n) ");
2606 pargs
[1] = intern ("face");
2607 pargs
[2] = intern ("minibuffer-prompt");
2608 args
[0] = Fpropertize (3, pargs
);
2613 if (minibuffer_auto_raise
)
2615 Lisp_Object mini_frame
;
2617 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2619 Fraise_frame (mini_frame
);
2622 obj
= read_filtered_event (1, 0, 0, 0);
2623 cursor_in_echo_area
= 0;
2624 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2627 key
= Fmake_vector (make_number (1), obj
);
2628 def
= Flookup_key (map
, key
, Qt
);
2630 if (EQ (def
, intern ("skip")))
2635 else if (EQ (def
, intern ("act")))
2640 else if (EQ (def
, intern ("recenter")))
2646 else if (EQ (def
, intern ("quit")))
2648 /* We want to exit this command for exit-prefix,
2649 and this is the only way to do it. */
2650 else if (EQ (def
, intern ("exit-prefix")))
2655 /* If we don't clear this, then the next call to read_char will
2656 return quit_char again, and we'll enter an infinite loop. */
2661 if (EQ (xprompt
, prompt
))
2663 args
[0] = build_string ("Please answer y or n. ");
2665 xprompt
= Fconcat (2, args
);
2670 if (! noninteractive
)
2672 cursor_in_echo_area
= -1;
2673 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2677 unbind_to (count
, Qnil
);
2678 return answer
? Qt
: Qnil
;
2681 /* This is how C code calls `yes-or-no-p' and allows the user
2684 Anything that calls this function must protect from GC! */
2687 do_yes_or_no_p (prompt
)
2690 return call1 (intern ("yes-or-no-p"), prompt
);
2693 /* Anything that calls this function must protect from GC! */
2695 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2696 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2697 Takes one argument, which is the string to display to ask the question.
2698 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2699 The user must confirm the answer with RET,
2700 and can edit it until it has been confirmed.
2702 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2703 is nil, and `use-dialog-box' is non-nil. */)
2707 register Lisp_Object ans
;
2708 Lisp_Object args
[2];
2709 struct gcpro gcpro1
;
2711 CHECK_STRING (prompt
);
2714 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2718 Lisp_Object pane
, menu
, obj
;
2719 redisplay_preserve_echo_area (4);
2720 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2721 Fcons (Fcons (build_string ("No"), Qnil
),
2724 menu
= Fcons (prompt
, pane
);
2725 obj
= Fx_popup_dialog (Qt
, menu
);
2729 #endif /* HAVE_MENUS */
2732 args
[1] = build_string ("(yes or no) ");
2733 prompt
= Fconcat (2, args
);
2739 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2740 Qyes_or_no_p_history
, Qnil
,
2742 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2747 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2755 message ("Please answer yes or no.");
2756 Fsleep_for (make_number (2), Qnil
);
2760 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2761 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2763 Each of the three load averages is multiplied by 100, then converted
2766 When USE-FLOATS is non-nil, floats will be used instead of integers.
2767 These floats are not multiplied by 100.
2769 If the 5-minute or 15-minute load averages are not available, return a
2770 shortened list, containing only those averages which are available.
2772 An error is thrown if the load average can't be obtained. In some
2773 cases making it work would require Emacs being installed setuid or
2774 setgid so that it can read kernel information, and that usually isn't
2777 Lisp_Object use_floats
;
2780 int loads
= getloadavg (load_ave
, 3);
2781 Lisp_Object ret
= Qnil
;
2784 error ("load-average not implemented for this operating system");
2788 Lisp_Object load
= (NILP (use_floats
) ?
2789 make_number ((int) (100.0 * load_ave
[loads
]))
2790 : make_float (load_ave
[loads
]));
2791 ret
= Fcons (load
, ret
);
2797 Lisp_Object Vfeatures
, Qsubfeatures
;
2798 extern Lisp_Object Vafter_load_alist
;
2800 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2801 doc
: /* Returns t if FEATURE is present in this Emacs.
2803 Use this to conditionalize execution of lisp code based on the
2804 presence or absence of emacs or environment extensions.
2805 Use `provide' to declare that a feature is available. This function
2806 looks at the value of the variable `features'. The optional argument
2807 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2808 (feature
, subfeature
)
2809 Lisp_Object feature
, subfeature
;
2811 register Lisp_Object tem
;
2812 CHECK_SYMBOL (feature
);
2813 tem
= Fmemq (feature
, Vfeatures
);
2814 if (!NILP (tem
) && !NILP (subfeature
))
2815 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2816 return (NILP (tem
)) ? Qnil
: Qt
;
2819 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2820 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2821 The optional argument SUBFEATURES should be a list of symbols listing
2822 particular subfeatures supported in this version of FEATURE. */)
2823 (feature
, subfeatures
)
2824 Lisp_Object feature
, subfeatures
;
2826 register Lisp_Object tem
;
2827 CHECK_SYMBOL (feature
);
2828 CHECK_LIST (subfeatures
);
2829 if (!NILP (Vautoload_queue
))
2830 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2831 tem
= Fmemq (feature
, Vfeatures
);
2833 Vfeatures
= Fcons (feature
, Vfeatures
);
2834 if (!NILP (subfeatures
))
2835 Fput (feature
, Qsubfeatures
, subfeatures
);
2836 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2838 /* Run any load-hooks for this file. */
2839 tem
= Fassq (feature
, Vafter_load_alist
);
2841 Fprogn (XCDR (tem
));
2846 /* `require' and its subroutines. */
2848 /* List of features currently being require'd, innermost first. */
2850 Lisp_Object require_nesting_list
;
2853 require_unwind (old_value
)
2854 Lisp_Object old_value
;
2856 return require_nesting_list
= old_value
;
2859 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2860 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2861 If FEATURE is not a member of the list `features', then the feature
2862 is not loaded; so load the file FILENAME.
2863 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2864 and `load' will try to load this name appended with the suffix `.elc' or
2865 `.el', in that order. The name without appended suffix will not be used.
2866 If the optional third argument NOERROR is non-nil,
2867 then return nil if the file is not found instead of signaling an error.
2868 Normally the return value is FEATURE.
2869 The normal messages at start and end of loading FILENAME are suppressed. */)
2870 (feature
, filename
, noerror
)
2871 Lisp_Object feature
, filename
, noerror
;
2873 register Lisp_Object tem
;
2874 struct gcpro gcpro1
, gcpro2
;
2876 CHECK_SYMBOL (feature
);
2878 tem
= Fmemq (feature
, Vfeatures
);
2882 int count
= SPECPDL_INDEX ();
2885 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2887 /* This is to make sure that loadup.el gives a clear picture
2888 of what files are preloaded and when. */
2889 if (! NILP (Vpurify_flag
))
2890 error ("(require %s) while preparing to dump",
2891 SDATA (SYMBOL_NAME (feature
)));
2893 /* A certain amount of recursive `require' is legitimate,
2894 but if we require the same feature recursively 3 times,
2896 tem
= require_nesting_list
;
2897 while (! NILP (tem
))
2899 if (! NILP (Fequal (feature
, XCAR (tem
))))
2904 error ("Recursive `require' for feature `%s'",
2905 SDATA (SYMBOL_NAME (feature
)));
2907 /* Update the list for any nested `require's that occur. */
2908 record_unwind_protect (require_unwind
, require_nesting_list
);
2909 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2911 /* Value saved here is to be restored into Vautoload_queue */
2912 record_unwind_protect (un_autoload
, Vautoload_queue
);
2913 Vautoload_queue
= Qt
;
2915 /* Load the file. */
2916 GCPRO2 (feature
, filename
);
2917 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2918 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2921 /* If load failed entirely, return nil. */
2923 return unbind_to (count
, Qnil
);
2925 tem
= Fmemq (feature
, Vfeatures
);
2927 error ("Required feature `%s' was not provided",
2928 SDATA (SYMBOL_NAME (feature
)));
2930 /* Once loading finishes, don't undo it. */
2931 Vautoload_queue
= Qt
;
2932 feature
= unbind_to (count
, feature
);
2938 /* Primitives for work of the "widget" library.
2939 In an ideal world, this section would not have been necessary.
2940 However, lisp function calls being as slow as they are, it turns
2941 out that some functions in the widget library (wid-edit.el) are the
2942 bottleneck of Widget operation. Here is their translation to C,
2943 for the sole reason of efficiency. */
2945 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2946 doc
: /* Return non-nil if PLIST has the property PROP.
2947 PLIST is a property list, which is a list of the form
2948 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2949 Unlike `plist-get', this allows you to distinguish between a missing
2950 property and a property with the value nil.
2951 The value is actually the tail of PLIST whose car is PROP. */)
2953 Lisp_Object plist
, prop
;
2955 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2958 plist
= XCDR (plist
);
2959 plist
= CDR (plist
);
2964 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2965 doc
: /* In WIDGET, set PROPERTY to VALUE.
2966 The value can later be retrieved with `widget-get'. */)
2967 (widget
, property
, value
)
2968 Lisp_Object widget
, property
, value
;
2970 CHECK_CONS (widget
);
2971 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2975 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2976 doc
: /* In WIDGET, get the value of PROPERTY.
2977 The value could either be specified when the widget was created, or
2978 later with `widget-put'. */)
2980 Lisp_Object widget
, property
;
2988 CHECK_CONS (widget
);
2989 tmp
= Fplist_member (XCDR (widget
), property
);
2995 tmp
= XCAR (widget
);
2998 widget
= Fget (tmp
, Qwidget_type
);
3002 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3003 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3004 ARGS are passed as extra arguments to the function.
3005 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3010 /* This function can GC. */
3011 Lisp_Object newargs
[3];
3012 struct gcpro gcpro1
, gcpro2
;
3015 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3016 newargs
[1] = args
[0];
3017 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3018 GCPRO2 (newargs
[0], newargs
[2]);
3019 result
= Fapply (3, newargs
);
3024 #ifdef HAVE_LANGINFO_CODESET
3025 #include <langinfo.h>
3028 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3029 doc
: /* Access locale data ITEM for the current C locale, if available.
3030 ITEM should be one of the following:
3032 `codeset', returning the character set as a string (locale item CODESET);
3034 `days', returning a 7-element vector of day names (locale items DAY_n);
3036 `months', returning a 12-element vector of month names (locale items MON_n);
3038 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3039 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3041 If the system can't provide such information through a call to
3042 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3044 See also Info node `(libc)Locales'.
3046 The data read from the system are decoded using `locale-coding-system'. */)
3051 #ifdef HAVE_LANGINFO_CODESET
3053 if (EQ (item
, Qcodeset
))
3055 str
= nl_langinfo (CODESET
);
3056 return build_string (str
);
3059 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3061 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3062 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3064 synchronize_system_time_locale ();
3065 for (i
= 0; i
< 7; i
++)
3067 str
= nl_langinfo (days
[i
]);
3068 val
= make_unibyte_string (str
, strlen (str
));
3069 /* Fixme: Is this coding system necessarily right, even if
3070 it is consistent with CODESET? If not, what to do? */
3071 Faset (v
, make_number (i
),
3072 code_convert_string_norecord (val
, Vlocale_coding_system
,
3079 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3081 struct Lisp_Vector
*p
= allocate_vector (12);
3082 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3083 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3085 synchronize_system_time_locale ();
3086 for (i
= 0; i
< 12; i
++)
3088 str
= nl_langinfo (months
[i
]);
3089 val
= make_unibyte_string (str
, strlen (str
));
3091 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3093 XSETVECTOR (val
, p
);
3097 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3098 but is in the locale files. This could be used by ps-print. */
3100 else if (EQ (item
, Qpaper
))
3102 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3103 make_number (nl_langinfo (PAPER_HEIGHT
)));
3105 #endif /* PAPER_WIDTH */
3106 #endif /* HAVE_LANGINFO_CODESET*/
3110 /* base64 encode/decode functions (RFC 2045).
3111 Based on code from GNU recode. */
3113 #define MIME_LINE_LENGTH 76
3115 #define IS_ASCII(Character) \
3117 #define IS_BASE64(Character) \
3118 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3119 #define IS_BASE64_IGNORABLE(Character) \
3120 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3121 || (Character) == '\f' || (Character) == '\r')
3123 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3124 character or return retval if there are no characters left to
3126 #define READ_QUADRUPLET_BYTE(retval) \
3131 if (nchars_return) \
3132 *nchars_return = nchars; \
3137 while (IS_BASE64_IGNORABLE (c))
3139 /* Table of characters coding the 64 values. */
3140 static char base64_value_to_char
[64] =
3142 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3143 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3144 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3145 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3146 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3147 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3148 '8', '9', '+', '/' /* 60-63 */
3151 /* Table of base64 values for first 128 characters. */
3152 static short base64_char_to_value
[128] =
3154 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3155 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3156 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3157 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3158 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3159 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3160 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3161 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3162 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3163 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3164 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3165 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3166 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3169 /* The following diagram shows the logical steps by which three octets
3170 get transformed into four base64 characters.
3172 .--------. .--------. .--------.
3173 |aaaaaabb| |bbbbcccc| |ccdddddd|
3174 `--------' `--------' `--------'
3176 .--------+--------+--------+--------.
3177 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3178 `--------+--------+--------+--------'
3180 .--------+--------+--------+--------.
3181 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3182 `--------+--------+--------+--------'
3184 The octets are divided into 6 bit chunks, which are then encoded into
3185 base64 characters. */
3188 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3189 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3191 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3193 doc
: /* Base64-encode the region between BEG and END.
3194 Return the length of the encoded text.
3195 Optional third argument NO-LINE-BREAK means do not break long lines
3196 into shorter lines. */)
3197 (beg
, end
, no_line_break
)
3198 Lisp_Object beg
, end
, no_line_break
;
3201 int allength
, length
;
3202 int ibeg
, iend
, encoded_length
;
3206 validate_region (&beg
, &end
);
3208 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3209 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3210 move_gap_both (XFASTINT (beg
), ibeg
);
3212 /* We need to allocate enough room for encoding the text.
3213 We need 33 1/3% more space, plus a newline every 76
3214 characters, and then we round up. */
3215 length
= iend
- ibeg
;
3216 allength
= length
+ length
/3 + 1;
3217 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3219 SAFE_ALLOCA (encoded
, char *, allength
);
3220 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3221 NILP (no_line_break
),
3222 !NILP (current_buffer
->enable_multibyte_characters
));
3223 if (encoded_length
> allength
)
3226 if (encoded_length
< 0)
3228 /* The encoding wasn't possible. */
3229 SAFE_FREE (allength
);
3230 error ("Multibyte character in data for base64 encoding");
3233 /* Now we have encoded the region, so we insert the new contents
3234 and delete the old. (Insert first in order to preserve markers.) */
3235 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3236 insert (encoded
, encoded_length
);
3237 SAFE_FREE (allength
);
3238 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3240 /* If point was outside of the region, restore it exactly; else just
3241 move to the beginning of the region. */
3242 if (old_pos
>= XFASTINT (end
))
3243 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3244 else if (old_pos
> XFASTINT (beg
))
3245 old_pos
= XFASTINT (beg
);
3248 /* We return the length of the encoded text. */
3249 return make_number (encoded_length
);
3252 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3254 doc
: /* Base64-encode STRING and return the result.
3255 Optional second argument NO-LINE-BREAK means do not break long lines
3256 into shorter lines. */)
3257 (string
, no_line_break
)
3258 Lisp_Object string
, no_line_break
;
3260 int allength
, length
, encoded_length
;
3262 Lisp_Object encoded_string
;
3265 CHECK_STRING (string
);
3267 /* We need to allocate enough room for encoding the text.
3268 We need 33 1/3% more space, plus a newline every 76
3269 characters, and then we round up. */
3270 length
= SBYTES (string
);
3271 allength
= length
+ length
/3 + 1;
3272 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3274 /* We need to allocate enough room for decoding the text. */
3275 SAFE_ALLOCA (encoded
, char *, allength
);
3277 encoded_length
= base64_encode_1 (SDATA (string
),
3278 encoded
, length
, NILP (no_line_break
),
3279 STRING_MULTIBYTE (string
));
3280 if (encoded_length
> allength
)
3283 if (encoded_length
< 0)
3285 /* The encoding wasn't possible. */
3286 SAFE_FREE (allength
);
3287 error ("Multibyte character in data for base64 encoding");
3290 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3291 SAFE_FREE (allength
);
3293 return encoded_string
;
3297 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3304 int counter
= 0, i
= 0;
3314 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3315 if (CHAR_BYTE8_P (c
))
3316 c
= CHAR_TO_BYTE8 (c
);
3324 /* Wrap line every 76 characters. */
3328 if (counter
< MIME_LINE_LENGTH
/ 4)
3337 /* Process first byte of a triplet. */
3339 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3340 value
= (0x03 & c
) << 4;
3342 /* Process second byte of a triplet. */
3346 *e
++ = base64_value_to_char
[value
];
3354 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3355 if (CHAR_BYTE8_P (c
))
3356 c
= CHAR_TO_BYTE8 (c
);
3364 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3365 value
= (0x0f & c
) << 2;
3367 /* Process third byte of a triplet. */
3371 *e
++ = base64_value_to_char
[value
];
3378 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3379 if (CHAR_BYTE8_P (c
))
3380 c
= CHAR_TO_BYTE8 (c
);
3388 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3389 *e
++ = base64_value_to_char
[0x3f & c
];
3396 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3398 doc
: /* Base64-decode the region between BEG and END.
3399 Return the length of the decoded text.
3400 If the region can't be decoded, signal an error and don't modify the buffer. */)
3402 Lisp_Object beg
, end
;
3404 int ibeg
, iend
, length
, allength
;
3409 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3412 validate_region (&beg
, &end
);
3414 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3415 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3417 length
= iend
- ibeg
;
3419 /* We need to allocate enough room for decoding the text. If we are
3420 working on a multibyte buffer, each decoded code may occupy at
3422 allength
= multibyte
? length
* 2 : length
;
3423 SAFE_ALLOCA (decoded
, char *, allength
);
3425 move_gap_both (XFASTINT (beg
), ibeg
);
3426 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3427 multibyte
, &inserted_chars
);
3428 if (decoded_length
> allength
)
3431 if (decoded_length
< 0)
3433 /* The decoding wasn't possible. */
3434 SAFE_FREE (allength
);
3435 error ("Invalid base64 data");
3438 /* Now we have decoded the region, so we insert the new contents
3439 and delete the old. (Insert first in order to preserve markers.) */
3440 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3441 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3442 SAFE_FREE (allength
);
3444 /* Delete the original text. */
3445 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3446 iend
+ decoded_length
, 1);
3448 /* If point was outside of the region, restore it exactly; else just
3449 move to the beginning of the region. */
3450 if (old_pos
>= XFASTINT (end
))
3451 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3452 else if (old_pos
> XFASTINT (beg
))
3453 old_pos
= XFASTINT (beg
);
3454 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3456 return make_number (inserted_chars
);
3459 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3461 doc
: /* Base64-decode STRING and return the result. */)
3466 int length
, decoded_length
;
3467 Lisp_Object decoded_string
;
3470 CHECK_STRING (string
);
3472 length
= SBYTES (string
);
3473 /* We need to allocate enough room for decoding the text. */
3474 SAFE_ALLOCA (decoded
, char *, length
);
3476 /* The decoded result should be unibyte. */
3477 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3479 if (decoded_length
> length
)
3481 else if (decoded_length
>= 0)
3482 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3484 decoded_string
= Qnil
;
3487 if (!STRINGP (decoded_string
))
3488 error ("Invalid base64 data");
3490 return decoded_string
;
3493 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3494 MULTIBYTE is nonzero, the decoded result should be in multibyte
3495 form. If NCHARS_RETRUN is not NULL, store the number of produced
3496 characters in *NCHARS_RETURN. */
3499 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3509 unsigned long value
;
3514 /* Process first byte of a quadruplet. */
3516 READ_QUADRUPLET_BYTE (e
-to
);
3520 value
= base64_char_to_value
[c
] << 18;
3522 /* Process second byte of a quadruplet. */
3524 READ_QUADRUPLET_BYTE (-1);
3528 value
|= base64_char_to_value
[c
] << 12;
3530 c
= (unsigned char) (value
>> 16);
3531 if (multibyte
&& c
>= 128)
3532 e
+= BYTE8_STRING (c
, e
);
3537 /* Process third byte of a quadruplet. */
3539 READ_QUADRUPLET_BYTE (-1);
3543 READ_QUADRUPLET_BYTE (-1);
3552 value
|= base64_char_to_value
[c
] << 6;
3554 c
= (unsigned char) (0xff & value
>> 8);
3555 if (multibyte
&& c
>= 128)
3556 e
+= BYTE8_STRING (c
, e
);
3561 /* Process fourth byte of a quadruplet. */
3563 READ_QUADRUPLET_BYTE (-1);
3570 value
|= base64_char_to_value
[c
];
3572 c
= (unsigned char) (0xff & value
);
3573 if (multibyte
&& c
>= 128)
3574 e
+= BYTE8_STRING (c
, e
);
3583 /***********************************************************************
3585 ***** Hash Tables *****
3587 ***********************************************************************/
3589 /* Implemented by gerd@gnu.org. This hash table implementation was
3590 inspired by CMUCL hash tables. */
3594 1. For small tables, association lists are probably faster than
3595 hash tables because they have lower overhead.
3597 For uses of hash tables where the O(1) behavior of table
3598 operations is not a requirement, it might therefore be a good idea
3599 not to hash. Instead, we could just do a linear search in the
3600 key_and_value vector of the hash table. This could be done
3601 if a `:linear-search t' argument is given to make-hash-table. */
3604 /* The list of all weak hash tables. Don't staticpro this one. */
3606 Lisp_Object Vweak_hash_tables
;
3608 /* Various symbols. */
3610 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3611 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3612 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3614 /* Function prototypes. */
3616 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3617 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3618 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3619 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3620 Lisp_Object
, unsigned));
3621 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3622 Lisp_Object
, unsigned));
3623 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3624 unsigned, Lisp_Object
, unsigned));
3625 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3626 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3627 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3628 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3630 static unsigned sxhash_string
P_ ((unsigned char *, int));
3631 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3632 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3633 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3634 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3638 /***********************************************************************
3640 ***********************************************************************/
3642 /* If OBJ is a Lisp hash table, return a pointer to its struct
3643 Lisp_Hash_Table. Otherwise, signal an error. */
3645 static struct Lisp_Hash_Table
*
3646 check_hash_table (obj
)
3649 CHECK_HASH_TABLE (obj
);
3650 return XHASH_TABLE (obj
);
3654 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3658 next_almost_prime (n
)
3671 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3672 which USED[I] is non-zero. If found at index I in ARGS, set
3673 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3674 -1. This function is used to extract a keyword/argument pair from
3675 a DEFUN parameter list. */
3678 get_key_arg (key
, nargs
, args
, used
)
3686 for (i
= 0; i
< nargs
- 1; ++i
)
3687 if (!used
[i
] && EQ (args
[i
], key
))
3702 /* Return a Lisp vector which has the same contents as VEC but has
3703 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3704 vector that are not copied from VEC are set to INIT. */
3707 larger_vector (vec
, new_size
, init
)
3712 struct Lisp_Vector
*v
;
3715 xassert (VECTORP (vec
));
3716 old_size
= XVECTOR (vec
)->size
;
3717 xassert (new_size
>= old_size
);
3719 v
= allocate_vector (new_size
);
3720 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3721 old_size
* sizeof *v
->contents
);
3722 for (i
= old_size
; i
< new_size
; ++i
)
3723 v
->contents
[i
] = init
;
3724 XSETVECTOR (vec
, v
);
3729 /***********************************************************************
3731 ***********************************************************************/
3733 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3734 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3735 KEY2 are the same. */
3738 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3739 struct Lisp_Hash_Table
*h
;
3740 Lisp_Object key1
, key2
;
3741 unsigned hash1
, hash2
;
3743 return (FLOATP (key1
)
3745 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3749 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3750 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3751 KEY2 are the same. */
3754 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3755 struct Lisp_Hash_Table
*h
;
3756 Lisp_Object key1
, key2
;
3757 unsigned hash1
, hash2
;
3759 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3763 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3764 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3765 if KEY1 and KEY2 are the same. */
3768 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3769 struct Lisp_Hash_Table
*h
;
3770 Lisp_Object key1
, key2
;
3771 unsigned hash1
, hash2
;
3775 Lisp_Object args
[3];
3777 args
[0] = h
->user_cmp_function
;
3780 return !NILP (Ffuncall (3, args
));
3787 /* Value is a hash code for KEY for use in hash table H which uses
3788 `eq' to compare keys. The hash code returned is guaranteed to fit
3789 in a Lisp integer. */
3793 struct Lisp_Hash_Table
*h
;
3796 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3797 xassert ((hash
& ~INTMASK
) == 0);
3802 /* Value is a hash code for KEY for use in hash table H which uses
3803 `eql' to compare keys. The hash code returned is guaranteed to fit
3804 in a Lisp integer. */
3808 struct Lisp_Hash_Table
*h
;
3813 hash
= sxhash (key
, 0);
3815 hash
= XUINT (key
) ^ XGCTYPE (key
);
3816 xassert ((hash
& ~INTMASK
) == 0);
3821 /* Value is a hash code for KEY for use in hash table H which uses
3822 `equal' to compare keys. The hash code returned is guaranteed to fit
3823 in a Lisp integer. */
3826 hashfn_equal (h
, key
)
3827 struct Lisp_Hash_Table
*h
;
3830 unsigned hash
= sxhash (key
, 0);
3831 xassert ((hash
& ~INTMASK
) == 0);
3836 /* Value is a hash code for KEY for use in hash table H which uses as
3837 user-defined function to compare keys. The hash code returned is
3838 guaranteed to fit in a Lisp integer. */
3841 hashfn_user_defined (h
, key
)
3842 struct Lisp_Hash_Table
*h
;
3845 Lisp_Object args
[2], hash
;
3847 args
[0] = h
->user_hash_function
;
3849 hash
= Ffuncall (2, args
);
3850 if (!INTEGERP (hash
))
3852 list2 (build_string ("Invalid hash code returned from \
3853 user-supplied hash function"),
3855 return XUINT (hash
);
3859 /* Create and initialize a new hash table.
3861 TEST specifies the test the hash table will use to compare keys.
3862 It must be either one of the predefined tests `eq', `eql' or
3863 `equal' or a symbol denoting a user-defined test named TEST with
3864 test and hash functions USER_TEST and USER_HASH.
3866 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3868 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3869 new size when it becomes full is computed by adding REHASH_SIZE to
3870 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3871 table's new size is computed by multiplying its old size with
3874 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3875 be resized when the ratio of (number of entries in the table) /
3876 (table size) is >= REHASH_THRESHOLD.
3878 WEAK specifies the weakness of the table. If non-nil, it must be
3879 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3882 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3883 user_test
, user_hash
)
3884 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3885 Lisp_Object user_test
, user_hash
;
3887 struct Lisp_Hash_Table
*h
;
3889 int index_size
, i
, sz
;
3891 /* Preconditions. */
3892 xassert (SYMBOLP (test
));
3893 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3894 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3895 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3896 xassert (FLOATP (rehash_threshold
)
3897 && XFLOATINT (rehash_threshold
) > 0
3898 && XFLOATINT (rehash_threshold
) <= 1.0);
3900 if (XFASTINT (size
) == 0)
3901 size
= make_number (1);
3903 /* Allocate a table and initialize it. */
3904 h
= allocate_hash_table ();
3906 /* Initialize hash table slots. */
3907 sz
= XFASTINT (size
);
3910 if (EQ (test
, Qeql
))
3912 h
->cmpfn
= cmpfn_eql
;
3913 h
->hashfn
= hashfn_eql
;
3915 else if (EQ (test
, Qeq
))
3918 h
->hashfn
= hashfn_eq
;
3920 else if (EQ (test
, Qequal
))
3922 h
->cmpfn
= cmpfn_equal
;
3923 h
->hashfn
= hashfn_equal
;
3927 h
->user_cmp_function
= user_test
;
3928 h
->user_hash_function
= user_hash
;
3929 h
->cmpfn
= cmpfn_user_defined
;
3930 h
->hashfn
= hashfn_user_defined
;
3934 h
->rehash_threshold
= rehash_threshold
;
3935 h
->rehash_size
= rehash_size
;
3936 h
->count
= make_number (0);
3937 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3938 h
->hash
= Fmake_vector (size
, Qnil
);
3939 h
->next
= Fmake_vector (size
, Qnil
);
3940 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3941 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3942 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3944 /* Set up the free list. */
3945 for (i
= 0; i
< sz
- 1; ++i
)
3946 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3947 h
->next_free
= make_number (0);
3949 XSET_HASH_TABLE (table
, h
);
3950 xassert (HASH_TABLE_P (table
));
3951 xassert (XHASH_TABLE (table
) == h
);
3953 /* Maybe add this hash table to the list of all weak hash tables. */
3955 h
->next_weak
= Qnil
;
3958 h
->next_weak
= Vweak_hash_tables
;
3959 Vweak_hash_tables
= table
;
3966 /* Return a copy of hash table H1. Keys and values are not copied,
3967 only the table itself is. */
3970 copy_hash_table (h1
)
3971 struct Lisp_Hash_Table
*h1
;
3974 struct Lisp_Hash_Table
*h2
;
3975 struct Lisp_Vector
*next
;
3977 h2
= allocate_hash_table ();
3978 next
= h2
->vec_next
;
3979 bcopy (h1
, h2
, sizeof *h2
);
3980 h2
->vec_next
= next
;
3981 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3982 h2
->hash
= Fcopy_sequence (h1
->hash
);
3983 h2
->next
= Fcopy_sequence (h1
->next
);
3984 h2
->index
= Fcopy_sequence (h1
->index
);
3985 XSET_HASH_TABLE (table
, h2
);
3987 /* Maybe add this hash table to the list of all weak hash tables. */
3988 if (!NILP (h2
->weak
))
3990 h2
->next_weak
= Vweak_hash_tables
;
3991 Vweak_hash_tables
= table
;
3998 /* Resize hash table H if it's too full. If H cannot be resized
3999 because it's already too large, throw an error. */
4002 maybe_resize_hash_table (h
)
4003 struct Lisp_Hash_Table
*h
;
4005 if (NILP (h
->next_free
))
4007 int old_size
= HASH_TABLE_SIZE (h
);
4008 int i
, new_size
, index_size
;
4010 if (INTEGERP (h
->rehash_size
))
4011 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4013 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4014 new_size
= max (old_size
+ 1, new_size
);
4015 index_size
= next_almost_prime ((int)
4017 / XFLOATINT (h
->rehash_threshold
)));
4018 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4019 error ("Hash table too large to resize");
4021 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4022 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4023 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4024 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4026 /* Update the free list. Do it so that new entries are added at
4027 the end of the free list. This makes some operations like
4029 for (i
= old_size
; i
< new_size
- 1; ++i
)
4030 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4032 if (!NILP (h
->next_free
))
4034 Lisp_Object last
, next
;
4036 last
= h
->next_free
;
4037 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4041 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4044 XSETFASTINT (h
->next_free
, old_size
);
4047 for (i
= 0; i
< old_size
; ++i
)
4048 if (!NILP (HASH_HASH (h
, i
)))
4050 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4051 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4052 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4053 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4059 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4060 the hash code of KEY. Value is the index of the entry in H
4061 matching KEY, or -1 if not found. */
4064 hash_lookup (h
, key
, hash
)
4065 struct Lisp_Hash_Table
*h
;
4070 int start_of_bucket
;
4073 hash_code
= h
->hashfn (h
, key
);
4077 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4078 idx
= HASH_INDEX (h
, start_of_bucket
);
4080 /* We need not gcpro idx since it's either an integer or nil. */
4083 int i
= XFASTINT (idx
);
4084 if (EQ (key
, HASH_KEY (h
, i
))
4086 && h
->cmpfn (h
, key
, hash_code
,
4087 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4089 idx
= HASH_NEXT (h
, i
);
4092 return NILP (idx
) ? -1 : XFASTINT (idx
);
4096 /* Put an entry into hash table H that associates KEY with VALUE.
4097 HASH is a previously computed hash code of KEY.
4098 Value is the index of the entry in H matching KEY. */
4101 hash_put (h
, key
, value
, hash
)
4102 struct Lisp_Hash_Table
*h
;
4103 Lisp_Object key
, value
;
4106 int start_of_bucket
, i
;
4108 xassert ((hash
& ~INTMASK
) == 0);
4110 /* Increment count after resizing because resizing may fail. */
4111 maybe_resize_hash_table (h
);
4112 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4114 /* Store key/value in the key_and_value vector. */
4115 i
= XFASTINT (h
->next_free
);
4116 h
->next_free
= HASH_NEXT (h
, i
);
4117 HASH_KEY (h
, i
) = key
;
4118 HASH_VALUE (h
, i
) = value
;
4120 /* Remember its hash code. */
4121 HASH_HASH (h
, i
) = make_number (hash
);
4123 /* Add new entry to its collision chain. */
4124 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4125 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4126 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4131 /* Remove the entry matching KEY from hash table H, if there is one. */
4134 hash_remove (h
, key
)
4135 struct Lisp_Hash_Table
*h
;
4139 int start_of_bucket
;
4140 Lisp_Object idx
, prev
;
4142 hash_code
= h
->hashfn (h
, key
);
4143 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4144 idx
= HASH_INDEX (h
, start_of_bucket
);
4147 /* We need not gcpro idx, prev since they're either integers or nil. */
4150 int i
= XFASTINT (idx
);
4152 if (EQ (key
, HASH_KEY (h
, i
))
4154 && h
->cmpfn (h
, key
, hash_code
,
4155 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4157 /* Take entry out of collision chain. */
4159 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4161 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4163 /* Clear slots in key_and_value and add the slots to
4165 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4166 HASH_NEXT (h
, i
) = h
->next_free
;
4167 h
->next_free
= make_number (i
);
4168 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4169 xassert (XINT (h
->count
) >= 0);
4175 idx
= HASH_NEXT (h
, i
);
4181 /* Clear hash table H. */
4185 struct Lisp_Hash_Table
*h
;
4187 if (XFASTINT (h
->count
) > 0)
4189 int i
, size
= HASH_TABLE_SIZE (h
);
4191 for (i
= 0; i
< size
; ++i
)
4193 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4194 HASH_KEY (h
, i
) = Qnil
;
4195 HASH_VALUE (h
, i
) = Qnil
;
4196 HASH_HASH (h
, i
) = Qnil
;
4199 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4200 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4202 h
->next_free
= make_number (0);
4203 h
->count
= make_number (0);
4209 /************************************************************************
4211 ************************************************************************/
4213 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4214 entries from the table that don't survive the current GC.
4215 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4216 non-zero if anything was marked. */
4219 sweep_weak_table (h
, remove_entries_p
)
4220 struct Lisp_Hash_Table
*h
;
4221 int remove_entries_p
;
4223 int bucket
, n
, marked
;
4225 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4228 for (bucket
= 0; bucket
< n
; ++bucket
)
4230 Lisp_Object idx
, next
, prev
;
4232 /* Follow collision chain, removing entries that
4233 don't survive this garbage collection. */
4235 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4237 int i
= XFASTINT (idx
);
4238 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4239 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4242 if (EQ (h
->weak
, Qkey
))
4243 remove_p
= !key_known_to_survive_p
;
4244 else if (EQ (h
->weak
, Qvalue
))
4245 remove_p
= !value_known_to_survive_p
;
4246 else if (EQ (h
->weak
, Qkey_or_value
))
4247 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4248 else if (EQ (h
->weak
, Qkey_and_value
))
4249 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4253 next
= HASH_NEXT (h
, i
);
4255 if (remove_entries_p
)
4259 /* Take out of collision chain. */
4261 HASH_INDEX (h
, bucket
) = next
;
4263 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4265 /* Add to free list. */
4266 HASH_NEXT (h
, i
) = h
->next_free
;
4269 /* Clear key, value, and hash. */
4270 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4271 HASH_HASH (h
, i
) = Qnil
;
4273 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4280 /* Make sure key and value survive. */
4281 if (!key_known_to_survive_p
)
4283 mark_object (HASH_KEY (h
, i
));
4287 if (!value_known_to_survive_p
)
4289 mark_object (HASH_VALUE (h
, i
));
4300 /* Remove elements from weak hash tables that don't survive the
4301 current garbage collection. Remove weak tables that don't survive
4302 from Vweak_hash_tables. Called from gc_sweep. */
4305 sweep_weak_hash_tables ()
4307 Lisp_Object table
, used
, next
;
4308 struct Lisp_Hash_Table
*h
;
4311 /* Mark all keys and values that are in use. Keep on marking until
4312 there is no more change. This is necessary for cases like
4313 value-weak table A containing an entry X -> Y, where Y is used in a
4314 key-weak table B, Z -> Y. If B comes after A in the list of weak
4315 tables, X -> Y might be removed from A, although when looking at B
4316 one finds that it shouldn't. */
4320 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4322 h
= XHASH_TABLE (table
);
4323 if (h
->size
& ARRAY_MARK_FLAG
)
4324 marked
|= sweep_weak_table (h
, 0);
4329 /* Remove tables and entries that aren't used. */
4330 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4332 h
= XHASH_TABLE (table
);
4333 next
= h
->next_weak
;
4335 if (h
->size
& ARRAY_MARK_FLAG
)
4337 /* TABLE is marked as used. Sweep its contents. */
4338 if (XFASTINT (h
->count
) > 0)
4339 sweep_weak_table (h
, 1);
4341 /* Add table to the list of used weak hash tables. */
4342 h
->next_weak
= used
;
4347 Vweak_hash_tables
= used
;
4352 /***********************************************************************
4353 Hash Code Computation
4354 ***********************************************************************/
4356 /* Maximum depth up to which to dive into Lisp structures. */
4358 #define SXHASH_MAX_DEPTH 3
4360 /* Maximum length up to which to take list and vector elements into
4363 #define SXHASH_MAX_LEN 7
4365 /* Combine two integers X and Y for hashing. */
4367 #define SXHASH_COMBINE(X, Y) \
4368 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4372 /* Return a hash for string PTR which has length LEN. The hash
4373 code returned is guaranteed to fit in a Lisp integer. */
4376 sxhash_string (ptr
, len
)
4380 unsigned char *p
= ptr
;
4381 unsigned char *end
= p
+ len
;
4390 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4393 return hash
& INTMASK
;
4397 /* Return a hash for list LIST. DEPTH is the current depth in the
4398 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4401 sxhash_list (list
, depth
)
4408 if (depth
< SXHASH_MAX_DEPTH
)
4410 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4411 list
= XCDR (list
), ++i
)
4413 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4414 hash
= SXHASH_COMBINE (hash
, hash2
);
4421 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4422 the Lisp structure. */
4425 sxhash_vector (vec
, depth
)
4429 unsigned hash
= XVECTOR (vec
)->size
;
4432 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4433 for (i
= 0; i
< n
; ++i
)
4435 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4436 hash
= SXHASH_COMBINE (hash
, hash2
);
4443 /* Return a hash for bool-vector VECTOR. */
4446 sxhash_bool_vector (vec
)
4449 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4452 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4453 for (i
= 0; i
< n
; ++i
)
4454 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4460 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4461 structure. Value is an unsigned integer clipped to INTMASK. */
4470 if (depth
> SXHASH_MAX_DEPTH
)
4473 switch (XTYPE (obj
))
4480 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4481 SCHARS (SYMBOL_NAME (obj
)));
4489 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4492 /* This can be everything from a vector to an overlay. */
4493 case Lisp_Vectorlike
:
4495 /* According to the CL HyperSpec, two arrays are equal only if
4496 they are `eq', except for strings and bit-vectors. In
4497 Emacs, this works differently. We have to compare element
4499 hash
= sxhash_vector (obj
, depth
);
4500 else if (BOOL_VECTOR_P (obj
))
4501 hash
= sxhash_bool_vector (obj
);
4503 /* Others are `equal' if they are `eq', so let's take their
4509 hash
= sxhash_list (obj
, depth
);
4514 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4515 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4516 for (hash
= 0; p
< e
; ++p
)
4517 hash
= SXHASH_COMBINE (hash
, *p
);
4525 return hash
& INTMASK
;
4530 /***********************************************************************
4532 ***********************************************************************/
4535 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4536 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4540 unsigned hash
= sxhash (obj
, 0);;
4541 return make_number (hash
);
4545 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4546 doc
: /* Create and return a new hash table.
4548 Arguments are specified as keyword/argument pairs. The following
4549 arguments are defined:
4551 :test TEST -- TEST must be a symbol that specifies how to compare
4552 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4553 `equal'. User-supplied test and hash functions can be specified via
4554 `define-hash-table-test'.
4556 :size SIZE -- A hint as to how many elements will be put in the table.
4559 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4560 fills up. If REHASH-SIZE is an integer, add that many space. If it
4561 is a float, it must be > 1.0, and the new size is computed by
4562 multiplying the old size with that factor. Default is 1.5.
4564 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4565 Resize the hash table when ratio of the number of entries in the
4566 table. Default is 0.8.
4568 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4569 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4570 returned is a weak table. Key/value pairs are removed from a weak
4571 hash table when there are no non-weak references pointing to their
4572 key, value, one of key or value, or both key and value, depending on
4573 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4576 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4581 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4582 Lisp_Object user_test
, user_hash
;
4586 /* The vector `used' is used to keep track of arguments that
4587 have been consumed. */
4588 used
= (char *) alloca (nargs
* sizeof *used
);
4589 bzero (used
, nargs
* sizeof *used
);
4591 /* See if there's a `:test TEST' among the arguments. */
4592 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4593 test
= i
< 0 ? Qeql
: args
[i
];
4594 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4596 /* See if it is a user-defined test. */
4599 prop
= Fget (test
, Qhash_table_test
);
4600 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4601 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4603 user_test
= XCAR (prop
);
4604 user_hash
= XCAR (XCDR (prop
));
4607 user_test
= user_hash
= Qnil
;
4609 /* See if there's a `:size SIZE' argument. */
4610 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4611 size
= i
< 0 ? Qnil
: args
[i
];
4613 size
= make_number (DEFAULT_HASH_SIZE
);
4614 else if (!INTEGERP (size
) || XINT (size
) < 0)
4616 list2 (build_string ("Invalid hash table size"),
4619 /* Look for `:rehash-size SIZE'. */
4620 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4621 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4622 if (!NUMBERP (rehash_size
)
4623 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4624 || XFLOATINT (rehash_size
) <= 1.0)
4626 list2 (build_string ("Invalid hash table rehash size"),
4629 /* Look for `:rehash-threshold THRESHOLD'. */
4630 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4631 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4632 if (!FLOATP (rehash_threshold
)
4633 || XFLOATINT (rehash_threshold
) <= 0.0
4634 || XFLOATINT (rehash_threshold
) > 1.0)
4636 list2 (build_string ("Invalid hash table rehash threshold"),
4639 /* Look for `:weakness WEAK'. */
4640 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4641 weak
= i
< 0 ? Qnil
: args
[i
];
4643 weak
= Qkey_and_value
;
4646 && !EQ (weak
, Qvalue
)
4647 && !EQ (weak
, Qkey_or_value
)
4648 && !EQ (weak
, Qkey_and_value
))
4649 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4652 /* Now, all args should have been used up, or there's a problem. */
4653 for (i
= 0; i
< nargs
; ++i
)
4656 list2 (build_string ("Invalid argument list"), args
[i
]));
4658 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4659 user_test
, user_hash
);
4663 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4664 doc
: /* Return a copy of hash table TABLE. */)
4668 return copy_hash_table (check_hash_table (table
));
4672 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4673 doc
: /* Return the number of elements in TABLE. */)
4677 return check_hash_table (table
)->count
;
4681 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4682 Shash_table_rehash_size
, 1, 1, 0,
4683 doc
: /* Return the current rehash size of TABLE. */)
4687 return check_hash_table (table
)->rehash_size
;
4691 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4692 Shash_table_rehash_threshold
, 1, 1, 0,
4693 doc
: /* Return the current rehash threshold of TABLE. */)
4697 return check_hash_table (table
)->rehash_threshold
;
4701 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4702 doc
: /* Return the size of TABLE.
4703 The size can be used as an argument to `make-hash-table' to create
4704 a hash table than can hold as many elements of TABLE holds
4705 without need for resizing. */)
4709 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4710 return make_number (HASH_TABLE_SIZE (h
));
4714 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4715 doc
: /* Return the test TABLE uses. */)
4719 return check_hash_table (table
)->test
;
4723 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4725 doc
: /* Return the weakness of TABLE. */)
4729 return check_hash_table (table
)->weak
;
4733 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4734 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4738 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4742 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4743 doc
: /* Clear hash table TABLE. */)
4747 hash_clear (check_hash_table (table
));
4752 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4753 doc
: /* Look up KEY in TABLE and return its associated value.
4754 If KEY is not found, return DFLT which defaults to nil. */)
4756 Lisp_Object key
, table
, dflt
;
4758 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4759 int i
= hash_lookup (h
, key
, NULL
);
4760 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4764 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4765 doc
: /* Associate KEY with VALUE in hash table TABLE.
4766 If KEY is already present in table, replace its current value with
4769 Lisp_Object key
, value
, table
;
4771 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4775 i
= hash_lookup (h
, key
, &hash
);
4777 HASH_VALUE (h
, i
) = value
;
4779 hash_put (h
, key
, value
, hash
);
4785 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4786 doc
: /* Remove KEY from TABLE. */)
4788 Lisp_Object key
, table
;
4790 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4791 hash_remove (h
, key
);
4796 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4797 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4798 FUNCTION is called with 2 arguments KEY and VALUE. */)
4800 Lisp_Object function
, table
;
4802 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4803 Lisp_Object args
[3];
4806 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4807 if (!NILP (HASH_HASH (h
, i
)))
4810 args
[1] = HASH_KEY (h
, i
);
4811 args
[2] = HASH_VALUE (h
, i
);
4819 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4820 Sdefine_hash_table_test
, 3, 3, 0,
4821 doc
: /* Define a new hash table test with name NAME, a symbol.
4823 In hash tables created with NAME specified as test, use TEST to
4824 compare keys, and HASH for computing hash codes of keys.
4826 TEST must be a function taking two arguments and returning non-nil if
4827 both arguments are the same. HASH must be a function taking one
4828 argument and return an integer that is the hash code of the argument.
4829 Hash code computation should use the whole value range of integers,
4830 including negative integers. */)
4832 Lisp_Object name
, test
, hash
;
4834 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4839 /************************************************************************
4841 ************************************************************************/
4845 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4846 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4848 A message digest is a cryptographic checksum of a document, and the
4849 algorithm to calculate it is defined in RFC 1321.
4851 The two optional arguments START and END are character positions
4852 specifying for which part of OBJECT the message digest should be
4853 computed. If nil or omitted, the digest is computed for the whole
4856 The MD5 message digest is computed from the result of encoding the
4857 text in a coding system, not directly from the internal Emacs form of
4858 the text. The optional fourth argument CODING-SYSTEM specifies which
4859 coding system to encode the text with. It should be the same coding
4860 system that you used or will use when actually writing the text into a
4863 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4864 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4865 system would be chosen by default for writing this text into a file.
4867 If OBJECT is a string, the most preferred coding system (see the
4868 command `prefer-coding-system') is used.
4870 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4871 guesswork fails. Normally, an error is signaled in such case. */)
4872 (object
, start
, end
, coding_system
, noerror
)
4873 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4875 unsigned char digest
[16];
4876 unsigned char value
[33];
4880 int start_char
= 0, end_char
= 0;
4881 int start_byte
= 0, end_byte
= 0;
4883 register struct buffer
*bp
;
4886 if (STRINGP (object
))
4888 if (NILP (coding_system
))
4890 /* Decide the coding-system to encode the data with. */
4892 if (STRING_MULTIBYTE (object
))
4893 /* use default, we can't guess correct value */
4894 coding_system
= preferred_coding_system ();
4896 coding_system
= Qraw_text
;
4899 if (NILP (Fcoding_system_p (coding_system
)))
4901 /* Invalid coding system. */
4903 if (!NILP (noerror
))
4904 coding_system
= Qraw_text
;
4907 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4910 if (STRING_MULTIBYTE (object
))
4911 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4913 size
= SCHARS (object
);
4914 size_byte
= SBYTES (object
);
4918 CHECK_NUMBER (start
);
4920 start_char
= XINT (start
);
4925 start_byte
= string_char_to_byte (object
, start_char
);
4931 end_byte
= size_byte
;
4937 end_char
= XINT (end
);
4942 end_byte
= string_char_to_byte (object
, end_char
);
4945 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4946 args_out_of_range_3 (object
, make_number (start_char
),
4947 make_number (end_char
));
4951 struct buffer
*prev
= current_buffer
;
4953 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4955 CHECK_BUFFER (object
);
4957 bp
= XBUFFER (object
);
4958 if (bp
!= current_buffer
)
4959 set_buffer_internal (bp
);
4965 CHECK_NUMBER_COERCE_MARKER (start
);
4973 CHECK_NUMBER_COERCE_MARKER (end
);
4978 temp
= b
, b
= e
, e
= temp
;
4980 if (!(BEGV
<= b
&& e
<= ZV
))
4981 args_out_of_range (start
, end
);
4983 if (NILP (coding_system
))
4985 /* Decide the coding-system to encode the data with.
4986 See fileio.c:Fwrite-region */
4988 if (!NILP (Vcoding_system_for_write
))
4989 coding_system
= Vcoding_system_for_write
;
4992 int force_raw_text
= 0;
4994 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4995 if (NILP (coding_system
)
4996 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4998 coding_system
= Qnil
;
4999 if (NILP (current_buffer
->enable_multibyte_characters
))
5003 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5005 /* Check file-coding-system-alist. */
5006 Lisp_Object args
[4], val
;
5008 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5009 args
[3] = Fbuffer_file_name(object
);
5010 val
= Ffind_operation_coding_system (4, args
);
5011 if (CONSP (val
) && !NILP (XCDR (val
)))
5012 coding_system
= XCDR (val
);
5015 if (NILP (coding_system
)
5016 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5018 /* If we still have not decided a coding system, use the
5019 default value of buffer-file-coding-system. */
5020 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5024 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5025 /* Confirm that VAL can surely encode the current region. */
5026 coding_system
= call4 (Vselect_safe_coding_system_function
,
5027 make_number (b
), make_number (e
),
5028 coding_system
, Qnil
);
5031 coding_system
= Qraw_text
;
5034 if (NILP (Fcoding_system_p (coding_system
)))
5036 /* Invalid coding system. */
5038 if (!NILP (noerror
))
5039 coding_system
= Qraw_text
;
5042 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5046 object
= make_buffer_string (b
, e
, 0);
5047 if (prev
!= current_buffer
)
5048 set_buffer_internal (prev
);
5049 /* Discard the unwind protect for recovering the current
5053 if (STRING_MULTIBYTE (object
))
5054 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5057 md5_buffer (SDATA (object
) + start_byte
,
5058 SBYTES (object
) - (size_byte
- end_byte
),
5061 for (i
= 0; i
< 16; i
++)
5062 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5065 return make_string (value
, 32);
5072 /* Hash table stuff. */
5073 Qhash_table_p
= intern ("hash-table-p");
5074 staticpro (&Qhash_table_p
);
5075 Qeq
= intern ("eq");
5077 Qeql
= intern ("eql");
5079 Qequal
= intern ("equal");
5080 staticpro (&Qequal
);
5081 QCtest
= intern (":test");
5082 staticpro (&QCtest
);
5083 QCsize
= intern (":size");
5084 staticpro (&QCsize
);
5085 QCrehash_size
= intern (":rehash-size");
5086 staticpro (&QCrehash_size
);
5087 QCrehash_threshold
= intern (":rehash-threshold");
5088 staticpro (&QCrehash_threshold
);
5089 QCweakness
= intern (":weakness");
5090 staticpro (&QCweakness
);
5091 Qkey
= intern ("key");
5093 Qvalue
= intern ("value");
5094 staticpro (&Qvalue
);
5095 Qhash_table_test
= intern ("hash-table-test");
5096 staticpro (&Qhash_table_test
);
5097 Qkey_or_value
= intern ("key-or-value");
5098 staticpro (&Qkey_or_value
);
5099 Qkey_and_value
= intern ("key-and-value");
5100 staticpro (&Qkey_and_value
);
5103 defsubr (&Smake_hash_table
);
5104 defsubr (&Scopy_hash_table
);
5105 defsubr (&Shash_table_count
);
5106 defsubr (&Shash_table_rehash_size
);
5107 defsubr (&Shash_table_rehash_threshold
);
5108 defsubr (&Shash_table_size
);
5109 defsubr (&Shash_table_test
);
5110 defsubr (&Shash_table_weakness
);
5111 defsubr (&Shash_table_p
);
5112 defsubr (&Sclrhash
);
5113 defsubr (&Sgethash
);
5114 defsubr (&Sputhash
);
5115 defsubr (&Sremhash
);
5116 defsubr (&Smaphash
);
5117 defsubr (&Sdefine_hash_table_test
);
5119 Qstring_lessp
= intern ("string-lessp");
5120 staticpro (&Qstring_lessp
);
5121 Qprovide
= intern ("provide");
5122 staticpro (&Qprovide
);
5123 Qrequire
= intern ("require");
5124 staticpro (&Qrequire
);
5125 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5126 staticpro (&Qyes_or_no_p_history
);
5127 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5128 staticpro (&Qcursor_in_echo_area
);
5129 Qwidget_type
= intern ("widget-type");
5130 staticpro (&Qwidget_type
);
5132 staticpro (&string_char_byte_cache_string
);
5133 string_char_byte_cache_string
= Qnil
;
5135 require_nesting_list
= Qnil
;
5136 staticpro (&require_nesting_list
);
5138 Fset (Qyes_or_no_p_history
, Qnil
);
5140 DEFVAR_LISP ("features", &Vfeatures
,
5141 doc
: /* A list of symbols which are the features of the executing emacs.
5142 Used by `featurep' and `require', and altered by `provide'. */);
5144 Qsubfeatures
= intern ("subfeatures");
5145 staticpro (&Qsubfeatures
);
5147 #ifdef HAVE_LANGINFO_CODESET
5148 Qcodeset
= intern ("codeset");
5149 staticpro (&Qcodeset
);
5150 Qdays
= intern ("days");
5152 Qmonths
= intern ("months");
5153 staticpro (&Qmonths
);
5154 Qpaper
= intern ("paper");
5155 staticpro (&Qpaper
);
5156 #endif /* HAVE_LANGINFO_CODESET */
5158 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5159 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5160 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5161 invoked by mouse clicks and mouse menu items. */);
5164 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5165 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5166 This applies to commands from menus and tool bar buttons. The value of
5167 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5168 used if both `use-dialog-box' and this variable are non-nil. */);
5169 use_file_dialog
= 1;
5171 defsubr (&Sidentity
);
5174 defsubr (&Ssafe_length
);
5175 defsubr (&Sstring_bytes
);
5176 defsubr (&Sstring_equal
);
5177 defsubr (&Scompare_strings
);
5178 defsubr (&Sstring_lessp
);
5181 defsubr (&Svconcat
);
5182 defsubr (&Scopy_sequence
);
5183 defsubr (&Sstring_make_multibyte
);
5184 defsubr (&Sstring_make_unibyte
);
5185 defsubr (&Sstring_as_multibyte
);
5186 defsubr (&Sstring_as_unibyte
);
5187 defsubr (&Sstring_to_multibyte
);
5188 defsubr (&Scopy_alist
);
5189 defsubr (&Ssubstring
);
5190 defsubr (&Ssubstring_no_properties
);
5202 defsubr (&Snreverse
);
5203 defsubr (&Sreverse
);
5205 defsubr (&Splist_get
);
5207 defsubr (&Splist_put
);
5209 defsubr (&Slax_plist_get
);
5210 defsubr (&Slax_plist_put
);
5213 defsubr (&Sequal_including_properties
);
5214 defsubr (&Sfillarray
);
5215 defsubr (&Sclear_string
);
5219 defsubr (&Smapconcat
);
5220 defsubr (&Sy_or_n_p
);
5221 defsubr (&Syes_or_no_p
);
5222 defsubr (&Sload_average
);
5223 defsubr (&Sfeaturep
);
5224 defsubr (&Srequire
);
5225 defsubr (&Sprovide
);
5226 defsubr (&Splist_member
);
5227 defsubr (&Swidget_put
);
5228 defsubr (&Swidget_get
);
5229 defsubr (&Swidget_apply
);
5230 defsubr (&Sbase64_encode_region
);
5231 defsubr (&Sbase64_decode_region
);
5232 defsubr (&Sbase64_encode_string
);
5233 defsubr (&Sbase64_decode_string
);
5235 defsubr (&Slocale_info
);
5242 Vweak_hash_tables
= Qnil
;
5245 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5246 (do not change this comment) */