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
)
922 if (STRING_MULTIBYTE (string
))
925 nbytes
= count_size_as_multibyte (SDATA (string
),
927 /* If all the chars are ASCII, they won't need any more bytes
928 once converted. In that case, we can return STRING itself. */
929 if (nbytes
== SBYTES (string
))
932 buf
= (unsigned char *) alloca (nbytes
);
933 copy_text (SDATA (string
), buf
, SBYTES (string
),
936 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
940 /* Convert STRING (if unibyte) to a multibyte string without changing
941 the number of characters. Characters 0200 trough 0237 are
942 converted to eight-bit characters. */
945 string_to_multibyte (string
)
951 if (STRING_MULTIBYTE (string
))
954 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
955 /* If all the chars are ASCII, they won't need any more bytes once
957 if (nbytes
== SBYTES (string
))
958 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
960 buf
= (unsigned char *) alloca (nbytes
);
961 bcopy (SDATA (string
), buf
, SBYTES (string
));
962 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
964 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
968 /* Convert STRING to a single-byte string. */
971 string_make_unibyte (string
)
977 if (! STRING_MULTIBYTE (string
))
980 /* We can not use alloca here, because string might be very long.
981 For example when selecting megabytes of text and then pasting it to
982 another application. */
983 buf
= (unsigned char *) xmalloc (SCHARS (string
));
985 copy_text (SDATA (string
), buf
, SBYTES (string
),
988 ret
= make_unibyte_string (buf
, SCHARS (string
));
995 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
997 doc
: /* Return the multibyte equivalent of STRING.
998 If STRING is unibyte and contains non-ASCII characters, the function
999 `unibyte-char-to-multibyte' is used to convert each unibyte character
1000 to a multibyte character. In this case, the returned string is a
1001 newly created string with no text properties. If STRING is multibyte
1002 or entirely ASCII, it is returned unchanged. In particular, when
1003 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1004 \(When the characters are all ASCII, Emacs primitives will treat the
1005 string the same way whether it is unibyte or multibyte.) */)
1009 CHECK_STRING (string
);
1011 return string_make_multibyte (string
);
1014 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1016 doc
: /* Return the unibyte equivalent of STRING.
1017 Multibyte character codes are converted to unibyte according to
1018 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1019 If the lookup in the translation table fails, this function takes just
1020 the low 8 bits of each character. */)
1024 CHECK_STRING (string
);
1026 return string_make_unibyte (string
);
1029 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1031 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1032 If STRING is unibyte, the result is STRING itself.
1033 Otherwise it is a newly created string, with no text properties.
1034 If STRING is multibyte and contains a character of charset
1035 `eight-bit', it is converted to the corresponding single byte. */)
1039 CHECK_STRING (string
);
1041 if (STRING_MULTIBYTE (string
))
1043 int bytes
= SBYTES (string
);
1044 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1046 bcopy (SDATA (string
), str
, bytes
);
1047 bytes
= str_as_unibyte (str
, bytes
);
1048 string
= make_unibyte_string (str
, bytes
);
1054 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1056 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1057 If STRING is multibyte, the result is STRING itself.
1058 Otherwise it is a newly created string, with no text properties.
1060 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1061 part of a correct utf-8 sequence), it is converted to the corresponding
1062 multibyte character of charset `eight-bit'.
1063 See also `string-to-multibyte'. */)
1067 CHECK_STRING (string
);
1069 if (! STRING_MULTIBYTE (string
))
1071 Lisp_Object new_string
;
1074 parse_str_as_multibyte (SDATA (string
),
1077 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1078 bcopy (SDATA (string
), SDATA (new_string
),
1080 if (nbytes
!= SBYTES (string
))
1081 str_as_multibyte (SDATA (new_string
), nbytes
,
1082 SBYTES (string
), NULL
);
1083 string
= new_string
;
1084 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1089 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1091 doc
: /* Return a multibyte string with the same individual chars as STRING.
1092 If STRING is multibyte, the result is STRING itself.
1093 Otherwise it is a newly created string, with no text properties.
1095 If STRING is unibyte and contains an 8-bit byte, it is converted to
1096 the corresponding multibyte character of charset `eight-bit'.
1098 This differs from `string-as-multibyte' by converting each byte of a correct
1099 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1100 correct sequence. */)
1104 CHECK_STRING (string
);
1106 return string_to_multibyte (string
);
1110 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1111 doc
: /* Return a copy of ALIST.
1112 This is an alist which represents the same mapping from objects to objects,
1113 but does not share the alist structure with ALIST.
1114 The objects mapped (cars and cdrs of elements of the alist)
1115 are shared, however.
1116 Elements of ALIST that are not conses are also shared. */)
1120 register Lisp_Object tem
;
1125 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1126 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1128 register Lisp_Object car
;
1132 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1137 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1138 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1139 TO may be nil or omitted; then the substring runs to the end of STRING.
1140 FROM and TO start at 0. If either is negative, it counts from the end.
1142 This function allows vectors as well as strings. */)
1145 register Lisp_Object from
, to
;
1150 int from_char
, to_char
;
1151 int from_byte
= 0, to_byte
= 0;
1153 if (! (STRINGP (string
) || VECTORP (string
)))
1154 wrong_type_argument (Qarrayp
, string
);
1156 CHECK_NUMBER (from
);
1158 if (STRINGP (string
))
1160 size
= SCHARS (string
);
1161 size_byte
= SBYTES (string
);
1164 size
= XVECTOR (string
)->size
;
1169 to_byte
= size_byte
;
1175 to_char
= XINT (to
);
1179 if (STRINGP (string
))
1180 to_byte
= string_char_to_byte (string
, to_char
);
1183 from_char
= XINT (from
);
1186 if (STRINGP (string
))
1187 from_byte
= string_char_to_byte (string
, from_char
);
1189 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1190 args_out_of_range_3 (string
, make_number (from_char
),
1191 make_number (to_char
));
1193 if (STRINGP (string
))
1195 res
= make_specified_string (SDATA (string
) + from_byte
,
1196 to_char
- from_char
, to_byte
- from_byte
,
1197 STRING_MULTIBYTE (string
));
1198 copy_text_properties (make_number (from_char
), make_number (to_char
),
1199 string
, make_number (0), res
, Qnil
);
1202 res
= Fvector (to_char
- from_char
,
1203 XVECTOR (string
)->contents
+ from_char
);
1209 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1210 doc
: /* Return a substring of STRING, without text properties.
1211 It starts at index FROM and ending before TO.
1212 TO may be nil or omitted; then the substring runs to the end of STRING.
1213 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1214 If FROM or TO is negative, it counts from the end.
1216 With one argument, just copy STRING without its properties. */)
1219 register Lisp_Object from
, to
;
1221 int size
, size_byte
;
1222 int from_char
, to_char
;
1223 int from_byte
, to_byte
;
1225 CHECK_STRING (string
);
1227 size
= SCHARS (string
);
1228 size_byte
= SBYTES (string
);
1231 from_char
= from_byte
= 0;
1234 CHECK_NUMBER (from
);
1235 from_char
= XINT (from
);
1239 from_byte
= string_char_to_byte (string
, from_char
);
1245 to_byte
= size_byte
;
1251 to_char
= XINT (to
);
1255 to_byte
= string_char_to_byte (string
, to_char
);
1258 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1259 args_out_of_range_3 (string
, make_number (from_char
),
1260 make_number (to_char
));
1262 return make_specified_string (SDATA (string
) + from_byte
,
1263 to_char
- from_char
, to_byte
- from_byte
,
1264 STRING_MULTIBYTE (string
));
1267 /* Extract a substring of STRING, giving start and end positions
1268 both in characters and in bytes. */
1271 substring_both (string
, from
, from_byte
, to
, to_byte
)
1273 int from
, from_byte
, to
, to_byte
;
1279 if (! (STRINGP (string
) || VECTORP (string
)))
1280 wrong_type_argument (Qarrayp
, string
);
1282 if (STRINGP (string
))
1284 size
= SCHARS (string
);
1285 size_byte
= SBYTES (string
);
1288 size
= XVECTOR (string
)->size
;
1290 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1291 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1293 if (STRINGP (string
))
1295 res
= make_specified_string (SDATA (string
) + from_byte
,
1296 to
- from
, to_byte
- from_byte
,
1297 STRING_MULTIBYTE (string
));
1298 copy_text_properties (make_number (from
), make_number (to
),
1299 string
, make_number (0), res
, Qnil
);
1302 res
= Fvector (to
- from
,
1303 XVECTOR (string
)->contents
+ from
);
1308 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1309 doc
: /* Take cdr N times on LIST, returns the result. */)
1312 register Lisp_Object list
;
1314 register int i
, num
;
1317 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1321 wrong_type_argument (Qlistp
, list
);
1327 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1328 doc
: /* Return the Nth element of LIST.
1329 N counts from zero. If LIST is not that long, nil is returned. */)
1331 Lisp_Object n
, list
;
1333 return Fcar (Fnthcdr (n
, list
));
1336 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1337 doc
: /* Return element of SEQUENCE at index N. */)
1339 register Lisp_Object sequence
, n
;
1344 if (CONSP (sequence
) || NILP (sequence
))
1345 return Fcar (Fnthcdr (n
, sequence
));
1346 else if (STRINGP (sequence
) || VECTORP (sequence
)
1347 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1348 return Faref (sequence
, n
);
1350 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1354 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1355 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1356 The value is actually the tail of LIST whose car is ELT. */)
1358 register Lisp_Object elt
;
1361 register Lisp_Object tail
;
1362 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1364 register Lisp_Object tem
;
1366 wrong_type_argument (Qlistp
, list
);
1368 if (! NILP (Fequal (elt
, tem
)))
1375 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1376 doc
: /* Return non-nil if ELT is an element of LIST.
1377 Comparison done with EQ. The value is actually the tail of LIST
1378 whose car is ELT. */)
1380 Lisp_Object elt
, list
;
1384 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1388 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1392 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1399 if (!CONSP (list
) && !NILP (list
))
1400 list
= wrong_type_argument (Qlistp
, list
);
1405 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1406 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1407 The value is actually the first element of LIST whose car is KEY.
1408 Elements of LIST that are not conses are ignored. */)
1410 Lisp_Object key
, list
;
1417 || (CONSP (XCAR (list
))
1418 && EQ (XCAR (XCAR (list
)), key
)))
1423 || (CONSP (XCAR (list
))
1424 && EQ (XCAR (XCAR (list
)), key
)))
1429 || (CONSP (XCAR (list
))
1430 && EQ (XCAR (XCAR (list
)), key
)))
1438 result
= XCAR (list
);
1439 else if (NILP (list
))
1442 result
= wrong_type_argument (Qlistp
, list
);
1447 /* Like Fassq but never report an error and do not allow quits.
1448 Use only on lists known never to be circular. */
1451 assq_no_quit (key
, list
)
1452 Lisp_Object key
, list
;
1455 && (!CONSP (XCAR (list
))
1456 || !EQ (XCAR (XCAR (list
)), key
)))
1459 return CONSP (list
) ? XCAR (list
) : Qnil
;
1462 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1463 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1464 The value is actually the first element of LIST whose car equals KEY. */)
1466 Lisp_Object key
, list
;
1468 Lisp_Object result
, car
;
1473 || (CONSP (XCAR (list
))
1474 && (car
= XCAR (XCAR (list
)),
1475 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1480 || (CONSP (XCAR (list
))
1481 && (car
= XCAR (XCAR (list
)),
1482 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1487 || (CONSP (XCAR (list
))
1488 && (car
= XCAR (XCAR (list
)),
1489 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1497 result
= XCAR (list
);
1498 else if (NILP (list
))
1501 result
= wrong_type_argument (Qlistp
, list
);
1506 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1507 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1508 The value is actually the first element of LIST whose cdr is KEY. */)
1510 register Lisp_Object key
;
1518 || (CONSP (XCAR (list
))
1519 && EQ (XCDR (XCAR (list
)), key
)))
1524 || (CONSP (XCAR (list
))
1525 && EQ (XCDR (XCAR (list
)), key
)))
1530 || (CONSP (XCAR (list
))
1531 && EQ (XCDR (XCAR (list
)), key
)))
1540 else if (CONSP (list
))
1541 result
= XCAR (list
);
1543 result
= wrong_type_argument (Qlistp
, list
);
1548 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1549 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1550 The value is actually the first element of LIST whose cdr equals KEY. */)
1552 Lisp_Object key
, list
;
1554 Lisp_Object result
, cdr
;
1559 || (CONSP (XCAR (list
))
1560 && (cdr
= XCDR (XCAR (list
)),
1561 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1566 || (CONSP (XCAR (list
))
1567 && (cdr
= XCDR (XCAR (list
)),
1568 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1573 || (CONSP (XCAR (list
))
1574 && (cdr
= XCDR (XCAR (list
)),
1575 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1583 result
= XCAR (list
);
1584 else if (NILP (list
))
1587 result
= wrong_type_argument (Qlistp
, list
);
1592 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1593 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1594 The modified LIST is returned. Comparison is done with `eq'.
1595 If the first member of LIST is ELT, there is no way to remove it by side effect;
1596 therefore, write `(setq foo (delq element foo))'
1597 to be sure of changing the value of `foo'. */)
1599 register Lisp_Object elt
;
1602 register Lisp_Object tail
, prev
;
1603 register Lisp_Object tem
;
1607 while (!NILP (tail
))
1610 wrong_type_argument (Qlistp
, list
);
1617 Fsetcdr (prev
, XCDR (tail
));
1627 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1628 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1629 SEQ must be a list, a vector, or a string.
1630 The modified SEQ is returned. Comparison is done with `equal'.
1631 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1632 is not a side effect; it is simply using a different sequence.
1633 Therefore, write `(setq foo (delete element foo))'
1634 to be sure of changing the value of `foo'. */)
1636 Lisp_Object elt
, seq
;
1642 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1643 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1646 if (n
!= ASIZE (seq
))
1648 struct Lisp_Vector
*p
= allocate_vector (n
);
1650 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1651 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1652 p
->contents
[n
++] = AREF (seq
, i
);
1654 XSETVECTOR (seq
, p
);
1657 else if (STRINGP (seq
))
1659 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1662 for (i
= nchars
= nbytes
= ibyte
= 0;
1664 ++i
, ibyte
+= cbytes
)
1666 if (STRING_MULTIBYTE (seq
))
1668 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1669 SBYTES (seq
) - ibyte
);
1670 cbytes
= CHAR_BYTES (c
);
1678 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1685 if (nchars
!= SCHARS (seq
))
1689 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1690 if (!STRING_MULTIBYTE (seq
))
1691 STRING_SET_UNIBYTE (tem
);
1693 for (i
= nchars
= nbytes
= ibyte
= 0;
1695 ++i
, ibyte
+= cbytes
)
1697 if (STRING_MULTIBYTE (seq
))
1699 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1700 SBYTES (seq
) - ibyte
);
1701 cbytes
= CHAR_BYTES (c
);
1709 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1711 unsigned char *from
= SDATA (seq
) + ibyte
;
1712 unsigned char *to
= SDATA (tem
) + nbytes
;
1718 for (n
= cbytes
; n
--; )
1728 Lisp_Object tail
, prev
;
1730 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1733 wrong_type_argument (Qlistp
, seq
);
1735 if (!NILP (Fequal (elt
, XCAR (tail
))))
1740 Fsetcdr (prev
, XCDR (tail
));
1751 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1752 doc
: /* Reverse LIST by modifying cdr pointers.
1753 Return the reversed list. */)
1757 register Lisp_Object prev
, tail
, next
;
1759 if (NILP (list
)) return list
;
1762 while (!NILP (tail
))
1766 wrong_type_argument (Qlistp
, list
);
1768 Fsetcdr (tail
, prev
);
1775 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1776 doc
: /* Reverse LIST, copying. Return the reversed list.
1777 See also the function `nreverse', which is used more often. */)
1783 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1786 new = Fcons (XCAR (list
), new);
1789 wrong_type_argument (Qconsp
, list
);
1793 Lisp_Object
merge ();
1795 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1796 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1797 Returns the sorted list. LIST is modified by side effects.
1798 PREDICATE is called with two elements of LIST, and should return t
1799 if the first element is "less" than the second. */)
1801 Lisp_Object list
, predicate
;
1803 Lisp_Object front
, back
;
1804 register Lisp_Object len
, tem
;
1805 struct gcpro gcpro1
, gcpro2
;
1806 register int length
;
1809 len
= Flength (list
);
1810 length
= XINT (len
);
1814 XSETINT (len
, (length
/ 2) - 1);
1815 tem
= Fnthcdr (len
, list
);
1817 Fsetcdr (tem
, Qnil
);
1819 GCPRO2 (front
, back
);
1820 front
= Fsort (front
, predicate
);
1821 back
= Fsort (back
, predicate
);
1823 return merge (front
, back
, predicate
);
1827 merge (org_l1
, org_l2
, pred
)
1828 Lisp_Object org_l1
, org_l2
;
1832 register Lisp_Object tail
;
1834 register Lisp_Object l1
, l2
;
1835 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1842 /* It is sufficient to protect org_l1 and org_l2.
1843 When l1 and l2 are updated, we copy the new values
1844 back into the org_ vars. */
1845 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1865 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1881 Fsetcdr (tail
, tem
);
1887 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1888 doc
: /* Extract a value from a property list.
1889 PLIST is a property list, which is a list of the form
1890 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1891 corresponding to the given PROP, or nil if PROP is not
1892 one of the properties on the list. */)
1900 CONSP (tail
) && CONSP (XCDR (tail
));
1901 tail
= XCDR (XCDR (tail
)))
1903 if (EQ (prop
, XCAR (tail
)))
1904 return XCAR (XCDR (tail
));
1906 /* This function can be called asynchronously
1907 (setup_coding_system). Don't QUIT in that case. */
1908 if (!interrupt_input_blocked
)
1913 wrong_type_argument (Qlistp
, prop
);
1918 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1919 doc
: /* Return the value of SYMBOL's PROPNAME property.
1920 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1922 Lisp_Object symbol
, propname
;
1924 CHECK_SYMBOL (symbol
);
1925 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1928 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1929 doc
: /* Change value in PLIST of PROP to VAL.
1930 PLIST is a property list, which is a list of the form
1931 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1932 If PROP is already a property on the list, its value is set to VAL,
1933 otherwise the new PROP VAL pair is added. The new plist is returned;
1934 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1935 The PLIST is modified by side effects. */)
1938 register Lisp_Object prop
;
1941 register Lisp_Object tail
, prev
;
1942 Lisp_Object newcell
;
1944 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1945 tail
= XCDR (XCDR (tail
)))
1947 if (EQ (prop
, XCAR (tail
)))
1949 Fsetcar (XCDR (tail
), val
);
1956 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1960 Fsetcdr (XCDR (prev
), newcell
);
1964 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1965 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1966 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1967 (symbol
, propname
, value
)
1968 Lisp_Object symbol
, propname
, value
;
1970 CHECK_SYMBOL (symbol
);
1971 XSYMBOL (symbol
)->plist
1972 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1976 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1977 doc
: /* Extract a value from a property list, comparing with `equal'.
1978 PLIST is a property list, which is a list of the form
1979 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1980 corresponding to the given PROP, or nil if PROP is not
1981 one of the properties on the list. */)
1989 CONSP (tail
) && CONSP (XCDR (tail
));
1990 tail
= XCDR (XCDR (tail
)))
1992 if (! NILP (Fequal (prop
, XCAR (tail
))))
1993 return XCAR (XCDR (tail
));
1999 wrong_type_argument (Qlistp
, prop
);
2004 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2005 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2006 PLIST is a property list, which is a list of the form
2007 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2008 If PROP is already a property on the list, its value is set to VAL,
2009 otherwise the new PROP VAL pair is added. The new plist is returned;
2010 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2011 The PLIST is modified by side effects. */)
2014 register Lisp_Object prop
;
2017 register Lisp_Object tail
, prev
;
2018 Lisp_Object newcell
;
2020 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2021 tail
= XCDR (XCDR (tail
)))
2023 if (! NILP (Fequal (prop
, XCAR (tail
))))
2025 Fsetcar (XCDR (tail
), val
);
2032 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2036 Fsetcdr (XCDR (prev
), newcell
);
2040 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2041 doc
: /* Return t if the two args are the same Lisp object.
2042 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2044 Lisp_Object obj1
, obj2
;
2047 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2049 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2052 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2053 doc
: /* Return t if two Lisp objects have similar structure and contents.
2054 They must have the same data type.
2055 Conses are compared by comparing the cars and the cdrs.
2056 Vectors and strings are compared element by element.
2057 Numbers are compared by value, but integers cannot equal floats.
2058 (Use `=' if you want integers and floats to be able to be equal.)
2059 Symbols must match exactly. */)
2061 register Lisp_Object o1
, o2
;
2063 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2066 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2067 doc
: /* Return t if two Lisp objects have similar structure and contents.
2068 This is like `equal' except that it compares the text properties
2069 of strings. (`equal' ignores text properties.) */)
2071 register Lisp_Object o1
, o2
;
2073 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2076 /* DEPTH is current depth of recursion. Signal an error if it
2078 PROPS, if non-nil, means compare string text properties too. */
2081 internal_equal (o1
, o2
, depth
, props
)
2082 register Lisp_Object o1
, o2
;
2086 error ("Stack overflow in equal");
2092 if (XTYPE (o1
) != XTYPE (o2
))
2101 d1
= extract_float (o1
);
2102 d2
= extract_float (o2
);
2103 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2104 though they are not =. */
2105 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2109 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2116 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2120 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2122 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2125 o1
= XOVERLAY (o1
)->plist
;
2126 o2
= XOVERLAY (o2
)->plist
;
2131 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2132 && (XMARKER (o1
)->buffer
== 0
2133 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2137 case Lisp_Vectorlike
:
2140 EMACS_INT size
= XVECTOR (o1
)->size
;
2141 /* Pseudovectors have the type encoded in the size field, so this test
2142 actually checks that the objects have the same type as well as the
2144 if (XVECTOR (o2
)->size
!= size
)
2146 /* Boolvectors are compared much like strings. */
2147 if (BOOL_VECTOR_P (o1
))
2150 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2151 / BOOL_VECTOR_BITS_PER_CHAR
);
2153 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2155 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2160 if (WINDOW_CONFIGURATIONP (o1
))
2161 return compare_window_configurations (o1
, o2
, 0);
2163 /* Aside from them, only true vectors, char-tables, and compiled
2164 functions are sensible to compare, so eliminate the others now. */
2165 if (size
& PSEUDOVECTOR_FLAG
)
2167 if (!(size
& (PVEC_COMPILED
2168 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
)))
2170 size
&= PSEUDOVECTOR_SIZE_MASK
;
2172 for (i
= 0; i
< size
; i
++)
2175 v1
= XVECTOR (o1
)->contents
[i
];
2176 v2
= XVECTOR (o2
)->contents
[i
];
2177 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2185 if (SCHARS (o1
) != SCHARS (o2
))
2187 if (SBYTES (o1
) != SBYTES (o2
))
2189 if (bcmp (SDATA (o1
), SDATA (o2
),
2192 if (props
&& !compare_string_intervals (o1
, o2
))
2198 case Lisp_Type_Limit
:
2205 extern Lisp_Object
Fmake_char_internal ();
2207 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2208 doc
: /* Store each element of ARRAY with ITEM.
2209 ARRAY is a vector, string, char-table, or bool-vector. */)
2211 Lisp_Object array
, item
;
2213 register int size
, index
, charval
;
2215 if (VECTORP (array
))
2217 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2218 size
= XVECTOR (array
)->size
;
2219 for (index
= 0; index
< size
; index
++)
2222 else if (CHAR_TABLE_P (array
))
2226 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2227 XCHAR_TABLE (array
)->contents
[i
] = item
;
2228 XCHAR_TABLE (array
)->defalt
= item
;
2230 else if (STRINGP (array
))
2232 register unsigned char *p
= SDATA (array
);
2233 CHECK_NUMBER (item
);
2234 charval
= XINT (item
);
2235 size
= SCHARS (array
);
2236 if (STRING_MULTIBYTE (array
))
2238 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2239 int len
= CHAR_STRING (charval
, str
);
2240 int size_byte
= SBYTES (array
);
2241 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2244 if (size
!= size_byte
)
2247 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2248 if (len
!= this_len
)
2249 error ("Attempt to change byte length of a string");
2252 for (i
= 0; i
< size_byte
; i
++)
2253 *p
++ = str
[i
% len
];
2256 for (index
= 0; index
< size
; index
++)
2259 else if (BOOL_VECTOR_P (array
))
2261 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2263 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2264 / BOOL_VECTOR_BITS_PER_CHAR
);
2266 charval
= (! NILP (item
) ? -1 : 0);
2267 for (index
= 0; index
< size_in_chars
- 1; index
++)
2269 if (index
< size_in_chars
)
2271 /* Mask out bits beyond the vector size. */
2272 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2273 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2279 array
= wrong_type_argument (Qarrayp
, array
);
2285 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2287 doc
: /* Clear the contents of STRING.
2288 This makes STRING unibyte and may change its length. */)
2292 int len
= SBYTES (string
);
2293 bzero (SDATA (string
), len
);
2294 STRING_SET_CHARS (string
, len
);
2295 STRING_SET_UNIBYTE (string
);
2305 Lisp_Object args
[2];
2308 return Fnconc (2, args
);
2310 return Fnconc (2, &s1
);
2311 #endif /* NO_ARG_ARRAY */
2314 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2315 doc
: /* Concatenate any number of lists by altering them.
2316 Only the last argument is not altered, and need not be a list.
2317 usage: (nconc &rest LISTS) */)
2322 register int argnum
;
2323 register Lisp_Object tail
, tem
, val
;
2327 for (argnum
= 0; argnum
< nargs
; argnum
++)
2330 if (NILP (tem
)) continue;
2335 if (argnum
+ 1 == nargs
) break;
2338 tem
= wrong_type_argument (Qlistp
, tem
);
2347 tem
= args
[argnum
+ 1];
2348 Fsetcdr (tail
, tem
);
2350 args
[argnum
+ 1] = tail
;
2356 /* This is the guts of all mapping functions.
2357 Apply FN to each element of SEQ, one by one,
2358 storing the results into elements of VALS, a C vector of Lisp_Objects.
2359 LENI is the length of VALS, which should also be the length of SEQ. */
2362 mapcar1 (leni
, vals
, fn
, seq
)
2365 Lisp_Object fn
, seq
;
2367 register Lisp_Object tail
;
2370 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2374 /* Don't let vals contain any garbage when GC happens. */
2375 for (i
= 0; i
< leni
; i
++)
2378 GCPRO3 (dummy
, fn
, seq
);
2380 gcpro1
.nvars
= leni
;
2384 /* We need not explicitly protect `tail' because it is used only on lists, and
2385 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2389 for (i
= 0; i
< leni
; i
++)
2391 dummy
= XVECTOR (seq
)->contents
[i
];
2392 dummy
= call1 (fn
, dummy
);
2397 else if (BOOL_VECTOR_P (seq
))
2399 for (i
= 0; i
< leni
; i
++)
2402 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2403 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2408 dummy
= call1 (fn
, dummy
);
2413 else if (STRINGP (seq
))
2417 for (i
= 0, i_byte
= 0; i
< leni
;)
2422 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2423 XSETFASTINT (dummy
, c
);
2424 dummy
= call1 (fn
, dummy
);
2426 vals
[i_before
] = dummy
;
2429 else /* Must be a list, since Flength did not get an error */
2432 for (i
= 0; i
< leni
; i
++)
2434 dummy
= call1 (fn
, Fcar (tail
));
2444 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2445 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2446 In between each pair of results, stick in SEPARATOR. Thus, " " as
2447 SEPARATOR results in spaces between the values returned by FUNCTION.
2448 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2449 (function
, sequence
, separator
)
2450 Lisp_Object function
, sequence
, separator
;
2455 register Lisp_Object
*args
;
2457 struct gcpro gcpro1
;
2459 len
= Flength (sequence
);
2460 if (CHAR_TABLE_P (sequence
))
2461 wrong_type_argument (Qlistp
, sequence
);
2463 nargs
= leni
+ leni
- 1;
2464 if (nargs
< 0) return build_string ("");
2466 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2469 mapcar1 (leni
, args
, function
, sequence
);
2472 for (i
= leni
- 1; i
>= 0; i
--)
2473 args
[i
+ i
] = args
[i
];
2475 for (i
= 1; i
< nargs
; i
+= 2)
2476 args
[i
] = separator
;
2478 return Fconcat (nargs
, args
);
2481 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2482 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2483 The result is a list just as long as SEQUENCE.
2484 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2485 (function
, sequence
)
2486 Lisp_Object function
, sequence
;
2488 register Lisp_Object len
;
2490 register Lisp_Object
*args
;
2492 len
= Flength (sequence
);
2493 if (CHAR_TABLE_P (sequence
))
2494 wrong_type_argument (Qlistp
, sequence
);
2495 leni
= XFASTINT (len
);
2496 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2498 mapcar1 (leni
, args
, function
, sequence
);
2500 return Flist (leni
, args
);
2503 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2504 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2505 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2506 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2507 (function
, sequence
)
2508 Lisp_Object function
, sequence
;
2512 leni
= XFASTINT (Flength (sequence
));
2513 if (CHAR_TABLE_P (sequence
))
2514 wrong_type_argument (Qlistp
, sequence
);
2515 mapcar1 (leni
, 0, function
, sequence
);
2520 /* Anything that calls this function must protect from GC! */
2522 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2523 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2524 Takes one argument, which is the string to display to ask the question.
2525 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2526 No confirmation of the answer is requested; a single character is enough.
2527 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2528 the bindings in `query-replace-map'; see the documentation of that variable
2529 for more information. In this case, the useful bindings are `act', `skip',
2530 `recenter', and `quit'.\)
2532 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2533 is nil and `use-dialog-box' is non-nil. */)
2537 register Lisp_Object obj
, key
, def
, map
;
2538 register int answer
;
2539 Lisp_Object xprompt
;
2540 Lisp_Object args
[2];
2541 struct gcpro gcpro1
, gcpro2
;
2542 int count
= SPECPDL_INDEX ();
2544 specbind (Qcursor_in_echo_area
, Qt
);
2546 map
= Fsymbol_value (intern ("query-replace-map"));
2548 CHECK_STRING (prompt
);
2550 GCPRO2 (prompt
, xprompt
);
2552 #ifdef HAVE_X_WINDOWS
2553 if (display_hourglass_p
)
2554 cancel_hourglass ();
2561 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2565 Lisp_Object pane
, menu
;
2566 redisplay_preserve_echo_area (3);
2567 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2568 Fcons (Fcons (build_string ("No"), Qnil
),
2570 menu
= Fcons (prompt
, pane
);
2571 obj
= Fx_popup_dialog (Qt
, menu
);
2572 answer
= !NILP (obj
);
2575 #endif /* HAVE_MENUS */
2576 cursor_in_echo_area
= 1;
2577 choose_minibuf_frame ();
2580 Lisp_Object pargs
[3];
2582 /* Colorize prompt according to `minibuffer-prompt' face. */
2583 pargs
[0] = build_string ("%s(y or n) ");
2584 pargs
[1] = intern ("face");
2585 pargs
[2] = intern ("minibuffer-prompt");
2586 args
[0] = Fpropertize (3, pargs
);
2591 if (minibuffer_auto_raise
)
2593 Lisp_Object mini_frame
;
2595 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2597 Fraise_frame (mini_frame
);
2600 obj
= read_filtered_event (1, 0, 0, 0);
2601 cursor_in_echo_area
= 0;
2602 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2605 key
= Fmake_vector (make_number (1), obj
);
2606 def
= Flookup_key (map
, key
, Qt
);
2608 if (EQ (def
, intern ("skip")))
2613 else if (EQ (def
, intern ("act")))
2618 else if (EQ (def
, intern ("recenter")))
2624 else if (EQ (def
, intern ("quit")))
2626 /* We want to exit this command for exit-prefix,
2627 and this is the only way to do it. */
2628 else if (EQ (def
, intern ("exit-prefix")))
2633 /* If we don't clear this, then the next call to read_char will
2634 return quit_char again, and we'll enter an infinite loop. */
2639 if (EQ (xprompt
, prompt
))
2641 args
[0] = build_string ("Please answer y or n. ");
2643 xprompt
= Fconcat (2, args
);
2648 if (! noninteractive
)
2650 cursor_in_echo_area
= -1;
2651 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2655 unbind_to (count
, Qnil
);
2656 return answer
? Qt
: Qnil
;
2659 /* This is how C code calls `yes-or-no-p' and allows the user
2662 Anything that calls this function must protect from GC! */
2665 do_yes_or_no_p (prompt
)
2668 return call1 (intern ("yes-or-no-p"), prompt
);
2671 /* Anything that calls this function must protect from GC! */
2673 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2674 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2675 Takes one argument, which is the string to display to ask the question.
2676 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2677 The user must confirm the answer with RET,
2678 and can edit it until it has been confirmed.
2680 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2681 is nil, and `use-dialog-box' is non-nil. */)
2685 register Lisp_Object ans
;
2686 Lisp_Object args
[2];
2687 struct gcpro gcpro1
;
2689 CHECK_STRING (prompt
);
2692 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2696 Lisp_Object pane
, menu
, obj
;
2697 redisplay_preserve_echo_area (4);
2698 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2699 Fcons (Fcons (build_string ("No"), Qnil
),
2702 menu
= Fcons (prompt
, pane
);
2703 obj
= Fx_popup_dialog (Qt
, menu
);
2707 #endif /* HAVE_MENUS */
2710 args
[1] = build_string ("(yes or no) ");
2711 prompt
= Fconcat (2, args
);
2717 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2718 Qyes_or_no_p_history
, Qnil
,
2720 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2725 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2733 message ("Please answer yes or no.");
2734 Fsleep_for (make_number (2), Qnil
);
2738 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2739 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2741 Each of the three load averages is multiplied by 100, then converted
2744 When USE-FLOATS is non-nil, floats will be used instead of integers.
2745 These floats are not multiplied by 100.
2747 If the 5-minute or 15-minute load averages are not available, return a
2748 shortened list, containing only those averages which are available.
2750 An error is thrown if the load average can't be obtained. In some
2751 cases making it work would require Emacs being installed setuid or
2752 setgid so that it can read kernel information, and that usually isn't
2755 Lisp_Object use_floats
;
2758 int loads
= getloadavg (load_ave
, 3);
2759 Lisp_Object ret
= Qnil
;
2762 error ("load-average not implemented for this operating system");
2766 Lisp_Object load
= (NILP (use_floats
) ?
2767 make_number ((int) (100.0 * load_ave
[loads
]))
2768 : make_float (load_ave
[loads
]));
2769 ret
= Fcons (load
, ret
);
2775 Lisp_Object Vfeatures
, Qsubfeatures
;
2776 extern Lisp_Object Vafter_load_alist
;
2778 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2779 doc
: /* Returns t if FEATURE is present in this Emacs.
2781 Use this to conditionalize execution of lisp code based on the
2782 presence or absence of emacs or environment extensions.
2783 Use `provide' to declare that a feature is available. This function
2784 looks at the value of the variable `features'. The optional argument
2785 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2786 (feature
, subfeature
)
2787 Lisp_Object feature
, subfeature
;
2789 register Lisp_Object tem
;
2790 CHECK_SYMBOL (feature
);
2791 tem
= Fmemq (feature
, Vfeatures
);
2792 if (!NILP (tem
) && !NILP (subfeature
))
2793 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2794 return (NILP (tem
)) ? Qnil
: Qt
;
2797 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2798 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2799 The optional argument SUBFEATURES should be a list of symbols listing
2800 particular subfeatures supported in this version of FEATURE. */)
2801 (feature
, subfeatures
)
2802 Lisp_Object feature
, subfeatures
;
2804 register Lisp_Object tem
;
2805 CHECK_SYMBOL (feature
);
2806 CHECK_LIST (subfeatures
);
2807 if (!NILP (Vautoload_queue
))
2808 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2809 tem
= Fmemq (feature
, Vfeatures
);
2811 Vfeatures
= Fcons (feature
, Vfeatures
);
2812 if (!NILP (subfeatures
))
2813 Fput (feature
, Qsubfeatures
, subfeatures
);
2814 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2816 /* Run any load-hooks for this file. */
2817 tem
= Fassq (feature
, Vafter_load_alist
);
2819 Fprogn (XCDR (tem
));
2824 /* `require' and its subroutines. */
2826 /* List of features currently being require'd, innermost first. */
2828 Lisp_Object require_nesting_list
;
2831 require_unwind (old_value
)
2832 Lisp_Object old_value
;
2834 return require_nesting_list
= old_value
;
2837 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2838 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2839 If FEATURE is not a member of the list `features', then the feature
2840 is not loaded; so load the file FILENAME.
2841 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2842 and `load' will try to load this name appended with the suffix `.elc' or
2843 `.el', in that order. The name without appended suffix will not be used.
2844 If the optional third argument NOERROR is non-nil,
2845 then return nil if the file is not found instead of signaling an error.
2846 Normally the return value is FEATURE.
2847 The normal messages at start and end of loading FILENAME are suppressed. */)
2848 (feature
, filename
, noerror
)
2849 Lisp_Object feature
, filename
, noerror
;
2851 register Lisp_Object tem
;
2852 struct gcpro gcpro1
, gcpro2
;
2854 CHECK_SYMBOL (feature
);
2856 tem
= Fmemq (feature
, Vfeatures
);
2860 int count
= SPECPDL_INDEX ();
2863 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2865 /* This is to make sure that loadup.el gives a clear picture
2866 of what files are preloaded and when. */
2867 if (! NILP (Vpurify_flag
))
2868 error ("(require %s) while preparing to dump",
2869 SDATA (SYMBOL_NAME (feature
)));
2871 /* A certain amount of recursive `require' is legitimate,
2872 but if we require the same feature recursively 3 times,
2874 tem
= require_nesting_list
;
2875 while (! NILP (tem
))
2877 if (! NILP (Fequal (feature
, XCAR (tem
))))
2882 error ("Recursive `require' for feature `%s'",
2883 SDATA (SYMBOL_NAME (feature
)));
2885 /* Update the list for any nested `require's that occur. */
2886 record_unwind_protect (require_unwind
, require_nesting_list
);
2887 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2889 /* Value saved here is to be restored into Vautoload_queue */
2890 record_unwind_protect (un_autoload
, Vautoload_queue
);
2891 Vautoload_queue
= Qt
;
2893 /* Load the file. */
2894 GCPRO2 (feature
, filename
);
2895 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2896 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2899 /* If load failed entirely, return nil. */
2901 return unbind_to (count
, Qnil
);
2903 tem
= Fmemq (feature
, Vfeatures
);
2905 error ("Required feature `%s' was not provided",
2906 SDATA (SYMBOL_NAME (feature
)));
2908 /* Once loading finishes, don't undo it. */
2909 Vautoload_queue
= Qt
;
2910 feature
= unbind_to (count
, feature
);
2916 /* Primitives for work of the "widget" library.
2917 In an ideal world, this section would not have been necessary.
2918 However, lisp function calls being as slow as they are, it turns
2919 out that some functions in the widget library (wid-edit.el) are the
2920 bottleneck of Widget operation. Here is their translation to C,
2921 for the sole reason of efficiency. */
2923 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2924 doc
: /* Return non-nil if PLIST has the property PROP.
2925 PLIST is a property list, which is a list of the form
2926 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2927 Unlike `plist-get', this allows you to distinguish between a missing
2928 property and a property with the value nil.
2929 The value is actually the tail of PLIST whose car is PROP. */)
2931 Lisp_Object plist
, prop
;
2933 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2936 plist
= XCDR (plist
);
2937 plist
= CDR (plist
);
2942 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2943 doc
: /* In WIDGET, set PROPERTY to VALUE.
2944 The value can later be retrieved with `widget-get'. */)
2945 (widget
, property
, value
)
2946 Lisp_Object widget
, property
, value
;
2948 CHECK_CONS (widget
);
2949 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2953 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2954 doc
: /* In WIDGET, get the value of PROPERTY.
2955 The value could either be specified when the widget was created, or
2956 later with `widget-put'. */)
2958 Lisp_Object widget
, property
;
2966 CHECK_CONS (widget
);
2967 tmp
= Fplist_member (XCDR (widget
), property
);
2973 tmp
= XCAR (widget
);
2976 widget
= Fget (tmp
, Qwidget_type
);
2980 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2981 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2982 ARGS are passed as extra arguments to the function.
2983 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2988 /* This function can GC. */
2989 Lisp_Object newargs
[3];
2990 struct gcpro gcpro1
, gcpro2
;
2993 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2994 newargs
[1] = args
[0];
2995 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2996 GCPRO2 (newargs
[0], newargs
[2]);
2997 result
= Fapply (3, newargs
);
3002 #ifdef HAVE_LANGINFO_CODESET
3003 #include <langinfo.h>
3006 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3007 doc
: /* Access locale data ITEM for the current C locale, if available.
3008 ITEM should be one of the following:
3010 `codeset', returning the character set as a string (locale item CODESET);
3012 `days', returning a 7-element vector of day names (locale items DAY_n);
3014 `months', returning a 12-element vector of month names (locale items MON_n);
3016 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3017 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3019 If the system can't provide such information through a call to
3020 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3022 See also Info node `(libc)Locales'.
3024 The data read from the system are decoded using `locale-coding-system'. */)
3029 #ifdef HAVE_LANGINFO_CODESET
3031 if (EQ (item
, Qcodeset
))
3033 str
= nl_langinfo (CODESET
);
3034 return build_string (str
);
3037 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3039 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3040 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3042 synchronize_system_time_locale ();
3043 for (i
= 0; i
< 7; i
++)
3045 str
= nl_langinfo (days
[i
]);
3046 val
= make_unibyte_string (str
, strlen (str
));
3047 /* Fixme: Is this coding system necessarily right, even if
3048 it is consistent with CODESET? If not, what to do? */
3049 Faset (v
, make_number (i
),
3050 code_convert_string_norecord (val
, Vlocale_coding_system
,
3057 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3059 struct Lisp_Vector
*p
= allocate_vector (12);
3060 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3061 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3063 synchronize_system_time_locale ();
3064 for (i
= 0; i
< 12; i
++)
3066 str
= nl_langinfo (months
[i
]);
3067 val
= make_unibyte_string (str
, strlen (str
));
3069 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3071 XSETVECTOR (val
, p
);
3075 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3076 but is in the locale files. This could be used by ps-print. */
3078 else if (EQ (item
, Qpaper
))
3080 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3081 make_number (nl_langinfo (PAPER_HEIGHT
)));
3083 #endif /* PAPER_WIDTH */
3084 #endif /* HAVE_LANGINFO_CODESET*/
3088 /* base64 encode/decode functions (RFC 2045).
3089 Based on code from GNU recode. */
3091 #define MIME_LINE_LENGTH 76
3093 #define IS_ASCII(Character) \
3095 #define IS_BASE64(Character) \
3096 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3097 #define IS_BASE64_IGNORABLE(Character) \
3098 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3099 || (Character) == '\f' || (Character) == '\r')
3101 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3102 character or return retval if there are no characters left to
3104 #define READ_QUADRUPLET_BYTE(retval) \
3109 if (nchars_return) \
3110 *nchars_return = nchars; \
3115 while (IS_BASE64_IGNORABLE (c))
3117 /* Don't use alloca for regions larger than this, lest we overflow
3119 #define MAX_ALLOCA 16*1024
3121 /* Table of characters coding the 64 values. */
3122 static char base64_value_to_char
[64] =
3124 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3125 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3126 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3127 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3128 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3129 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3130 '8', '9', '+', '/' /* 60-63 */
3133 /* Table of base64 values for first 128 characters. */
3134 static short base64_char_to_value
[128] =
3136 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3137 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3138 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3139 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3140 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3141 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3142 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3143 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3144 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3145 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3146 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3147 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3148 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3151 /* The following diagram shows the logical steps by which three octets
3152 get transformed into four base64 characters.
3154 .--------. .--------. .--------.
3155 |aaaaaabb| |bbbbcccc| |ccdddddd|
3156 `--------' `--------' `--------'
3158 .--------+--------+--------+--------.
3159 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3160 `--------+--------+--------+--------'
3162 .--------+--------+--------+--------.
3163 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3164 `--------+--------+--------+--------'
3166 The octets are divided into 6 bit chunks, which are then encoded into
3167 base64 characters. */
3170 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3171 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3173 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3175 doc
: /* Base64-encode the region between BEG and END.
3176 Return the length of the encoded text.
3177 Optional third argument NO-LINE-BREAK means do not break long lines
3178 into shorter lines. */)
3179 (beg
, end
, no_line_break
)
3180 Lisp_Object beg
, end
, no_line_break
;
3183 int allength
, length
;
3184 int ibeg
, iend
, encoded_length
;
3187 validate_region (&beg
, &end
);
3189 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3190 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3191 move_gap_both (XFASTINT (beg
), ibeg
);
3193 /* We need to allocate enough room for encoding the text.
3194 We need 33 1/3% more space, plus a newline every 76
3195 characters, and then we round up. */
3196 length
= iend
- ibeg
;
3197 allength
= length
+ length
/3 + 1;
3198 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3200 if (allength
<= MAX_ALLOCA
)
3201 encoded
= (char *) alloca (allength
);
3203 encoded
= (char *) xmalloc (allength
);
3204 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3205 NILP (no_line_break
),
3206 !NILP (current_buffer
->enable_multibyte_characters
));
3207 if (encoded_length
> allength
)
3210 if (encoded_length
< 0)
3212 /* The encoding wasn't possible. */
3213 if (length
> MAX_ALLOCA
)
3215 error ("Multibyte character in data for base64 encoding");
3218 /* Now we have encoded the region, so we insert the new contents
3219 and delete the old. (Insert first in order to preserve markers.) */
3220 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3221 insert (encoded
, encoded_length
);
3222 if (allength
> MAX_ALLOCA
)
3224 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3226 /* If point was outside of the region, restore it exactly; else just
3227 move to the beginning of the region. */
3228 if (old_pos
>= XFASTINT (end
))
3229 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3230 else if (old_pos
> XFASTINT (beg
))
3231 old_pos
= XFASTINT (beg
);
3234 /* We return the length of the encoded text. */
3235 return make_number (encoded_length
);
3238 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3240 doc
: /* Base64-encode STRING and return the result.
3241 Optional second argument NO-LINE-BREAK means do not break long lines
3242 into shorter lines. */)
3243 (string
, no_line_break
)
3244 Lisp_Object string
, no_line_break
;
3246 int allength
, length
, encoded_length
;
3248 Lisp_Object encoded_string
;
3250 CHECK_STRING (string
);
3252 /* We need to allocate enough room for encoding the text.
3253 We need 33 1/3% more space, plus a newline every 76
3254 characters, and then we round up. */
3255 length
= SBYTES (string
);
3256 allength
= length
+ length
/3 + 1;
3257 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3259 /* We need to allocate enough room for decoding the text. */
3260 if (allength
<= MAX_ALLOCA
)
3261 encoded
= (char *) alloca (allength
);
3263 encoded
= (char *) xmalloc (allength
);
3265 encoded_length
= base64_encode_1 (SDATA (string
),
3266 encoded
, length
, NILP (no_line_break
),
3267 STRING_MULTIBYTE (string
));
3268 if (encoded_length
> allength
)
3271 if (encoded_length
< 0)
3273 /* The encoding wasn't possible. */
3274 if (length
> MAX_ALLOCA
)
3276 error ("Multibyte character in data for base64 encoding");
3279 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3280 if (allength
> MAX_ALLOCA
)
3283 return encoded_string
;
3287 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3294 int counter
= 0, i
= 0;
3304 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3305 if (CHAR_BYTE8_P (c
))
3306 c
= CHAR_TO_BYTE8 (c
);
3314 /* Wrap line every 76 characters. */
3318 if (counter
< MIME_LINE_LENGTH
/ 4)
3327 /* Process first byte of a triplet. */
3329 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3330 value
= (0x03 & c
) << 4;
3332 /* Process second byte of a triplet. */
3336 *e
++ = base64_value_to_char
[value
];
3344 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3345 if (CHAR_BYTE8_P (c
))
3346 c
= CHAR_TO_BYTE8 (c
);
3354 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3355 value
= (0x0f & c
) << 2;
3357 /* Process third byte of a triplet. */
3361 *e
++ = base64_value_to_char
[value
];
3368 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3369 if (CHAR_BYTE8_P (c
))
3370 c
= CHAR_TO_BYTE8 (c
);
3378 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3379 *e
++ = base64_value_to_char
[0x3f & c
];
3386 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3388 doc
: /* Base64-decode the region between BEG and END.
3389 Return the length of the decoded text.
3390 If the region can't be decoded, signal an error and don't modify the buffer. */)
3392 Lisp_Object beg
, end
;
3394 int ibeg
, iend
, length
, allength
;
3399 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3401 validate_region (&beg
, &end
);
3403 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3404 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3406 length
= iend
- ibeg
;
3408 /* We need to allocate enough room for decoding the text. If we are
3409 working on a multibyte buffer, each decoded code may occupy at
3411 allength
= multibyte
? length
* 2 : length
;
3412 if (allength
<= MAX_ALLOCA
)
3413 decoded
= (char *) alloca (allength
);
3415 decoded
= (char *) xmalloc (allength
);
3417 move_gap_both (XFASTINT (beg
), ibeg
);
3418 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3419 multibyte
, &inserted_chars
);
3420 if (decoded_length
> allength
)
3423 if (decoded_length
< 0)
3425 /* The decoding wasn't possible. */
3426 if (allength
> MAX_ALLOCA
)
3428 error ("Invalid base64 data");
3431 /* Now we have decoded the region, so we insert the new contents
3432 and delete the old. (Insert first in order to preserve markers.) */
3433 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3434 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3435 if (allength
> MAX_ALLOCA
)
3437 /* Delete the original text. */
3438 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3439 iend
+ decoded_length
, 1);
3441 /* If point was outside of the region, restore it exactly; else just
3442 move to the beginning of the region. */
3443 if (old_pos
>= XFASTINT (end
))
3444 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3445 else if (old_pos
> XFASTINT (beg
))
3446 old_pos
= XFASTINT (beg
);
3447 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3449 return make_number (inserted_chars
);
3452 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3454 doc
: /* Base64-decode STRING and return the result. */)
3459 int length
, decoded_length
;
3460 Lisp_Object decoded_string
;
3462 CHECK_STRING (string
);
3464 length
= SBYTES (string
);
3465 /* We need to allocate enough room for decoding the text. */
3466 if (length
<= MAX_ALLOCA
)
3467 decoded
= (char *) alloca (length
);
3469 decoded
= (char *) xmalloc (length
);
3471 /* The decoded result should be unibyte. */
3472 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3474 if (decoded_length
> length
)
3476 else if (decoded_length
>= 0)
3477 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3479 decoded_string
= Qnil
;
3481 if (length
> MAX_ALLOCA
)
3483 if (!STRINGP (decoded_string
))
3484 error ("Invalid base64 data");
3486 return decoded_string
;
3489 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3490 MULTIBYTE is nonzero, the decoded result should be in multibyte
3491 form. If NCHARS_RETRUN is not NULL, store the number of produced
3492 characters in *NCHARS_RETURN. */
3495 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3505 unsigned long value
;
3510 /* Process first byte of a quadruplet. */
3512 READ_QUADRUPLET_BYTE (e
-to
);
3516 value
= base64_char_to_value
[c
] << 18;
3518 /* Process second byte of a quadruplet. */
3520 READ_QUADRUPLET_BYTE (-1);
3524 value
|= base64_char_to_value
[c
] << 12;
3526 c
= (unsigned char) (value
>> 16);
3527 if (multibyte
&& c
>= 128)
3528 e
+= BYTE8_STRING (c
, e
);
3533 /* Process third byte of a quadruplet. */
3535 READ_QUADRUPLET_BYTE (-1);
3539 READ_QUADRUPLET_BYTE (-1);
3548 value
|= base64_char_to_value
[c
] << 6;
3550 c
= (unsigned char) (0xff & value
>> 8);
3551 if (multibyte
&& c
>= 128)
3552 e
+= BYTE8_STRING (c
, e
);
3557 /* Process fourth byte of a quadruplet. */
3559 READ_QUADRUPLET_BYTE (-1);
3566 value
|= base64_char_to_value
[c
];
3568 c
= (unsigned char) (0xff & value
);
3569 if (multibyte
&& c
>= 128)
3570 e
+= BYTE8_STRING (c
, e
);
3579 /***********************************************************************
3581 ***** Hash Tables *****
3583 ***********************************************************************/
3585 /* Implemented by gerd@gnu.org. This hash table implementation was
3586 inspired by CMUCL hash tables. */
3590 1. For small tables, association lists are probably faster than
3591 hash tables because they have lower overhead.
3593 For uses of hash tables where the O(1) behavior of table
3594 operations is not a requirement, it might therefore be a good idea
3595 not to hash. Instead, we could just do a linear search in the
3596 key_and_value vector of the hash table. This could be done
3597 if a `:linear-search t' argument is given to make-hash-table. */
3600 /* The list of all weak hash tables. Don't staticpro this one. */
3602 Lisp_Object Vweak_hash_tables
;
3604 /* Various symbols. */
3606 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3607 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3608 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3610 /* Function prototypes. */
3612 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3613 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3614 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3615 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3616 Lisp_Object
, unsigned));
3617 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3618 Lisp_Object
, unsigned));
3619 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3620 unsigned, Lisp_Object
, unsigned));
3621 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3622 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3623 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3624 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3626 static unsigned sxhash_string
P_ ((unsigned char *, int));
3627 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3628 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3629 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3630 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3634 /***********************************************************************
3636 ***********************************************************************/
3638 /* If OBJ is a Lisp hash table, return a pointer to its struct
3639 Lisp_Hash_Table. Otherwise, signal an error. */
3641 static struct Lisp_Hash_Table
*
3642 check_hash_table (obj
)
3645 CHECK_HASH_TABLE (obj
);
3646 return XHASH_TABLE (obj
);
3650 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3654 next_almost_prime (n
)
3667 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3668 which USED[I] is non-zero. If found at index I in ARGS, set
3669 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3670 -1. This function is used to extract a keyword/argument pair from
3671 a DEFUN parameter list. */
3674 get_key_arg (key
, nargs
, args
, used
)
3682 for (i
= 0; i
< nargs
- 1; ++i
)
3683 if (!used
[i
] && EQ (args
[i
], key
))
3698 /* Return a Lisp vector which has the same contents as VEC but has
3699 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3700 vector that are not copied from VEC are set to INIT. */
3703 larger_vector (vec
, new_size
, init
)
3708 struct Lisp_Vector
*v
;
3711 xassert (VECTORP (vec
));
3712 old_size
= XVECTOR (vec
)->size
;
3713 xassert (new_size
>= old_size
);
3715 v
= allocate_vector (new_size
);
3716 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3717 old_size
* sizeof *v
->contents
);
3718 for (i
= old_size
; i
< new_size
; ++i
)
3719 v
->contents
[i
] = init
;
3720 XSETVECTOR (vec
, v
);
3725 /***********************************************************************
3727 ***********************************************************************/
3729 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3730 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3731 KEY2 are the same. */
3734 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3735 struct Lisp_Hash_Table
*h
;
3736 Lisp_Object key1
, key2
;
3737 unsigned hash1
, hash2
;
3739 return (FLOATP (key1
)
3741 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3745 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3746 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3747 KEY2 are the same. */
3750 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3751 struct Lisp_Hash_Table
*h
;
3752 Lisp_Object key1
, key2
;
3753 unsigned hash1
, hash2
;
3755 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3759 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3760 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3761 if KEY1 and KEY2 are the same. */
3764 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3765 struct Lisp_Hash_Table
*h
;
3766 Lisp_Object key1
, key2
;
3767 unsigned hash1
, hash2
;
3771 Lisp_Object args
[3];
3773 args
[0] = h
->user_cmp_function
;
3776 return !NILP (Ffuncall (3, args
));
3783 /* Value is a hash code for KEY for use in hash table H which uses
3784 `eq' to compare keys. The hash code returned is guaranteed to fit
3785 in a Lisp integer. */
3789 struct Lisp_Hash_Table
*h
;
3792 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3793 xassert ((hash
& ~INTMASK
) == 0);
3798 /* Value is a hash code for KEY for use in hash table H which uses
3799 `eql' to compare keys. The hash code returned is guaranteed to fit
3800 in a Lisp integer. */
3804 struct Lisp_Hash_Table
*h
;
3809 hash
= sxhash (key
, 0);
3811 hash
= XUINT (key
) ^ XGCTYPE (key
);
3812 xassert ((hash
& ~INTMASK
) == 0);
3817 /* Value is a hash code for KEY for use in hash table H which uses
3818 `equal' to compare keys. The hash code returned is guaranteed to fit
3819 in a Lisp integer. */
3822 hashfn_equal (h
, key
)
3823 struct Lisp_Hash_Table
*h
;
3826 unsigned hash
= sxhash (key
, 0);
3827 xassert ((hash
& ~INTMASK
) == 0);
3832 /* Value is a hash code for KEY for use in hash table H which uses as
3833 user-defined function to compare keys. The hash code returned is
3834 guaranteed to fit in a Lisp integer. */
3837 hashfn_user_defined (h
, key
)
3838 struct Lisp_Hash_Table
*h
;
3841 Lisp_Object args
[2], hash
;
3843 args
[0] = h
->user_hash_function
;
3845 hash
= Ffuncall (2, args
);
3846 if (!INTEGERP (hash
))
3848 list2 (build_string ("Invalid hash code returned from \
3849 user-supplied hash function"),
3851 return XUINT (hash
);
3855 /* Create and initialize a new hash table.
3857 TEST specifies the test the hash table will use to compare keys.
3858 It must be either one of the predefined tests `eq', `eql' or
3859 `equal' or a symbol denoting a user-defined test named TEST with
3860 test and hash functions USER_TEST and USER_HASH.
3862 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3864 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3865 new size when it becomes full is computed by adding REHASH_SIZE to
3866 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3867 table's new size is computed by multiplying its old size with
3870 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3871 be resized when the ratio of (number of entries in the table) /
3872 (table size) is >= REHASH_THRESHOLD.
3874 WEAK specifies the weakness of the table. If non-nil, it must be
3875 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3878 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3879 user_test
, user_hash
)
3880 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3881 Lisp_Object user_test
, user_hash
;
3883 struct Lisp_Hash_Table
*h
;
3885 int index_size
, i
, sz
;
3887 /* Preconditions. */
3888 xassert (SYMBOLP (test
));
3889 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3890 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3891 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3892 xassert (FLOATP (rehash_threshold
)
3893 && XFLOATINT (rehash_threshold
) > 0
3894 && XFLOATINT (rehash_threshold
) <= 1.0);
3896 if (XFASTINT (size
) == 0)
3897 size
= make_number (1);
3899 /* Allocate a table and initialize it. */
3900 h
= allocate_hash_table ();
3902 /* Initialize hash table slots. */
3903 sz
= XFASTINT (size
);
3906 if (EQ (test
, Qeql
))
3908 h
->cmpfn
= cmpfn_eql
;
3909 h
->hashfn
= hashfn_eql
;
3911 else if (EQ (test
, Qeq
))
3914 h
->hashfn
= hashfn_eq
;
3916 else if (EQ (test
, Qequal
))
3918 h
->cmpfn
= cmpfn_equal
;
3919 h
->hashfn
= hashfn_equal
;
3923 h
->user_cmp_function
= user_test
;
3924 h
->user_hash_function
= user_hash
;
3925 h
->cmpfn
= cmpfn_user_defined
;
3926 h
->hashfn
= hashfn_user_defined
;
3930 h
->rehash_threshold
= rehash_threshold
;
3931 h
->rehash_size
= rehash_size
;
3932 h
->count
= make_number (0);
3933 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3934 h
->hash
= Fmake_vector (size
, Qnil
);
3935 h
->next
= Fmake_vector (size
, Qnil
);
3936 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3937 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3938 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3940 /* Set up the free list. */
3941 for (i
= 0; i
< sz
- 1; ++i
)
3942 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3943 h
->next_free
= make_number (0);
3945 XSET_HASH_TABLE (table
, h
);
3946 xassert (HASH_TABLE_P (table
));
3947 xassert (XHASH_TABLE (table
) == h
);
3949 /* Maybe add this hash table to the list of all weak hash tables. */
3951 h
->next_weak
= Qnil
;
3954 h
->next_weak
= Vweak_hash_tables
;
3955 Vweak_hash_tables
= table
;
3962 /* Return a copy of hash table H1. Keys and values are not copied,
3963 only the table itself is. */
3966 copy_hash_table (h1
)
3967 struct Lisp_Hash_Table
*h1
;
3970 struct Lisp_Hash_Table
*h2
;
3971 struct Lisp_Vector
*next
;
3973 h2
= allocate_hash_table ();
3974 next
= h2
->vec_next
;
3975 bcopy (h1
, h2
, sizeof *h2
);
3976 h2
->vec_next
= next
;
3977 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3978 h2
->hash
= Fcopy_sequence (h1
->hash
);
3979 h2
->next
= Fcopy_sequence (h1
->next
);
3980 h2
->index
= Fcopy_sequence (h1
->index
);
3981 XSET_HASH_TABLE (table
, h2
);
3983 /* Maybe add this hash table to the list of all weak hash tables. */
3984 if (!NILP (h2
->weak
))
3986 h2
->next_weak
= Vweak_hash_tables
;
3987 Vweak_hash_tables
= table
;
3994 /* Resize hash table H if it's too full. If H cannot be resized
3995 because it's already too large, throw an error. */
3998 maybe_resize_hash_table (h
)
3999 struct Lisp_Hash_Table
*h
;
4001 if (NILP (h
->next_free
))
4003 int old_size
= HASH_TABLE_SIZE (h
);
4004 int i
, new_size
, index_size
;
4006 if (INTEGERP (h
->rehash_size
))
4007 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4009 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4010 new_size
= max (old_size
+ 1, new_size
);
4011 index_size
= next_almost_prime ((int)
4013 / XFLOATINT (h
->rehash_threshold
)));
4014 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4015 error ("Hash table too large to resize");
4017 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4018 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4019 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4020 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4022 /* Update the free list. Do it so that new entries are added at
4023 the end of the free list. This makes some operations like
4025 for (i
= old_size
; i
< new_size
- 1; ++i
)
4026 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4028 if (!NILP (h
->next_free
))
4030 Lisp_Object last
, next
;
4032 last
= h
->next_free
;
4033 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4037 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4040 XSETFASTINT (h
->next_free
, old_size
);
4043 for (i
= 0; i
< old_size
; ++i
)
4044 if (!NILP (HASH_HASH (h
, i
)))
4046 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4047 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4048 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4049 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4055 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4056 the hash code of KEY. Value is the index of the entry in H
4057 matching KEY, or -1 if not found. */
4060 hash_lookup (h
, key
, hash
)
4061 struct Lisp_Hash_Table
*h
;
4066 int start_of_bucket
;
4069 hash_code
= h
->hashfn (h
, key
);
4073 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4074 idx
= HASH_INDEX (h
, start_of_bucket
);
4076 /* We need not gcpro idx since it's either an integer or nil. */
4079 int i
= XFASTINT (idx
);
4080 if (EQ (key
, HASH_KEY (h
, i
))
4082 && h
->cmpfn (h
, key
, hash_code
,
4083 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4085 idx
= HASH_NEXT (h
, i
);
4088 return NILP (idx
) ? -1 : XFASTINT (idx
);
4092 /* Put an entry into hash table H that associates KEY with VALUE.
4093 HASH is a previously computed hash code of KEY.
4094 Value is the index of the entry in H matching KEY. */
4097 hash_put (h
, key
, value
, hash
)
4098 struct Lisp_Hash_Table
*h
;
4099 Lisp_Object key
, value
;
4102 int start_of_bucket
, i
;
4104 xassert ((hash
& ~INTMASK
) == 0);
4106 /* Increment count after resizing because resizing may fail. */
4107 maybe_resize_hash_table (h
);
4108 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4110 /* Store key/value in the key_and_value vector. */
4111 i
= XFASTINT (h
->next_free
);
4112 h
->next_free
= HASH_NEXT (h
, i
);
4113 HASH_KEY (h
, i
) = key
;
4114 HASH_VALUE (h
, i
) = value
;
4116 /* Remember its hash code. */
4117 HASH_HASH (h
, i
) = make_number (hash
);
4119 /* Add new entry to its collision chain. */
4120 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4121 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4122 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4127 /* Remove the entry matching KEY from hash table H, if there is one. */
4130 hash_remove (h
, key
)
4131 struct Lisp_Hash_Table
*h
;
4135 int start_of_bucket
;
4136 Lisp_Object idx
, prev
;
4138 hash_code
= h
->hashfn (h
, key
);
4139 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4140 idx
= HASH_INDEX (h
, start_of_bucket
);
4143 /* We need not gcpro idx, prev since they're either integers or nil. */
4146 int i
= XFASTINT (idx
);
4148 if (EQ (key
, HASH_KEY (h
, i
))
4150 && h
->cmpfn (h
, key
, hash_code
,
4151 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4153 /* Take entry out of collision chain. */
4155 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4157 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4159 /* Clear slots in key_and_value and add the slots to
4161 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4162 HASH_NEXT (h
, i
) = h
->next_free
;
4163 h
->next_free
= make_number (i
);
4164 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4165 xassert (XINT (h
->count
) >= 0);
4171 idx
= HASH_NEXT (h
, i
);
4177 /* Clear hash table H. */
4181 struct Lisp_Hash_Table
*h
;
4183 if (XFASTINT (h
->count
) > 0)
4185 int i
, size
= HASH_TABLE_SIZE (h
);
4187 for (i
= 0; i
< size
; ++i
)
4189 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4190 HASH_KEY (h
, i
) = Qnil
;
4191 HASH_VALUE (h
, i
) = Qnil
;
4192 HASH_HASH (h
, i
) = Qnil
;
4195 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4196 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4198 h
->next_free
= make_number (0);
4199 h
->count
= make_number (0);
4205 /************************************************************************
4207 ************************************************************************/
4209 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4210 entries from the table that don't survive the current GC.
4211 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4212 non-zero if anything was marked. */
4215 sweep_weak_table (h
, remove_entries_p
)
4216 struct Lisp_Hash_Table
*h
;
4217 int remove_entries_p
;
4219 int bucket
, n
, marked
;
4221 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4224 for (bucket
= 0; bucket
< n
; ++bucket
)
4226 Lisp_Object idx
, next
, prev
;
4228 /* Follow collision chain, removing entries that
4229 don't survive this garbage collection. */
4231 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4233 int i
= XFASTINT (idx
);
4234 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4235 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4238 if (EQ (h
->weak
, Qkey
))
4239 remove_p
= !key_known_to_survive_p
;
4240 else if (EQ (h
->weak
, Qvalue
))
4241 remove_p
= !value_known_to_survive_p
;
4242 else if (EQ (h
->weak
, Qkey_or_value
))
4243 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4244 else if (EQ (h
->weak
, Qkey_and_value
))
4245 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4249 next
= HASH_NEXT (h
, i
);
4251 if (remove_entries_p
)
4255 /* Take out of collision chain. */
4257 HASH_INDEX (h
, bucket
) = next
;
4259 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4261 /* Add to free list. */
4262 HASH_NEXT (h
, i
) = h
->next_free
;
4265 /* Clear key, value, and hash. */
4266 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4267 HASH_HASH (h
, i
) = Qnil
;
4269 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4276 /* Make sure key and value survive. */
4277 if (!key_known_to_survive_p
)
4279 mark_object (HASH_KEY (h
, i
));
4283 if (!value_known_to_survive_p
)
4285 mark_object (HASH_VALUE (h
, i
));
4296 /* Remove elements from weak hash tables that don't survive the
4297 current garbage collection. Remove weak tables that don't survive
4298 from Vweak_hash_tables. Called from gc_sweep. */
4301 sweep_weak_hash_tables ()
4303 Lisp_Object table
, used
, next
;
4304 struct Lisp_Hash_Table
*h
;
4307 /* Mark all keys and values that are in use. Keep on marking until
4308 there is no more change. This is necessary for cases like
4309 value-weak table A containing an entry X -> Y, where Y is used in a
4310 key-weak table B, Z -> Y. If B comes after A in the list of weak
4311 tables, X -> Y might be removed from A, although when looking at B
4312 one finds that it shouldn't. */
4316 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4318 h
= XHASH_TABLE (table
);
4319 if (h
->size
& ARRAY_MARK_FLAG
)
4320 marked
|= sweep_weak_table (h
, 0);
4325 /* Remove tables and entries that aren't used. */
4326 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4328 h
= XHASH_TABLE (table
);
4329 next
= h
->next_weak
;
4331 if (h
->size
& ARRAY_MARK_FLAG
)
4333 /* TABLE is marked as used. Sweep its contents. */
4334 if (XFASTINT (h
->count
) > 0)
4335 sweep_weak_table (h
, 1);
4337 /* Add table to the list of used weak hash tables. */
4338 h
->next_weak
= used
;
4343 Vweak_hash_tables
= used
;
4348 /***********************************************************************
4349 Hash Code Computation
4350 ***********************************************************************/
4352 /* Maximum depth up to which to dive into Lisp structures. */
4354 #define SXHASH_MAX_DEPTH 3
4356 /* Maximum length up to which to take list and vector elements into
4359 #define SXHASH_MAX_LEN 7
4361 /* Combine two integers X and Y for hashing. */
4363 #define SXHASH_COMBINE(X, Y) \
4364 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4368 /* Return a hash for string PTR which has length LEN. The hash
4369 code returned is guaranteed to fit in a Lisp integer. */
4372 sxhash_string (ptr
, len
)
4376 unsigned char *p
= ptr
;
4377 unsigned char *end
= p
+ len
;
4386 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4389 return hash
& INTMASK
;
4393 /* Return a hash for list LIST. DEPTH is the current depth in the
4394 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4397 sxhash_list (list
, depth
)
4404 if (depth
< SXHASH_MAX_DEPTH
)
4406 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4407 list
= XCDR (list
), ++i
)
4409 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4410 hash
= SXHASH_COMBINE (hash
, hash2
);
4417 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4418 the Lisp structure. */
4421 sxhash_vector (vec
, depth
)
4425 unsigned hash
= XVECTOR (vec
)->size
;
4428 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4429 for (i
= 0; i
< n
; ++i
)
4431 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4432 hash
= SXHASH_COMBINE (hash
, hash2
);
4439 /* Return a hash for bool-vector VECTOR. */
4442 sxhash_bool_vector (vec
)
4445 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4448 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4449 for (i
= 0; i
< n
; ++i
)
4450 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4456 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4457 structure. Value is an unsigned integer clipped to INTMASK. */
4466 if (depth
> SXHASH_MAX_DEPTH
)
4469 switch (XTYPE (obj
))
4476 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4477 SCHARS (SYMBOL_NAME (obj
)));
4485 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4488 /* This can be everything from a vector to an overlay. */
4489 case Lisp_Vectorlike
:
4491 /* According to the CL HyperSpec, two arrays are equal only if
4492 they are `eq', except for strings and bit-vectors. In
4493 Emacs, this works differently. We have to compare element
4495 hash
= sxhash_vector (obj
, depth
);
4496 else if (BOOL_VECTOR_P (obj
))
4497 hash
= sxhash_bool_vector (obj
);
4499 /* Others are `equal' if they are `eq', so let's take their
4505 hash
= sxhash_list (obj
, depth
);
4510 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4511 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4512 for (hash
= 0; p
< e
; ++p
)
4513 hash
= SXHASH_COMBINE (hash
, *p
);
4521 return hash
& INTMASK
;
4526 /***********************************************************************
4528 ***********************************************************************/
4531 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4532 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4536 unsigned hash
= sxhash (obj
, 0);;
4537 return make_number (hash
);
4541 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4542 doc
: /* Create and return a new hash table.
4544 Arguments are specified as keyword/argument pairs. The following
4545 arguments are defined:
4547 :test TEST -- TEST must be a symbol that specifies how to compare
4548 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4549 `equal'. User-supplied test and hash functions can be specified via
4550 `define-hash-table-test'.
4552 :size SIZE -- A hint as to how many elements will be put in the table.
4555 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4556 fills up. If REHASH-SIZE is an integer, add that many space. If it
4557 is a float, it must be > 1.0, and the new size is computed by
4558 multiplying the old size with that factor. Default is 1.5.
4560 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4561 Resize the hash table when ratio of the number of entries in the
4562 table. Default is 0.8.
4564 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4565 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4566 returned is a weak table. Key/value pairs are removed from a weak
4567 hash table when there are no non-weak references pointing to their
4568 key, value, one of key or value, or both key and value, depending on
4569 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4572 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4577 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4578 Lisp_Object user_test
, user_hash
;
4582 /* The vector `used' is used to keep track of arguments that
4583 have been consumed. */
4584 used
= (char *) alloca (nargs
* sizeof *used
);
4585 bzero (used
, nargs
* sizeof *used
);
4587 /* See if there's a `:test TEST' among the arguments. */
4588 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4589 test
= i
< 0 ? Qeql
: args
[i
];
4590 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4592 /* See if it is a user-defined test. */
4595 prop
= Fget (test
, Qhash_table_test
);
4596 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4597 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4599 user_test
= XCAR (prop
);
4600 user_hash
= XCAR (XCDR (prop
));
4603 user_test
= user_hash
= Qnil
;
4605 /* See if there's a `:size SIZE' argument. */
4606 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4607 size
= i
< 0 ? Qnil
: args
[i
];
4609 size
= make_number (DEFAULT_HASH_SIZE
);
4610 else if (!INTEGERP (size
) || XINT (size
) < 0)
4612 list2 (build_string ("Invalid hash table size"),
4615 /* Look for `:rehash-size SIZE'. */
4616 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4617 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4618 if (!NUMBERP (rehash_size
)
4619 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4620 || XFLOATINT (rehash_size
) <= 1.0)
4622 list2 (build_string ("Invalid hash table rehash size"),
4625 /* Look for `:rehash-threshold THRESHOLD'. */
4626 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4627 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4628 if (!FLOATP (rehash_threshold
)
4629 || XFLOATINT (rehash_threshold
) <= 0.0
4630 || XFLOATINT (rehash_threshold
) > 1.0)
4632 list2 (build_string ("Invalid hash table rehash threshold"),
4635 /* Look for `:weakness WEAK'. */
4636 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4637 weak
= i
< 0 ? Qnil
: args
[i
];
4639 weak
= Qkey_and_value
;
4642 && !EQ (weak
, Qvalue
)
4643 && !EQ (weak
, Qkey_or_value
)
4644 && !EQ (weak
, Qkey_and_value
))
4645 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4648 /* Now, all args should have been used up, or there's a problem. */
4649 for (i
= 0; i
< nargs
; ++i
)
4652 list2 (build_string ("Invalid argument list"), args
[i
]));
4654 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4655 user_test
, user_hash
);
4659 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4660 doc
: /* Return a copy of hash table TABLE. */)
4664 return copy_hash_table (check_hash_table (table
));
4668 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4669 doc
: /* Return the number of elements in TABLE. */)
4673 return check_hash_table (table
)->count
;
4677 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4678 Shash_table_rehash_size
, 1, 1, 0,
4679 doc
: /* Return the current rehash size of TABLE. */)
4683 return check_hash_table (table
)->rehash_size
;
4687 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4688 Shash_table_rehash_threshold
, 1, 1, 0,
4689 doc
: /* Return the current rehash threshold of TABLE. */)
4693 return check_hash_table (table
)->rehash_threshold
;
4697 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4698 doc
: /* Return the size of TABLE.
4699 The size can be used as an argument to `make-hash-table' to create
4700 a hash table than can hold as many elements of TABLE holds
4701 without need for resizing. */)
4705 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4706 return make_number (HASH_TABLE_SIZE (h
));
4710 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4711 doc
: /* Return the test TABLE uses. */)
4715 return check_hash_table (table
)->test
;
4719 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4721 doc
: /* Return the weakness of TABLE. */)
4725 return check_hash_table (table
)->weak
;
4729 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4730 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4734 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4738 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4739 doc
: /* Clear hash table TABLE. */)
4743 hash_clear (check_hash_table (table
));
4748 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4749 doc
: /* Look up KEY in TABLE and return its associated value.
4750 If KEY is not found, return DFLT which defaults to nil. */)
4752 Lisp_Object key
, table
, dflt
;
4754 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4755 int i
= hash_lookup (h
, key
, NULL
);
4756 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4760 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4761 doc
: /* Associate KEY with VALUE in hash table TABLE.
4762 If KEY is already present in table, replace its current value with
4765 Lisp_Object key
, value
, table
;
4767 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4771 i
= hash_lookup (h
, key
, &hash
);
4773 HASH_VALUE (h
, i
) = value
;
4775 hash_put (h
, key
, value
, hash
);
4781 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4782 doc
: /* Remove KEY from TABLE. */)
4784 Lisp_Object key
, table
;
4786 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4787 hash_remove (h
, key
);
4792 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4793 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4794 FUNCTION is called with 2 arguments KEY and VALUE. */)
4796 Lisp_Object function
, table
;
4798 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4799 Lisp_Object args
[3];
4802 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4803 if (!NILP (HASH_HASH (h
, i
)))
4806 args
[1] = HASH_KEY (h
, i
);
4807 args
[2] = HASH_VALUE (h
, i
);
4815 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4816 Sdefine_hash_table_test
, 3, 3, 0,
4817 doc
: /* Define a new hash table test with name NAME, a symbol.
4819 In hash tables created with NAME specified as test, use TEST to
4820 compare keys, and HASH for computing hash codes of keys.
4822 TEST must be a function taking two arguments and returning non-nil if
4823 both arguments are the same. HASH must be a function taking one
4824 argument and return an integer that is the hash code of the argument.
4825 Hash code computation should use the whole value range of integers,
4826 including negative integers. */)
4828 Lisp_Object name
, test
, hash
;
4830 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4835 /************************************************************************
4837 ************************************************************************/
4841 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4842 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4844 A message digest is a cryptographic checksum of a document, and the
4845 algorithm to calculate it is defined in RFC 1321.
4847 The two optional arguments START and END are character positions
4848 specifying for which part of OBJECT the message digest should be
4849 computed. If nil or omitted, the digest is computed for the whole
4852 The MD5 message digest is computed from the result of encoding the
4853 text in a coding system, not directly from the internal Emacs form of
4854 the text. The optional fourth argument CODING-SYSTEM specifies which
4855 coding system to encode the text with. It should be the same coding
4856 system that you used or will use when actually writing the text into a
4859 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4860 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4861 system would be chosen by default for writing this text into a file.
4863 If OBJECT is a string, the most preferred coding system (see the
4864 command `prefer-coding-system') is used.
4866 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4867 guesswork fails. Normally, an error is signaled in such case. */)
4868 (object
, start
, end
, coding_system
, noerror
)
4869 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4871 unsigned char digest
[16];
4872 unsigned char value
[33];
4876 int start_char
= 0, end_char
= 0;
4877 int start_byte
= 0, end_byte
= 0;
4879 register struct buffer
*bp
;
4882 if (STRINGP (object
))
4884 if (NILP (coding_system
))
4886 /* Decide the coding-system to encode the data with. */
4888 if (STRING_MULTIBYTE (object
))
4889 /* use default, we can't guess correct value */
4890 coding_system
= preferred_coding_system ();
4892 coding_system
= Qraw_text
;
4895 if (NILP (Fcoding_system_p (coding_system
)))
4897 /* Invalid coding system. */
4899 if (!NILP (noerror
))
4900 coding_system
= Qraw_text
;
4903 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4906 if (STRING_MULTIBYTE (object
))
4907 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4909 size
= SCHARS (object
);
4910 size_byte
= SBYTES (object
);
4914 CHECK_NUMBER (start
);
4916 start_char
= XINT (start
);
4921 start_byte
= string_char_to_byte (object
, start_char
);
4927 end_byte
= size_byte
;
4933 end_char
= XINT (end
);
4938 end_byte
= string_char_to_byte (object
, end_char
);
4941 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4942 args_out_of_range_3 (object
, make_number (start_char
),
4943 make_number (end_char
));
4947 struct buffer
*prev
= current_buffer
;
4949 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4951 CHECK_BUFFER (object
);
4953 bp
= XBUFFER (object
);
4954 if (bp
!= current_buffer
)
4955 set_buffer_internal (bp
);
4961 CHECK_NUMBER_COERCE_MARKER (start
);
4969 CHECK_NUMBER_COERCE_MARKER (end
);
4974 temp
= b
, b
= e
, e
= temp
;
4976 if (!(BEGV
<= b
&& e
<= ZV
))
4977 args_out_of_range (start
, end
);
4979 if (NILP (coding_system
))
4981 /* Decide the coding-system to encode the data with.
4982 See fileio.c:Fwrite-region */
4984 if (!NILP (Vcoding_system_for_write
))
4985 coding_system
= Vcoding_system_for_write
;
4988 int force_raw_text
= 0;
4990 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4991 if (NILP (coding_system
)
4992 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4994 coding_system
= Qnil
;
4995 if (NILP (current_buffer
->enable_multibyte_characters
))
4999 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5001 /* Check file-coding-system-alist. */
5002 Lisp_Object args
[4], val
;
5004 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5005 args
[3] = Fbuffer_file_name(object
);
5006 val
= Ffind_operation_coding_system (4, args
);
5007 if (CONSP (val
) && !NILP (XCDR (val
)))
5008 coding_system
= XCDR (val
);
5011 if (NILP (coding_system
)
5012 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5014 /* If we still have not decided a coding system, use the
5015 default value of buffer-file-coding-system. */
5016 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5020 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5021 /* Confirm that VAL can surely encode the current region. */
5022 coding_system
= call4 (Vselect_safe_coding_system_function
,
5023 make_number (b
), make_number (e
),
5024 coding_system
, Qnil
);
5027 coding_system
= Qraw_text
;
5030 if (NILP (Fcoding_system_p (coding_system
)))
5032 /* Invalid coding system. */
5034 if (!NILP (noerror
))
5035 coding_system
= Qraw_text
;
5038 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5042 object
= make_buffer_string (b
, e
, 0);
5043 if (prev
!= current_buffer
)
5044 set_buffer_internal (prev
);
5045 /* Discard the unwind protect for recovering the current
5049 if (STRING_MULTIBYTE (object
))
5050 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5053 md5_buffer (SDATA (object
) + start_byte
,
5054 SBYTES (object
) - (size_byte
- end_byte
),
5057 for (i
= 0; i
< 16; i
++)
5058 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5061 return make_string (value
, 32);
5068 /* Hash table stuff. */
5069 Qhash_table_p
= intern ("hash-table-p");
5070 staticpro (&Qhash_table_p
);
5071 Qeq
= intern ("eq");
5073 Qeql
= intern ("eql");
5075 Qequal
= intern ("equal");
5076 staticpro (&Qequal
);
5077 QCtest
= intern (":test");
5078 staticpro (&QCtest
);
5079 QCsize
= intern (":size");
5080 staticpro (&QCsize
);
5081 QCrehash_size
= intern (":rehash-size");
5082 staticpro (&QCrehash_size
);
5083 QCrehash_threshold
= intern (":rehash-threshold");
5084 staticpro (&QCrehash_threshold
);
5085 QCweakness
= intern (":weakness");
5086 staticpro (&QCweakness
);
5087 Qkey
= intern ("key");
5089 Qvalue
= intern ("value");
5090 staticpro (&Qvalue
);
5091 Qhash_table_test
= intern ("hash-table-test");
5092 staticpro (&Qhash_table_test
);
5093 Qkey_or_value
= intern ("key-or-value");
5094 staticpro (&Qkey_or_value
);
5095 Qkey_and_value
= intern ("key-and-value");
5096 staticpro (&Qkey_and_value
);
5099 defsubr (&Smake_hash_table
);
5100 defsubr (&Scopy_hash_table
);
5101 defsubr (&Shash_table_count
);
5102 defsubr (&Shash_table_rehash_size
);
5103 defsubr (&Shash_table_rehash_threshold
);
5104 defsubr (&Shash_table_size
);
5105 defsubr (&Shash_table_test
);
5106 defsubr (&Shash_table_weakness
);
5107 defsubr (&Shash_table_p
);
5108 defsubr (&Sclrhash
);
5109 defsubr (&Sgethash
);
5110 defsubr (&Sputhash
);
5111 defsubr (&Sremhash
);
5112 defsubr (&Smaphash
);
5113 defsubr (&Sdefine_hash_table_test
);
5115 Qstring_lessp
= intern ("string-lessp");
5116 staticpro (&Qstring_lessp
);
5117 Qprovide
= intern ("provide");
5118 staticpro (&Qprovide
);
5119 Qrequire
= intern ("require");
5120 staticpro (&Qrequire
);
5121 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5122 staticpro (&Qyes_or_no_p_history
);
5123 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5124 staticpro (&Qcursor_in_echo_area
);
5125 Qwidget_type
= intern ("widget-type");
5126 staticpro (&Qwidget_type
);
5128 staticpro (&string_char_byte_cache_string
);
5129 string_char_byte_cache_string
= Qnil
;
5131 require_nesting_list
= Qnil
;
5132 staticpro (&require_nesting_list
);
5134 Fset (Qyes_or_no_p_history
, Qnil
);
5136 DEFVAR_LISP ("features", &Vfeatures
,
5137 doc
: /* A list of symbols which are the features of the executing emacs.
5138 Used by `featurep' and `require', and altered by `provide'. */);
5140 Qsubfeatures
= intern ("subfeatures");
5141 staticpro (&Qsubfeatures
);
5143 #ifdef HAVE_LANGINFO_CODESET
5144 Qcodeset
= intern ("codeset");
5145 staticpro (&Qcodeset
);
5146 Qdays
= intern ("days");
5148 Qmonths
= intern ("months");
5149 staticpro (&Qmonths
);
5150 Qpaper
= intern ("paper");
5151 staticpro (&Qpaper
);
5152 #endif /* HAVE_LANGINFO_CODESET */
5154 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5155 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5156 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5157 invoked by mouse clicks and mouse menu items. */);
5160 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5161 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5162 This applies to commands from menus and tool bar buttons. The value of
5163 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5164 used if both `use-dialog-box' and this variable are non-nil. */);
5165 use_file_dialog
= 1;
5167 defsubr (&Sidentity
);
5170 defsubr (&Ssafe_length
);
5171 defsubr (&Sstring_bytes
);
5172 defsubr (&Sstring_equal
);
5173 defsubr (&Scompare_strings
);
5174 defsubr (&Sstring_lessp
);
5177 defsubr (&Svconcat
);
5178 defsubr (&Scopy_sequence
);
5179 defsubr (&Sstring_make_multibyte
);
5180 defsubr (&Sstring_make_unibyte
);
5181 defsubr (&Sstring_as_multibyte
);
5182 defsubr (&Sstring_as_unibyte
);
5183 defsubr (&Sstring_to_multibyte
);
5184 defsubr (&Scopy_alist
);
5185 defsubr (&Ssubstring
);
5186 defsubr (&Ssubstring_no_properties
);
5198 defsubr (&Snreverse
);
5199 defsubr (&Sreverse
);
5201 defsubr (&Splist_get
);
5203 defsubr (&Splist_put
);
5205 defsubr (&Slax_plist_get
);
5206 defsubr (&Slax_plist_put
);
5209 defsubr (&Sequal_including_properties
);
5210 defsubr (&Sfillarray
);
5211 defsubr (&Sclear_string
);
5215 defsubr (&Smapconcat
);
5216 defsubr (&Sy_or_n_p
);
5217 defsubr (&Syes_or_no_p
);
5218 defsubr (&Sload_average
);
5219 defsubr (&Sfeaturep
);
5220 defsubr (&Srequire
);
5221 defsubr (&Sprovide
);
5222 defsubr (&Splist_member
);
5223 defsubr (&Swidget_put
);
5224 defsubr (&Swidget_get
);
5225 defsubr (&Swidget_apply
);
5226 defsubr (&Sbase64_encode_region
);
5227 defsubr (&Sbase64_decode_region
);
5228 defsubr (&Sbase64_encode_string
);
5229 defsubr (&Sbase64_decode_string
);
5231 defsubr (&Slocale_info
);
5238 Vweak_hash_tables
= Qnil
;
5241 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5242 (do not change this comment) */