1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
31 /* On Mac OS, defining this conflicts with precompiled headers. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
38 #endif /* ! MAC_OSX */
47 #include "intervals.h"
50 #include "blockinput.h"
52 #if defined (HAVE_X_WINDOWS)
54 #elif defined (MAC_OS)
60 #define NULL ((POINTER_TYPE *)0)
63 /* Nonzero enables use of dialog boxes for questions
64 asked by mouse commands. */
67 /* Nonzero enables use of a file dialog for file name
68 questions asked by mouse commands. */
71 extern int minibuffer_auto_raise
;
72 extern Lisp_Object minibuf_window
;
73 extern Lisp_Object Vlocale_coding_system
;
74 extern int load_in_progress
;
76 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
77 Lisp_Object Qyes_or_no_p_history
;
78 Lisp_Object Qcursor_in_echo_area
;
79 Lisp_Object Qwidget_type
;
80 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
82 extern Lisp_Object Qinput_method_function
;
84 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
86 extern long get_random ();
87 extern void seed_random
P_ ((long));
93 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
94 doc
: /* Return the argument unchanged. */)
101 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
102 doc
: /* Return a pseudo-random number.
103 All integers representable in Lisp are equally likely.
104 On most systems, this is 29 bits' worth.
105 With positive integer argument N, return random number in interval [0,N).
106 With argument t, set the random number seed from the current time and pid. */)
111 Lisp_Object lispy_val
;
112 unsigned long denominator
;
115 seed_random (getpid () + time (NULL
));
116 if (NATNUMP (n
) && XFASTINT (n
) != 0)
118 /* Try to take our random number from the higher bits of VAL,
119 not the lower, since (says Gentzel) the low bits of `random'
120 are less random than the higher ones. We do this by using the
121 quotient rather than the remainder. At the high end of the RNG
122 it's possible to get a quotient larger than n; discarding
123 these values eliminates the bias that would otherwise appear
124 when using a large n. */
125 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
127 val
= get_random () / denominator
;
128 while (val
>= XFASTINT (n
));
132 XSETINT (lispy_val
, val
);
136 /* Random data-structure functions */
138 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
139 doc
: /* Return the length of vector, list or string SEQUENCE.
140 A byte-code function object is also allowed.
141 If the string contains multibyte characters, this is not necessarily
142 the number of bytes in the string; it is the number of characters.
143 To get the number of bytes, use `string-bytes'. */)
145 register Lisp_Object sequence
;
147 register Lisp_Object val
;
150 if (STRINGP (sequence
))
151 XSETFASTINT (val
, SCHARS (sequence
));
152 else if (VECTORP (sequence
))
153 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
154 else if (SUB_CHAR_TABLE_P (sequence
))
155 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
156 else if (CHAR_TABLE_P (sequence
))
157 XSETFASTINT (val
, MAX_CHAR
);
158 else if (BOOL_VECTOR_P (sequence
))
159 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
160 else if (COMPILEDP (sequence
))
161 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
162 else if (CONSP (sequence
))
165 while (CONSP (sequence
))
167 sequence
= XCDR (sequence
);
170 if (!CONSP (sequence
))
173 sequence
= XCDR (sequence
);
178 CHECK_LIST_END (sequence
, sequence
);
180 val
= make_number (i
);
182 else if (NILP (sequence
))
183 XSETFASTINT (val
, 0);
185 wrong_type_argument (Qsequencep
, sequence
);
190 /* This does not check for quits. That is safe since it must terminate. */
192 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
193 doc
: /* Return the length of a list, but avoid error or infinite loop.
194 This function never gets an error. If LIST is not really a list,
195 it returns 0. If LIST is circular, it returns a finite value
196 which is at least the number of distinct elements. */)
200 Lisp_Object tail
, halftail
, length
;
203 /* halftail is used to detect circular lists. */
205 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
207 if (EQ (tail
, halftail
) && len
!= 0)
211 halftail
= XCDR (halftail
);
214 XSETINT (length
, len
);
218 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
219 doc
: /* Return the number of bytes in STRING.
220 If STRING is a multibyte string, this is greater than the length of STRING. */)
224 CHECK_STRING (string
);
225 return make_number (SBYTES (string
));
228 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
229 doc
: /* Return t if two strings have identical contents.
230 Case is significant, but text properties are ignored.
231 Symbols are also allowed; their print names are used instead. */)
233 register Lisp_Object s1
, s2
;
236 s1
= SYMBOL_NAME (s1
);
238 s2
= SYMBOL_NAME (s2
);
242 if (SCHARS (s1
) != SCHARS (s2
)
243 || SBYTES (s1
) != SBYTES (s2
)
244 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
249 DEFUN ("compare-strings", Fcompare_strings
,
250 Scompare_strings
, 6, 7, 0,
251 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
252 In string STR1, skip the first START1 characters and stop at END1.
253 In string STR2, skip the first START2 characters and stop at END2.
254 END1 and END2 default to the full lengths of the respective strings.
256 Case is significant in this comparison if IGNORE-CASE is nil.
257 Unibyte strings are converted to multibyte for comparison.
259 The value is t if the strings (or specified portions) match.
260 If string STR1 is less, the value is a negative number N;
261 - 1 - N is the number of characters that match at the beginning.
262 If string STR1 is greater, the value is a positive number N;
263 N - 1 is the number of characters that match at the beginning. */)
264 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
265 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
267 register int end1_char
, end2_char
;
268 register int i1
, i1_byte
, i2
, i2_byte
;
273 start1
= make_number (0);
275 start2
= make_number (0);
276 CHECK_NATNUM (start1
);
277 CHECK_NATNUM (start2
);
286 i1_byte
= string_char_to_byte (str1
, i1
);
287 i2_byte
= string_char_to_byte (str2
, i2
);
289 end1_char
= SCHARS (str1
);
290 if (! NILP (end1
) && end1_char
> XINT (end1
))
291 end1_char
= XINT (end1
);
293 end2_char
= SCHARS (str2
);
294 if (! NILP (end2
) && end2_char
> XINT (end2
))
295 end2_char
= XINT (end2
);
297 while (i1
< end1_char
&& i2
< end2_char
)
299 /* When we find a mismatch, we must compare the
300 characters, not just the bytes. */
303 if (STRING_MULTIBYTE (str1
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
307 c1
= SREF (str1
, i1
++);
308 c1
= unibyte_char_to_multibyte (c1
);
311 if (STRING_MULTIBYTE (str2
))
312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
315 c2
= SREF (str2
, i2
++);
316 c2
= unibyte_char_to_multibyte (c2
);
322 if (! NILP (ignore_case
))
326 tem
= Fupcase (make_number (c1
));
328 tem
= Fupcase (make_number (c2
));
335 /* Note that I1 has already been incremented
336 past the character that we are comparing;
337 hence we don't add or subtract 1 here. */
339 return make_number (- i1
+ XINT (start1
));
341 return make_number (i1
- XINT (start1
));
345 return make_number (i1
- XINT (start1
) + 1);
347 return make_number (- i1
+ XINT (start1
) - 1);
352 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
353 doc
: /* Return t if first arg string is less than second in lexicographic order.
355 Symbols are also allowed; their print names are used instead. */)
357 register Lisp_Object s1
, s2
;
360 register int i1
, i1_byte
, i2
, i2_byte
;
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 i1
= i1_byte
= i2
= i2_byte
= 0;
372 if (end
> SCHARS (s2
))
377 /* When we find a mismatch, we must compare the
378 characters, not just the bytes. */
381 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
382 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
385 return c1
< c2
? Qt
: Qnil
;
387 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
391 /* "gcc -O3" enables automatic function inlining, which optimizes out
392 the arguments for the invocations of this function, whereas it
393 expects these values on the stack. */
394 static Lisp_Object
concat () __attribute__((noinline
));
395 #else /* !__GNUC__ */
396 static Lisp_Object
concat ();
408 return concat (2, args
, Lisp_String
, 0);
410 return concat (2, &s1
, Lisp_String
, 0);
411 #endif /* NO_ARG_ARRAY */
417 Lisp_Object s1
, s2
, s3
;
424 return concat (3, args
, Lisp_String
, 0);
426 return concat (3, &s1
, Lisp_String
, 0);
427 #endif /* NO_ARG_ARRAY */
430 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
431 doc
: /* Concatenate all the arguments and make the result a list.
432 The result is a list whose elements are the elements of all the arguments.
433 Each argument may be a list, vector or string.
434 The last argument is not copied, just used as the tail of the new list.
435 usage: (append &rest SEQUENCES) */)
440 return concat (nargs
, args
, Lisp_Cons
, 1);
443 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
444 doc
: /* Concatenate all the arguments and make the result a string.
445 The result is a string whose elements are the elements of all the arguments.
446 Each argument may be a string or a list or vector of characters (integers).
447 usage: (concat &rest SEQUENCES) */)
452 return concat (nargs
, args
, Lisp_String
, 0);
455 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
456 doc
: /* Concatenate all the arguments and make the result a vector.
457 The result is a vector whose elements are the elements of all the arguments.
458 Each argument may be a list, vector or string.
459 usage: (vconcat &rest SEQUENCES) */)
464 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
467 /* Return a copy of a sub char table ARG. The elements except for a
468 nested sub char table are not copied. */
470 copy_sub_char_table (arg
)
473 Lisp_Object copy
= make_sub_char_table (Qnil
);
476 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
477 /* Copy all the contents. */
478 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
479 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
480 /* Recursively copy any sub char-tables in the ordinary slots. */
481 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
482 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
483 XCHAR_TABLE (copy
)->contents
[i
]
484 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
490 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
491 doc
: /* Return a copy of a list, vector, string or char-table.
492 The elements of a list or vector are not copied; they are shared
493 with the original. */)
497 if (NILP (arg
)) return arg
;
499 if (CHAR_TABLE_P (arg
))
504 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
505 /* Copy all the slots, including the extra ones. */
506 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
507 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
508 * sizeof (Lisp_Object
)));
510 /* Recursively copy any sub char tables in the ordinary slots
511 for multibyte characters. */
512 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
513 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
514 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
515 XCHAR_TABLE (copy
)->contents
[i
]
516 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
521 if (BOOL_VECTOR_P (arg
))
525 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
526 / BOOL_VECTOR_BITS_PER_CHAR
);
528 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
529 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
534 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
535 wrong_type_argument (Qsequencep
, arg
);
537 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
540 /* This structure holds information of an argument of `concat' that is
541 a string and has text properties to be copied. */
544 int argnum
; /* refer to ARGS (arguments of `concat') */
545 int from
; /* refer to ARGS[argnum] (argument string) */
546 int to
; /* refer to VAL (the target string) */
550 concat (nargs
, args
, target_type
, last_special
)
553 enum Lisp_Type target_type
;
557 register Lisp_Object tail
;
558 register Lisp_Object
this;
560 int toindex_byte
= 0;
561 register int result_len
;
562 register int result_len_byte
;
564 Lisp_Object last_tail
;
567 /* When we make a multibyte string, we can't copy text properties
568 while concatinating each string because the length of resulting
569 string can't be decided until we finish the whole concatination.
570 So, we record strings that have text properties to be copied
571 here, and copy the text properties after the concatination. */
572 struct textprop_rec
*textprops
= NULL
;
573 /* Number of elments in textprops. */
574 int num_textprops
= 0;
579 /* In append, the last arg isn't treated like the others */
580 if (last_special
&& nargs
> 0)
583 last_tail
= args
[nargs
];
588 /* Check each argument. */
589 for (argnum
= 0; argnum
< nargs
; argnum
++)
592 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
593 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
594 wrong_type_argument (Qsequencep
, this);
597 /* Compute total length in chars of arguments in RESULT_LEN.
598 If desired output is a string, also compute length in bytes
599 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
600 whether the result should be a multibyte string. */
604 for (argnum
= 0; argnum
< nargs
; argnum
++)
608 len
= XFASTINT (Flength (this));
609 if (target_type
== Lisp_String
)
611 /* We must count the number of bytes needed in the string
612 as well as the number of characters. */
618 for (i
= 0; i
< len
; i
++)
620 ch
= XVECTOR (this)->contents
[i
];
622 this_len_byte
= CHAR_BYTES (XINT (ch
));
623 result_len_byte
+= this_len_byte
;
624 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
627 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
628 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
629 else if (CONSP (this))
630 for (; CONSP (this); this = XCDR (this))
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
639 else if (STRINGP (this))
641 if (STRING_MULTIBYTE (this))
644 result_len_byte
+= SBYTES (this);
647 result_len_byte
+= count_size_as_multibyte (SDATA (this),
655 if (! some_multibyte
)
656 result_len_byte
= result_len
;
658 /* Create the output object. */
659 if (target_type
== Lisp_Cons
)
660 val
= Fmake_list (make_number (result_len
), Qnil
);
661 else if (target_type
== Lisp_Vectorlike
)
662 val
= Fmake_vector (make_number (result_len
), Qnil
);
663 else if (some_multibyte
)
664 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
666 val
= make_uninit_string (result_len
);
668 /* In `append', if all but last arg are nil, return last arg. */
669 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
672 /* Copy the contents of the args into the result. */
674 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
676 toindex
= 0, toindex_byte
= 0;
680 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
682 for (argnum
= 0; argnum
< nargs
; argnum
++)
686 register unsigned int thisindex
= 0;
687 register unsigned int thisindex_byte
= 0;
691 thislen
= Flength (this), thisleni
= XINT (thislen
);
693 /* Between strings of the same kind, copy fast. */
694 if (STRINGP (this) && STRINGP (val
)
695 && STRING_MULTIBYTE (this) == some_multibyte
)
697 int thislen_byte
= SBYTES (this);
699 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
701 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
703 textprops
[num_textprops
].argnum
= argnum
;
704 textprops
[num_textprops
].from
= 0;
705 textprops
[num_textprops
++].to
= toindex
;
707 toindex_byte
+= thislen_byte
;
709 STRING_SET_CHARS (val
, SCHARS (val
));
711 /* Copy a single-byte string to a multibyte string. */
712 else if (STRINGP (this) && STRINGP (val
))
714 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
716 textprops
[num_textprops
].argnum
= argnum
;
717 textprops
[num_textprops
].from
= 0;
718 textprops
[num_textprops
++].to
= toindex
;
720 toindex_byte
+= copy_text (SDATA (this),
721 SDATA (val
) + toindex_byte
,
722 SCHARS (this), 0, 1);
726 /* Copy element by element. */
729 register Lisp_Object elt
;
731 /* Fetch next element of `this' arg into `elt', or break if
732 `this' is exhausted. */
733 if (NILP (this)) break;
735 elt
= XCAR (this), this = XCDR (this);
736 else if (thisindex
>= thisleni
)
738 else if (STRINGP (this))
741 if (STRING_MULTIBYTE (this))
743 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
746 XSETFASTINT (elt
, c
);
750 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
752 && (XINT (elt
) >= 0240
753 || (XINT (elt
) >= 0200
754 && ! NILP (Vnonascii_translation_table
)))
755 && XINT (elt
) < 0400)
757 c
= unibyte_char_to_multibyte (XINT (elt
));
762 else if (BOOL_VECTOR_P (this))
765 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
766 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
773 elt
= XVECTOR (this)->contents
[thisindex
++];
775 /* Store this element into the result. */
782 else if (VECTORP (val
))
783 XVECTOR (val
)->contents
[toindex
++] = elt
;
787 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
791 += CHAR_STRING (XINT (elt
),
792 SDATA (val
) + toindex_byte
);
794 SSET (val
, toindex_byte
++, XINT (elt
));
798 /* If we have any multibyte characters,
799 we already decided to make a multibyte string. */
802 /* P exists as a variable
803 to avoid a bug on the Masscomp C compiler. */
804 unsigned char *p
= SDATA (val
) + toindex_byte
;
806 toindex_byte
+= CHAR_STRING (c
, p
);
813 XSETCDR (prev
, last_tail
);
815 if (num_textprops
> 0)
818 int last_to_end
= -1;
820 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
822 this = args
[textprops
[argnum
].argnum
];
823 props
= text_property_list (this,
825 make_number (SCHARS (this)),
827 /* If successive arguments have properites, be sure that the
828 value of `composition' property be the copy. */
829 if (last_to_end
== textprops
[argnum
].to
)
830 make_composition_value_copy (props
);
831 add_text_properties_from_list (val
, props
,
832 make_number (textprops
[argnum
].to
));
833 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
841 static Lisp_Object string_char_byte_cache_string
;
842 static int string_char_byte_cache_charpos
;
843 static int string_char_byte_cache_bytepos
;
846 clear_string_char_byte_cache ()
848 string_char_byte_cache_string
= Qnil
;
851 /* Return the character index corresponding to CHAR_INDEX in STRING. */
854 string_char_to_byte (string
, char_index
)
859 int best_below
, best_below_byte
;
860 int best_above
, best_above_byte
;
862 best_below
= best_below_byte
= 0;
863 best_above
= SCHARS (string
);
864 best_above_byte
= SBYTES (string
);
865 if (best_above
== best_above_byte
)
868 if (EQ (string
, string_char_byte_cache_string
))
870 if (string_char_byte_cache_charpos
< char_index
)
872 best_below
= string_char_byte_cache_charpos
;
873 best_below_byte
= string_char_byte_cache_bytepos
;
877 best_above
= string_char_byte_cache_charpos
;
878 best_above_byte
= string_char_byte_cache_bytepos
;
882 if (char_index
- best_below
< best_above
- char_index
)
884 while (best_below
< char_index
)
887 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
888 best_below
, best_below_byte
);
891 i_byte
= best_below_byte
;
895 while (best_above
> char_index
)
897 unsigned char *pend
= SDATA (string
) + best_above_byte
;
898 unsigned char *pbeg
= pend
- best_above_byte
;
899 unsigned char *p
= pend
- 1;
902 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
903 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
904 if (bytes
== pend
- p
)
905 best_above_byte
-= bytes
;
906 else if (bytes
> pend
- p
)
907 best_above_byte
-= (pend
- p
);
913 i_byte
= best_above_byte
;
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Return the character index corresponding to BYTE_INDEX in STRING. */
926 string_byte_to_char (string
, byte_index
)
931 int best_below
, best_below_byte
;
932 int best_above
, best_above_byte
;
934 best_below
= best_below_byte
= 0;
935 best_above
= SCHARS (string
);
936 best_above_byte
= SBYTES (string
);
937 if (best_above
== best_above_byte
)
940 if (EQ (string
, string_char_byte_cache_string
))
942 if (string_char_byte_cache_bytepos
< byte_index
)
944 best_below
= string_char_byte_cache_charpos
;
945 best_below_byte
= string_char_byte_cache_bytepos
;
949 best_above
= string_char_byte_cache_charpos
;
950 best_above_byte
= string_char_byte_cache_bytepos
;
954 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
956 while (best_below_byte
< byte_index
)
959 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
960 best_below
, best_below_byte
);
963 i_byte
= best_below_byte
;
967 while (best_above_byte
> byte_index
)
969 unsigned char *pend
= SDATA (string
) + best_above_byte
;
970 unsigned char *pbeg
= pend
- best_above_byte
;
971 unsigned char *p
= pend
- 1;
974 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
975 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
976 if (bytes
== pend
- p
)
977 best_above_byte
-= bytes
;
978 else if (bytes
> pend
- p
)
979 best_above_byte
-= (pend
- p
);
985 i_byte
= best_above_byte
;
988 string_char_byte_cache_bytepos
= i_byte
;
989 string_char_byte_cache_charpos
= i
;
990 string_char_byte_cache_string
= string
;
995 /* Convert STRING to a multibyte string.
996 Single-byte characters 0240 through 0377 are converted
997 by adding nonascii_insert_offset to each. */
1000 string_make_multibyte (string
)
1008 if (STRING_MULTIBYTE (string
))
1011 nbytes
= count_size_as_multibyte (SDATA (string
),
1013 /* If all the chars are ASCII, they won't need any more bytes
1014 once converted. In that case, we can return STRING itself. */
1015 if (nbytes
== SBYTES (string
))
1018 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1019 copy_text (SDATA (string
), buf
, SBYTES (string
),
1022 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1029 /* Convert STRING to a multibyte string without changing each
1030 character codes. Thus, characters 0200 trough 0237 are converted
1031 to eight-bit-control characters, and characters 0240 through 0377
1032 are converted eight-bit-graphic characters. */
1035 string_to_multibyte (string
)
1043 if (STRING_MULTIBYTE (string
))
1046 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1047 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1048 any more bytes once converted. */
1049 if (nbytes
== SBYTES (string
))
1050 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1052 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1053 bcopy (SDATA (string
), buf
, SBYTES (string
));
1054 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1056 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1063 /* Convert STRING to a single-byte string. */
1066 string_make_unibyte (string
)
1074 if (! STRING_MULTIBYTE (string
))
1077 nchars
= SCHARS (string
);
1079 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1080 copy_text (SDATA (string
), buf
, SBYTES (string
),
1083 ret
= make_unibyte_string (buf
, nchars
);
1089 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1091 doc
: /* Return the multibyte equivalent of STRING.
1092 If STRING is unibyte and contains non-ASCII characters, the function
1093 `unibyte-char-to-multibyte' is used to convert each unibyte character
1094 to a multibyte character. In this case, the returned string is a
1095 newly created string with no text properties. If STRING is multibyte
1096 or entirely ASCII, it is returned unchanged. In particular, when
1097 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1098 \(When the characters are all ASCII, Emacs primitives will treat the
1099 string the same way whether it is unibyte or multibyte.) */)
1103 CHECK_STRING (string
);
1105 return string_make_multibyte (string
);
1108 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1110 doc
: /* Return the unibyte equivalent of STRING.
1111 Multibyte character codes are converted to unibyte according to
1112 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1113 If the lookup in the translation table fails, this function takes just
1114 the low 8 bits of each character. */)
1118 CHECK_STRING (string
);
1120 return string_make_unibyte (string
);
1123 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1125 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1126 If STRING is unibyte, the result is STRING itself.
1127 Otherwise it is a newly created string, with no text properties.
1128 If STRING is multibyte and contains a character of charset
1129 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1130 corresponding single byte. */)
1134 CHECK_STRING (string
);
1136 if (STRING_MULTIBYTE (string
))
1138 int bytes
= SBYTES (string
);
1139 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1141 bcopy (SDATA (string
), str
, bytes
);
1142 bytes
= str_as_unibyte (str
, bytes
);
1143 string
= make_unibyte_string (str
, bytes
);
1149 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1151 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1152 If STRING is multibyte, the result is STRING itself.
1153 Otherwise it is a newly created string, with no text properties.
1154 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1155 part of a multibyte form), it is converted to the corresponding
1156 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1157 Beware, this often doesn't really do what you think it does.
1158 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1159 If you're not sure, whether to use `string-as-multibyte' or
1160 `string-to-multibyte', use `string-to-multibyte'. Beware:
1161 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1162 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1163 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1164 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1166 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1167 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1171 CHECK_STRING (string
);
1173 if (! STRING_MULTIBYTE (string
))
1175 Lisp_Object new_string
;
1178 parse_str_as_multibyte (SDATA (string
),
1181 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1182 bcopy (SDATA (string
), SDATA (new_string
),
1184 if (nbytes
!= SBYTES (string
))
1185 str_as_multibyte (SDATA (new_string
), nbytes
,
1186 SBYTES (string
), NULL
);
1187 string
= new_string
;
1188 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1193 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1195 doc
: /* Return a multibyte string with the same individual chars as STRING.
1196 If STRING is multibyte, the result is STRING itself.
1197 Otherwise it is a newly created string, with no text properties.
1198 Characters 0200 through 0237 are converted to eight-bit-control
1199 characters of the same character code. Characters 0240 through 0377
1200 are converted to eight-bit-graphic characters of the same character
1202 This is similar to (decode-coding-string STRING 'binary) */)
1206 CHECK_STRING (string
);
1208 return string_to_multibyte (string
);
1212 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1213 doc
: /* Return a copy of ALIST.
1214 This is an alist which represents the same mapping from objects to objects,
1215 but does not share the alist structure with ALIST.
1216 The objects mapped (cars and cdrs of elements of the alist)
1217 are shared, however.
1218 Elements of ALIST that are not conses are also shared. */)
1222 register Lisp_Object tem
;
1227 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1228 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1230 register Lisp_Object car
;
1234 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1239 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1240 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1241 TO may be nil or omitted; then the substring runs to the end of STRING.
1242 FROM and TO start at 0. If either is negative, it counts from the end.
1244 This function allows vectors as well as strings. */)
1247 register Lisp_Object from
, to
;
1252 int from_char
, to_char
;
1253 int from_byte
= 0, to_byte
= 0;
1255 CHECK_VECTOR_OR_STRING (string
);
1256 CHECK_NUMBER (from
);
1258 if (STRINGP (string
))
1260 size
= SCHARS (string
);
1261 size_byte
= SBYTES (string
);
1264 size
= XVECTOR (string
)->size
;
1269 to_byte
= size_byte
;
1275 to_char
= XINT (to
);
1279 if (STRINGP (string
))
1280 to_byte
= string_char_to_byte (string
, to_char
);
1283 from_char
= XINT (from
);
1286 if (STRINGP (string
))
1287 from_byte
= string_char_to_byte (string
, from_char
);
1289 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1290 args_out_of_range_3 (string
, make_number (from_char
),
1291 make_number (to_char
));
1293 if (STRINGP (string
))
1295 res
= make_specified_string (SDATA (string
) + from_byte
,
1296 to_char
- from_char
, to_byte
- from_byte
,
1297 STRING_MULTIBYTE (string
));
1298 copy_text_properties (make_number (from_char
), make_number (to_char
),
1299 string
, make_number (0), res
, Qnil
);
1302 res
= Fvector (to_char
- from_char
,
1303 XVECTOR (string
)->contents
+ from_char
);
1309 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1310 doc
: /* Return a substring of STRING, without text properties.
1311 It starts at index FROM and ending before TO.
1312 TO may be nil or omitted; then the substring runs to the end of STRING.
1313 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1314 If FROM or TO is negative, it counts from the end.
1316 With one argument, just copy STRING without its properties. */)
1319 register Lisp_Object from
, to
;
1321 int size
, size_byte
;
1322 int from_char
, to_char
;
1323 int from_byte
, to_byte
;
1325 CHECK_STRING (string
);
1327 size
= SCHARS (string
);
1328 size_byte
= SBYTES (string
);
1331 from_char
= from_byte
= 0;
1334 CHECK_NUMBER (from
);
1335 from_char
= XINT (from
);
1339 from_byte
= string_char_to_byte (string
, from_char
);
1345 to_byte
= size_byte
;
1351 to_char
= XINT (to
);
1355 to_byte
= string_char_to_byte (string
, to_char
);
1358 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1359 args_out_of_range_3 (string
, make_number (from_char
),
1360 make_number (to_char
));
1362 return make_specified_string (SDATA (string
) + from_byte
,
1363 to_char
- from_char
, to_byte
- from_byte
,
1364 STRING_MULTIBYTE (string
));
1367 /* Extract a substring of STRING, giving start and end positions
1368 both in characters and in bytes. */
1371 substring_both (string
, from
, from_byte
, to
, to_byte
)
1373 int from
, from_byte
, to
, to_byte
;
1379 CHECK_VECTOR_OR_STRING (string
);
1381 if (STRINGP (string
))
1383 size
= SCHARS (string
);
1384 size_byte
= SBYTES (string
);
1387 size
= XVECTOR (string
)->size
;
1389 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1390 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1392 if (STRINGP (string
))
1394 res
= make_specified_string (SDATA (string
) + from_byte
,
1395 to
- from
, to_byte
- from_byte
,
1396 STRING_MULTIBYTE (string
));
1397 copy_text_properties (make_number (from
), make_number (to
),
1398 string
, make_number (0), res
, Qnil
);
1401 res
= Fvector (to
- from
,
1402 XVECTOR (string
)->contents
+ from
);
1407 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1408 doc
: /* Take cdr N times on LIST, returns the result. */)
1411 register Lisp_Object list
;
1413 register int i
, num
;
1416 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1419 CHECK_LIST_CONS (list
, list
);
1425 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1426 doc
: /* Return the Nth element of LIST.
1427 N counts from zero. If LIST is not that long, nil is returned. */)
1429 Lisp_Object n
, list
;
1431 return Fcar (Fnthcdr (n
, list
));
1434 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1435 doc
: /* Return element of SEQUENCE at index N. */)
1437 register Lisp_Object sequence
, n
;
1440 if (CONSP (sequence
) || NILP (sequence
))
1441 return Fcar (Fnthcdr (n
, sequence
));
1443 /* Faref signals a "not array" error, so check here. */
1444 CHECK_ARRAY (sequence
, Qsequencep
);
1445 return Faref (sequence
, n
);
1448 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1449 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1450 The value is actually the tail of LIST whose car is ELT. */)
1452 register Lisp_Object elt
;
1455 register Lisp_Object tail
;
1456 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1458 register Lisp_Object tem
;
1459 CHECK_LIST_CONS (tail
, list
);
1461 if (! NILP (Fequal (elt
, tem
)))
1468 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1469 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1470 The value is actually the tail of LIST whose car is ELT. */)
1472 register Lisp_Object elt
, list
;
1476 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1480 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1484 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1495 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1496 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1497 The value is actually the tail of LIST whose car is ELT. */)
1499 register Lisp_Object elt
;
1502 register Lisp_Object tail
;
1505 return Fmemq (elt
, list
);
1507 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1509 register Lisp_Object tem
;
1510 CHECK_LIST_CONS (tail
, list
);
1512 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1519 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1520 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1521 The value is actually the first element of LIST whose car is KEY.
1522 Elements of LIST that are not conses are ignored. */)
1524 Lisp_Object key
, list
;
1529 || (CONSP (XCAR (list
))
1530 && EQ (XCAR (XCAR (list
)), key
)))
1535 || (CONSP (XCAR (list
))
1536 && EQ (XCAR (XCAR (list
)), key
)))
1541 || (CONSP (XCAR (list
))
1542 && EQ (XCAR (XCAR (list
)), key
)))
1552 /* Like Fassq but never report an error and do not allow quits.
1553 Use only on lists known never to be circular. */
1556 assq_no_quit (key
, list
)
1557 Lisp_Object key
, list
;
1560 && (!CONSP (XCAR (list
))
1561 || !EQ (XCAR (XCAR (list
)), key
)))
1564 return CAR_SAFE (list
);
1567 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1568 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1569 The value is actually the first element of LIST whose car equals KEY. */)
1571 Lisp_Object key
, list
;
1578 || (CONSP (XCAR (list
))
1579 && (car
= XCAR (XCAR (list
)),
1580 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1585 || (CONSP (XCAR (list
))
1586 && (car
= XCAR (XCAR (list
)),
1587 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1592 || (CONSP (XCAR (list
))
1593 && (car
= XCAR (XCAR (list
)),
1594 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1604 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr is KEY. */)
1608 register Lisp_Object key
;
1614 || (CONSP (XCAR (list
))
1615 && EQ (XCDR (XCAR (list
)), key
)))
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1626 || (CONSP (XCAR (list
))
1627 && EQ (XCDR (XCAR (list
)), key
)))
1637 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1638 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1639 The value is actually the first element of LIST whose cdr equals KEY. */)
1641 Lisp_Object key
, list
;
1648 || (CONSP (XCAR (list
))
1649 && (cdr
= XCDR (XCAR (list
)),
1650 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1655 || (CONSP (XCAR (list
))
1656 && (cdr
= XCDR (XCAR (list
)),
1657 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1662 || (CONSP (XCAR (list
))
1663 && (cdr
= XCDR (XCAR (list
)),
1664 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1674 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1675 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1676 The modified LIST is returned. Comparison is done with `eq'.
1677 If the first member of LIST is ELT, there is no way to remove it by side effect;
1678 therefore, write `(setq foo (delq element foo))'
1679 to be sure of changing the value of `foo'. */)
1681 register Lisp_Object elt
;
1684 register Lisp_Object tail
, prev
;
1685 register Lisp_Object tem
;
1689 while (!NILP (tail
))
1691 CHECK_LIST_CONS (tail
, list
);
1698 Fsetcdr (prev
, XCDR (tail
));
1708 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1709 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1710 SEQ must be a list, a vector, or a string.
1711 The modified SEQ is returned. Comparison is done with `equal'.
1712 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1713 is not a side effect; it is simply using a different sequence.
1714 Therefore, write `(setq foo (delete element foo))'
1715 to be sure of changing the value of `foo'. */)
1717 Lisp_Object elt
, seq
;
1723 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1724 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1727 if (n
!= ASIZE (seq
))
1729 struct Lisp_Vector
*p
= allocate_vector (n
);
1731 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1732 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1733 p
->contents
[n
++] = AREF (seq
, i
);
1735 XSETVECTOR (seq
, p
);
1738 else if (STRINGP (seq
))
1740 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1743 for (i
= nchars
= nbytes
= ibyte
= 0;
1745 ++i
, ibyte
+= cbytes
)
1747 if (STRING_MULTIBYTE (seq
))
1749 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1750 SBYTES (seq
) - ibyte
);
1751 cbytes
= CHAR_BYTES (c
);
1759 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1766 if (nchars
!= SCHARS (seq
))
1770 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1771 if (!STRING_MULTIBYTE (seq
))
1772 STRING_SET_UNIBYTE (tem
);
1774 for (i
= nchars
= nbytes
= ibyte
= 0;
1776 ++i
, ibyte
+= cbytes
)
1778 if (STRING_MULTIBYTE (seq
))
1780 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1781 SBYTES (seq
) - ibyte
);
1782 cbytes
= CHAR_BYTES (c
);
1790 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1792 unsigned char *from
= SDATA (seq
) + ibyte
;
1793 unsigned char *to
= SDATA (tem
) + nbytes
;
1799 for (n
= cbytes
; n
--; )
1809 Lisp_Object tail
, prev
;
1811 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1813 CHECK_LIST_CONS (tail
, seq
);
1815 if (!NILP (Fequal (elt
, XCAR (tail
))))
1820 Fsetcdr (prev
, XCDR (tail
));
1831 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1832 doc
: /* Reverse LIST by modifying cdr pointers.
1833 Return the reversed list. */)
1837 register Lisp_Object prev
, tail
, next
;
1839 if (NILP (list
)) return list
;
1842 while (!NILP (tail
))
1845 CHECK_LIST_CONS (tail
, list
);
1847 Fsetcdr (tail
, prev
);
1854 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1855 doc
: /* Reverse LIST, copying. Return the reversed list.
1856 See also the function `nreverse', which is used more often. */)
1862 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1865 new = Fcons (XCAR (list
), new);
1867 CHECK_LIST_END (list
, list
);
1871 Lisp_Object
merge ();
1873 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1874 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1875 Returns the sorted list. LIST is modified by side effects.
1876 PREDICATE is called with two elements of LIST, and should return non-nil
1877 if the first element should sort before the second. */)
1879 Lisp_Object list
, predicate
;
1881 Lisp_Object front
, back
;
1882 register Lisp_Object len
, tem
;
1883 struct gcpro gcpro1
, gcpro2
;
1884 register int length
;
1887 len
= Flength (list
);
1888 length
= XINT (len
);
1892 XSETINT (len
, (length
/ 2) - 1);
1893 tem
= Fnthcdr (len
, list
);
1895 Fsetcdr (tem
, Qnil
);
1897 GCPRO2 (front
, back
);
1898 front
= Fsort (front
, predicate
);
1899 back
= Fsort (back
, predicate
);
1901 return merge (front
, back
, predicate
);
1905 merge (org_l1
, org_l2
, pred
)
1906 Lisp_Object org_l1
, org_l2
;
1910 register Lisp_Object tail
;
1912 register Lisp_Object l1
, l2
;
1913 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1920 /* It is sufficient to protect org_l1 and org_l2.
1921 When l1 and l2 are updated, we copy the new values
1922 back into the org_ vars. */
1923 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1943 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1959 Fsetcdr (tail
, tem
);
1965 #if 0 /* Unsafe version. */
1966 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1967 doc
: /* Extract a value from a property list.
1968 PLIST is a property list, which is a list of the form
1969 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1970 corresponding to the given PROP, or nil if PROP is not
1971 one of the properties on the list. */)
1979 CONSP (tail
) && CONSP (XCDR (tail
));
1980 tail
= XCDR (XCDR (tail
)))
1982 if (EQ (prop
, XCAR (tail
)))
1983 return XCAR (XCDR (tail
));
1985 /* This function can be called asynchronously
1986 (setup_coding_system). Don't QUIT in that case. */
1987 if (!interrupt_input_blocked
)
1991 CHECK_LIST_END (tail
, prop
);
1997 /* This does not check for quits. That is safe since it must terminate. */
1999 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2000 doc
: /* Extract a value from a property list.
2001 PLIST is a property list, which is a list of the form
2002 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2003 corresponding to the given PROP, or nil if PROP is not one of the
2004 properties on the list. This function never signals an error. */)
2009 Lisp_Object tail
, halftail
;
2011 /* halftail is used to detect circular lists. */
2012 tail
= halftail
= plist
;
2013 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2015 if (EQ (prop
, XCAR (tail
)))
2016 return XCAR (XCDR (tail
));
2018 tail
= XCDR (XCDR (tail
));
2019 halftail
= XCDR (halftail
);
2020 if (EQ (tail
, halftail
))
2027 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2028 doc
: /* Return the value of SYMBOL's PROPNAME property.
2029 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2031 Lisp_Object symbol
, propname
;
2033 CHECK_SYMBOL (symbol
);
2034 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2037 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2038 doc
: /* Change value in PLIST of PROP to VAL.
2039 PLIST is a property list, which is a list of the form
2040 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2041 If PROP is already a property on the list, its value is set to VAL,
2042 otherwise the new PROP VAL pair is added. The new plist is returned;
2043 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2044 The PLIST is modified by side effects. */)
2047 register Lisp_Object prop
;
2050 register Lisp_Object tail
, prev
;
2051 Lisp_Object newcell
;
2053 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2054 tail
= XCDR (XCDR (tail
)))
2056 if (EQ (prop
, XCAR (tail
)))
2058 Fsetcar (XCDR (tail
), val
);
2065 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2069 Fsetcdr (XCDR (prev
), newcell
);
2073 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2074 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2075 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2076 (symbol
, propname
, value
)
2077 Lisp_Object symbol
, propname
, value
;
2079 CHECK_SYMBOL (symbol
);
2080 XSYMBOL (symbol
)->plist
2081 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2085 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2086 doc
: /* Extract a value from a property list, comparing with `equal'.
2087 PLIST is a property list, which is a list of the form
2088 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2089 corresponding to the given PROP, or nil if PROP is not
2090 one of the properties on the list. */)
2098 CONSP (tail
) && CONSP (XCDR (tail
));
2099 tail
= XCDR (XCDR (tail
)))
2101 if (! NILP (Fequal (prop
, XCAR (tail
))))
2102 return XCAR (XCDR (tail
));
2107 CHECK_LIST_END (tail
, prop
);
2112 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2113 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2114 PLIST is a property list, which is a list of the form
2115 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2116 If PROP is already a property on the list, its value is set to VAL,
2117 otherwise the new PROP VAL pair is added. The new plist is returned;
2118 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2119 The PLIST is modified by side effects. */)
2122 register Lisp_Object prop
;
2125 register Lisp_Object tail
, prev
;
2126 Lisp_Object newcell
;
2128 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2129 tail
= XCDR (XCDR (tail
)))
2131 if (! NILP (Fequal (prop
, XCAR (tail
))))
2133 Fsetcar (XCDR (tail
), val
);
2140 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2144 Fsetcdr (XCDR (prev
), newcell
);
2148 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2149 doc
: /* Return t if the two args are the same Lisp object.
2150 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2152 Lisp_Object obj1
, obj2
;
2155 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2157 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2160 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2161 doc
: /* Return t if two Lisp objects have similar structure and contents.
2162 They must have the same data type.
2163 Conses are compared by comparing the cars and the cdrs.
2164 Vectors and strings are compared element by element.
2165 Numbers are compared by value, but integers cannot equal floats.
2166 (Use `=' if you want integers and floats to be able to be equal.)
2167 Symbols must match exactly. */)
2169 register Lisp_Object o1
, o2
;
2171 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2174 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2175 doc
: /* Return t if two Lisp objects have similar structure and contents.
2176 This is like `equal' except that it compares the text properties
2177 of strings. (`equal' ignores text properties.) */)
2179 register Lisp_Object o1
, o2
;
2181 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2184 /* DEPTH is current depth of recursion. Signal an error if it
2186 PROPS, if non-nil, means compare string text properties too. */
2189 internal_equal (o1
, o2
, depth
, props
)
2190 register Lisp_Object o1
, o2
;
2194 error ("Stack overflow in equal");
2200 if (XTYPE (o1
) != XTYPE (o2
))
2209 d1
= extract_float (o1
);
2210 d2
= extract_float (o2
);
2211 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2212 though they are not =. */
2213 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2217 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2224 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2228 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2230 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2233 o1
= XOVERLAY (o1
)->plist
;
2234 o2
= XOVERLAY (o2
)->plist
;
2239 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2240 && (XMARKER (o1
)->buffer
== 0
2241 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2245 case Lisp_Vectorlike
:
2248 EMACS_INT size
= XVECTOR (o1
)->size
;
2249 /* Pseudovectors have the type encoded in the size field, so this test
2250 actually checks that the objects have the same type as well as the
2252 if (XVECTOR (o2
)->size
!= size
)
2254 /* Boolvectors are compared much like strings. */
2255 if (BOOL_VECTOR_P (o1
))
2258 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2259 / BOOL_VECTOR_BITS_PER_CHAR
);
2261 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2263 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2268 if (WINDOW_CONFIGURATIONP (o1
))
2269 return compare_window_configurations (o1
, o2
, 0);
2271 /* Aside from them, only true vectors, char-tables, and compiled
2272 functions are sensible to compare, so eliminate the others now. */
2273 if (size
& PSEUDOVECTOR_FLAG
)
2275 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2277 size
&= PSEUDOVECTOR_SIZE_MASK
;
2279 for (i
= 0; i
< size
; i
++)
2282 v1
= XVECTOR (o1
)->contents
[i
];
2283 v2
= XVECTOR (o2
)->contents
[i
];
2284 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2292 if (SCHARS (o1
) != SCHARS (o2
))
2294 if (SBYTES (o1
) != SBYTES (o2
))
2296 if (bcmp (SDATA (o1
), SDATA (o2
),
2299 if (props
&& !compare_string_intervals (o1
, o2
))
2305 case Lisp_Type_Limit
:
2312 extern Lisp_Object
Fmake_char_internal ();
2314 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2315 doc
: /* Store each element of ARRAY with ITEM.
2316 ARRAY is a vector, string, char-table, or bool-vector. */)
2318 Lisp_Object array
, item
;
2320 register int size
, index
, charval
;
2321 if (VECTORP (array
))
2323 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2324 size
= XVECTOR (array
)->size
;
2325 for (index
= 0; index
< size
; index
++)
2328 else if (CHAR_TABLE_P (array
))
2330 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2331 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2332 for (index
= 0; index
< size
; index
++)
2334 XCHAR_TABLE (array
)->defalt
= Qnil
;
2336 else if (STRINGP (array
))
2338 register unsigned char *p
= SDATA (array
);
2339 CHECK_NUMBER (item
);
2340 charval
= XINT (item
);
2341 size
= SCHARS (array
);
2342 if (STRING_MULTIBYTE (array
))
2344 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2345 int len
= CHAR_STRING (charval
, str
);
2346 int size_byte
= SBYTES (array
);
2347 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2350 if (size
!= size_byte
)
2353 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2354 if (len
!= this_len
)
2355 error ("Attempt to change byte length of a string");
2358 for (i
= 0; i
< size_byte
; i
++)
2359 *p
++ = str
[i
% len
];
2362 for (index
= 0; index
< size
; index
++)
2365 else if (BOOL_VECTOR_P (array
))
2367 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2369 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2370 / BOOL_VECTOR_BITS_PER_CHAR
);
2372 charval
= (! NILP (item
) ? -1 : 0);
2373 for (index
= 0; index
< size_in_chars
- 1; index
++)
2375 if (index
< size_in_chars
)
2377 /* Mask out bits beyond the vector size. */
2378 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2379 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2384 wrong_type_argument (Qarrayp
, array
);
2388 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2390 doc
: /* Clear the contents of STRING.
2391 This makes STRING unibyte and may change its length. */)
2396 CHECK_STRING (string
);
2397 len
= SBYTES (string
);
2398 bzero (SDATA (string
), len
);
2399 STRING_SET_CHARS (string
, len
);
2400 STRING_SET_UNIBYTE (string
);
2404 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2406 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2408 Lisp_Object char_table
;
2410 CHECK_CHAR_TABLE (char_table
);
2412 return XCHAR_TABLE (char_table
)->purpose
;
2415 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2417 doc
: /* Return the parent char-table of CHAR-TABLE.
2418 The value is either nil or another char-table.
2419 If CHAR-TABLE holds nil for a given character,
2420 then the actual applicable value is inherited from the parent char-table
2421 \(or from its parents, if necessary). */)
2423 Lisp_Object char_table
;
2425 CHECK_CHAR_TABLE (char_table
);
2427 return XCHAR_TABLE (char_table
)->parent
;
2430 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2432 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2433 Return PARENT. PARENT must be either nil or another char-table. */)
2434 (char_table
, parent
)
2435 Lisp_Object char_table
, parent
;
2439 CHECK_CHAR_TABLE (char_table
);
2443 CHECK_CHAR_TABLE (parent
);
2445 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2446 if (EQ (temp
, char_table
))
2447 error ("Attempt to make a chartable be its own parent");
2450 XCHAR_TABLE (char_table
)->parent
= parent
;
2455 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2457 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2459 Lisp_Object char_table
, n
;
2461 CHECK_CHAR_TABLE (char_table
);
2464 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2465 args_out_of_range (char_table
, n
);
2467 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2470 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2471 Sset_char_table_extra_slot
,
2473 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2474 (char_table
, n
, value
)
2475 Lisp_Object char_table
, n
, value
;
2477 CHECK_CHAR_TABLE (char_table
);
2480 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2481 args_out_of_range (char_table
, n
);
2483 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2487 char_table_range (table
, from
, to
, defalt
)
2494 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2495 defalt
= XCHAR_TABLE (table
)->defalt
;
2496 val
= XCHAR_TABLE (table
)->contents
[from
];
2497 if (SUB_CHAR_TABLE_P (val
))
2498 val
= char_table_range (val
, 32, 127, defalt
);
2499 else if (NILP (val
))
2501 for (from
++; from
<= to
; from
++)
2503 Lisp_Object this_val
;
2505 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2506 if (SUB_CHAR_TABLE_P (this_val
))
2507 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2508 else if (NILP (this_val
))
2510 if (! EQ (val
, this_val
))
2511 error ("Characters in the range have inconsistent values");
2517 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2519 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2520 RANGE should be nil (for the default value),
2521 a vector which identifies a character set or a row of a character set,
2522 a character set name, or a character code.
2523 If the characters in the specified range have different values,
2524 an error is signaled.
2526 Note that this function doesn't check the parent of CHAR-TABLE. */)
2528 Lisp_Object char_table
, range
;
2530 int charset_id
, c1
= 0, c2
= 0;
2532 Lisp_Object ch
, val
, current_default
;
2534 CHECK_CHAR_TABLE (char_table
);
2536 if (EQ (range
, Qnil
))
2537 return XCHAR_TABLE (char_table
)->defalt
;
2538 if (INTEGERP (range
))
2540 int c
= XINT (range
);
2541 if (! CHAR_VALID_P (c
, 0))
2542 error ("Invalid character code: %d", c
);
2544 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2546 else if (SYMBOLP (range
))
2548 Lisp_Object charset_info
;
2550 charset_info
= Fget (range
, Qcharset
);
2551 CHECK_VECTOR (charset_info
);
2552 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2553 ch
= Fmake_char_internal (make_number (charset_id
),
2554 make_number (0), make_number (0));
2556 else if (VECTORP (range
))
2558 size
= ASIZE (range
);
2560 args_out_of_range (range
, make_number (0));
2561 CHECK_NUMBER (AREF (range
, 0));
2562 charset_id
= XINT (AREF (range
, 0));
2565 CHECK_NUMBER (AREF (range
, 1));
2566 c1
= XINT (AREF (range
, 1));
2569 CHECK_NUMBER (AREF (range
, 2));
2570 c2
= XINT (AREF (range
, 2));
2574 /* This checks if charset_id, c0, and c1 are all valid or not. */
2575 ch
= Fmake_char_internal (make_number (charset_id
),
2576 make_number (c1
), make_number (c2
));
2579 error ("Invalid RANGE argument to `char-table-range'");
2581 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2583 /* Fully specified character. */
2584 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2586 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2587 val
= Faref (char_table
, ch
);
2588 XCHAR_TABLE (char_table
)->parent
= parent
;
2592 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2593 if (charset_id
== CHARSET_ASCII
2594 || charset_id
== CHARSET_8_BIT_CONTROL
2595 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2597 int from
, to
, defalt
;
2599 if (charset_id
== CHARSET_ASCII
)
2600 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2601 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2602 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2604 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2605 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2606 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2607 return char_table_range (char_table
, from
, to
, current_default
);
2610 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2611 if (! SUB_CHAR_TABLE_P (val
))
2612 return (NILP (val
) ? current_default
: val
);
2613 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2614 current_default
= XCHAR_TABLE (val
)->defalt
;
2616 return char_table_range (val
, 32, 127, current_default
);
2617 val
= XCHAR_TABLE (val
)->contents
[c1
];
2618 if (! SUB_CHAR_TABLE_P (val
))
2619 return (NILP (val
) ? current_default
: val
);
2620 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2621 current_default
= XCHAR_TABLE (val
)->defalt
;
2622 return char_table_range (val
, 32, 127, current_default
);
2625 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2627 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2628 RANGE should be t (for all characters), nil (for the default value),
2629 a character set, a vector which identifies a character set, a row of a
2630 character set, or a character code. Return VALUE. */)
2631 (char_table
, range
, value
)
2632 Lisp_Object char_table
, range
, value
;
2636 CHECK_CHAR_TABLE (char_table
);
2639 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2641 /* Don't set these special slots used for default values of
2642 ascii, eight-bit-control, and eight-bit-graphic. */
2643 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2644 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2645 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2646 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2648 else if (EQ (range
, Qnil
))
2649 XCHAR_TABLE (char_table
)->defalt
= value
;
2650 else if (SYMBOLP (range
))
2652 Lisp_Object charset_info
;
2655 charset_info
= Fget (range
, Qcharset
);
2656 if (! VECTORP (charset_info
)
2657 || ! NATNUMP (AREF (charset_info
, 0))
2658 || (charset_id
= XINT (AREF (charset_info
, 0)),
2659 ! CHARSET_DEFINED_P (charset_id
)))
2660 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2662 if (charset_id
== CHARSET_ASCII
)
2663 for (i
= 0; i
< 128; i
++)
2664 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2665 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2666 for (i
= 128; i
< 160; i
++)
2667 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2668 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2669 for (i
= 160; i
< 256; i
++)
2670 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2672 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2674 else if (INTEGERP (range
))
2675 Faset (char_table
, range
, value
);
2676 else if (VECTORP (range
))
2678 int size
= XVECTOR (range
)->size
;
2679 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2680 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2681 size
<= 1 ? Qnil
: val
[1],
2682 size
<= 2 ? Qnil
: val
[2]);
2683 Faset (char_table
, ch
, value
);
2686 error ("Invalid RANGE argument to `set-char-table-range'");
2691 DEFUN ("set-char-table-default", Fset_char_table_default
,
2692 Sset_char_table_default
, 3, 3, 0,
2693 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2694 The generic character specifies the group of characters.
2695 If CH is a normal character, set the default value for a group of
2696 characters to which CH belongs.
2697 See also the documentation of `make-char'. */)
2698 (char_table
, ch
, value
)
2699 Lisp_Object char_table
, ch
, value
;
2701 int c
, charset
, code1
, code2
;
2704 CHECK_CHAR_TABLE (char_table
);
2708 SPLIT_CHAR (c
, charset
, code1
, code2
);
2710 /* Since we may want to set the default value for a character set
2711 not yet defined, we check only if the character set is in the
2712 valid range or not, instead of it is already defined or not. */
2713 if (! CHARSET_VALID_P (charset
))
2714 invalid_character (c
);
2716 if (SINGLE_BYTE_CHAR_P (c
))
2718 /* We use special slots for the default values of single byte
2721 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2722 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2723 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2725 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2728 /* Even if C is not a generic char, we had better behave as if a
2729 generic char is specified. */
2730 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2732 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2733 if (! SUB_CHAR_TABLE_P (temp
))
2735 temp
= make_sub_char_table (temp
);
2736 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2740 XCHAR_TABLE (temp
)->defalt
= value
;
2744 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2745 if (SUB_CHAR_TABLE_P (temp
))
2746 XCHAR_TABLE (temp
)->defalt
= value
;
2748 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2752 /* Look up the element in TABLE at index CH,
2753 and return it as an integer.
2754 If the element is nil, return CH itself.
2755 (Actually we do that for any non-integer.) */
2758 char_table_translate (table
, ch
)
2763 value
= Faref (table
, make_number (ch
));
2764 if (! INTEGERP (value
))
2766 return XINT (value
);
2770 optimize_sub_char_table (table
, chars
)
2778 from
= 33, to
= 127;
2780 from
= 32, to
= 128;
2782 if (!SUB_CHAR_TABLE_P (*table
)
2783 || ! NILP (XCHAR_TABLE (*table
)->defalt
))
2785 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2786 for (; from
< to
; from
++)
2787 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2792 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2793 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2801 CHECK_CHAR_TABLE (table
);
2803 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2805 elt
= XCHAR_TABLE (table
)->contents
[i
];
2806 if (!SUB_CHAR_TABLE_P (elt
))
2808 dim
= CHARSET_DIMENSION (i
- 128);
2809 chars
= CHARSET_CHARS (i
- 128);
2811 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2812 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, chars
);
2813 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, chars
);
2819 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2820 character or group of characters that share a value.
2821 DEPTH is the current depth in the originally specified
2822 chartable, and INDICES contains the vector indices
2823 for the levels our callers have descended.
2825 ARG is passed to C_FUNCTION when that is called. */
2828 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2829 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2830 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2834 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2836 GCPRO4 (arg
, table
, subtable
, function
);
2840 /* At first, handle ASCII and 8-bit European characters. */
2841 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2843 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2845 elt
= XCHAR_TABLE (subtable
)->defalt
;
2847 elt
= Faref (subtable
, make_number (i
));
2849 (*c_function
) (arg
, make_number (i
), elt
);
2851 call2 (function
, make_number (i
), elt
);
2853 #if 0 /* If the char table has entries for higher characters,
2854 we should report them. */
2855 if (NILP (current_buffer
->enable_multibyte_characters
))
2861 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2865 int charset
= XFASTINT (indices
[0]) - 128;
2868 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2869 if (CHARSET_CHARS (charset
) == 94)
2878 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2879 XSETFASTINT (indices
[depth
], i
);
2880 charset
= XFASTINT (indices
[0]) - 128;
2882 && (!CHARSET_DEFINED_P (charset
)
2883 || charset
== CHARSET_8_BIT_CONTROL
2884 || charset
== CHARSET_8_BIT_GRAPHIC
))
2887 if (SUB_CHAR_TABLE_P (elt
))
2890 error ("Too deep char table");
2891 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2897 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2898 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2899 c
= MAKE_CHAR (charset
, c1
, c2
);
2902 elt
= XCHAR_TABLE (subtable
)->defalt
;
2904 elt
= Faref (table
, make_number (c
));
2907 (*c_function
) (arg
, make_number (c
), elt
);
2909 call2 (function
, make_number (c
), elt
);
2915 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2917 void_call2 (a
, b
, c
)
2918 Lisp_Object a
, b
, c
;
2923 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2925 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2926 FUNCTION is called with two arguments--a key and a value.
2927 The key is always a possible IDX argument to `aref'. */)
2928 (function
, char_table
)
2929 Lisp_Object function
, char_table
;
2931 /* The depth of char table is at most 3. */
2932 Lisp_Object indices
[3];
2934 CHECK_CHAR_TABLE (char_table
);
2936 /* When Lisp_Object is represented as a union, `call2' cannot directly
2937 be passed to map_char_table because it returns a Lisp_Object rather
2938 than returning nothing.
2939 Casting leads to crashes on some architectures. -stef */
2940 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2944 /* Return a value for character C in char-table TABLE. Store the
2945 actual index for that value in *IDX. Ignore the default value of
2949 char_table_ref_and_index (table
, c
, idx
)
2953 int charset
, c1
, c2
;
2956 if (SINGLE_BYTE_CHAR_P (c
))
2959 return XCHAR_TABLE (table
)->contents
[c
];
2961 SPLIT_CHAR (c
, charset
, c1
, c2
);
2962 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2963 *idx
= MAKE_CHAR (charset
, 0, 0);
2964 if (!SUB_CHAR_TABLE_P (elt
))
2966 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2967 return XCHAR_TABLE (elt
)->defalt
;
2968 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2969 *idx
= MAKE_CHAR (charset
, c1
, 0);
2970 if (!SUB_CHAR_TABLE_P (elt
))
2972 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2973 return XCHAR_TABLE (elt
)->defalt
;
2975 return XCHAR_TABLE (elt
)->contents
[c2
];
2985 Lisp_Object args
[2];
2988 return Fnconc (2, args
);
2990 return Fnconc (2, &s1
);
2991 #endif /* NO_ARG_ARRAY */
2994 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2995 doc
: /* Concatenate any number of lists by altering them.
2996 Only the last argument is not altered, and need not be a list.
2997 usage: (nconc &rest LISTS) */)
3002 register int argnum
;
3003 register Lisp_Object tail
, tem
, val
;
3007 for (argnum
= 0; argnum
< nargs
; argnum
++)
3010 if (NILP (tem
)) continue;
3015 if (argnum
+ 1 == nargs
) break;
3017 CHECK_LIST_CONS (tem
, tem
);
3026 tem
= args
[argnum
+ 1];
3027 Fsetcdr (tail
, tem
);
3029 args
[argnum
+ 1] = tail
;
3035 /* This is the guts of all mapping functions.
3036 Apply FN to each element of SEQ, one by one,
3037 storing the results into elements of VALS, a C vector of Lisp_Objects.
3038 LENI is the length of VALS, which should also be the length of SEQ. */
3041 mapcar1 (leni
, vals
, fn
, seq
)
3044 Lisp_Object fn
, seq
;
3046 register Lisp_Object tail
;
3049 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3053 /* Don't let vals contain any garbage when GC happens. */
3054 for (i
= 0; i
< leni
; i
++)
3057 GCPRO3 (dummy
, fn
, seq
);
3059 gcpro1
.nvars
= leni
;
3063 /* We need not explicitly protect `tail' because it is used only on lists, and
3064 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3068 for (i
= 0; i
< leni
; i
++)
3070 dummy
= XVECTOR (seq
)->contents
[i
];
3071 dummy
= call1 (fn
, dummy
);
3076 else if (BOOL_VECTOR_P (seq
))
3078 for (i
= 0; i
< leni
; i
++)
3081 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3082 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3087 dummy
= call1 (fn
, dummy
);
3092 else if (STRINGP (seq
))
3096 for (i
= 0, i_byte
= 0; i
< leni
;)
3101 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3102 XSETFASTINT (dummy
, c
);
3103 dummy
= call1 (fn
, dummy
);
3105 vals
[i_before
] = dummy
;
3108 else /* Must be a list, since Flength did not get an error */
3111 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3113 dummy
= call1 (fn
, XCAR (tail
));
3123 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3124 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3125 In between each pair of results, stick in SEPARATOR. Thus, " " as
3126 SEPARATOR results in spaces between the values returned by FUNCTION.
3127 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3128 (function
, sequence
, separator
)
3129 Lisp_Object function
, sequence
, separator
;
3134 register Lisp_Object
*args
;
3136 struct gcpro gcpro1
;
3140 len
= Flength (sequence
);
3142 nargs
= leni
+ leni
- 1;
3143 if (nargs
< 0) return build_string ("");
3145 SAFE_ALLOCA_LISP (args
, nargs
);
3148 mapcar1 (leni
, args
, function
, sequence
);
3151 for (i
= leni
- 1; i
> 0; i
--)
3152 args
[i
+ i
] = args
[i
];
3154 for (i
= 1; i
< nargs
; i
+= 2)
3155 args
[i
] = separator
;
3157 ret
= Fconcat (nargs
, args
);
3163 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3164 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3165 The result is a list just as long as SEQUENCE.
3166 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3167 (function
, sequence
)
3168 Lisp_Object function
, sequence
;
3170 register Lisp_Object len
;
3172 register Lisp_Object
*args
;
3176 len
= Flength (sequence
);
3177 leni
= XFASTINT (len
);
3179 SAFE_ALLOCA_LISP (args
, leni
);
3181 mapcar1 (leni
, args
, function
, sequence
);
3183 ret
= Flist (leni
, args
);
3189 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3190 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3191 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3192 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3193 (function
, sequence
)
3194 Lisp_Object function
, sequence
;
3198 leni
= XFASTINT (Flength (sequence
));
3199 mapcar1 (leni
, 0, function
, sequence
);
3204 /* Anything that calls this function must protect from GC! */
3206 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3207 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3208 Takes one argument, which is the string to display to ask the question.
3209 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3210 No confirmation of the answer is requested; a single character is enough.
3211 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3212 the bindings in `query-replace-map'; see the documentation of that variable
3213 for more information. In this case, the useful bindings are `act', `skip',
3214 `recenter', and `quit'.\)
3216 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3217 is nil and `use-dialog-box' is non-nil. */)
3221 register Lisp_Object obj
, key
, def
, map
;
3222 register int answer
;
3223 Lisp_Object xprompt
;
3224 Lisp_Object args
[2];
3225 struct gcpro gcpro1
, gcpro2
;
3226 int count
= SPECPDL_INDEX ();
3228 specbind (Qcursor_in_echo_area
, Qt
);
3230 map
= Fsymbol_value (intern ("query-replace-map"));
3232 CHECK_STRING (prompt
);
3234 GCPRO2 (prompt
, xprompt
);
3236 #ifdef HAVE_X_WINDOWS
3237 if (display_hourglass_p
)
3238 cancel_hourglass ();
3245 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3249 Lisp_Object pane
, menu
;
3250 redisplay_preserve_echo_area (3);
3251 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3252 Fcons (Fcons (build_string ("No"), Qnil
),
3254 menu
= Fcons (prompt
, pane
);
3255 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3256 answer
= !NILP (obj
);
3259 #endif /* HAVE_MENUS */
3260 cursor_in_echo_area
= 1;
3261 choose_minibuf_frame ();
3264 Lisp_Object pargs
[3];
3266 /* Colorize prompt according to `minibuffer-prompt' face. */
3267 pargs
[0] = build_string ("%s(y or n) ");
3268 pargs
[1] = intern ("face");
3269 pargs
[2] = intern ("minibuffer-prompt");
3270 args
[0] = Fpropertize (3, pargs
);
3275 if (minibuffer_auto_raise
)
3277 Lisp_Object mini_frame
;
3279 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3281 Fraise_frame (mini_frame
);
3284 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
3285 cursor_in_echo_area
= 0;
3286 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3289 key
= Fmake_vector (make_number (1), obj
);
3290 def
= Flookup_key (map
, key
, Qt
);
3292 if (EQ (def
, intern ("skip")))
3297 else if (EQ (def
, intern ("act")))
3302 else if (EQ (def
, intern ("recenter")))
3308 else if (EQ (def
, intern ("quit")))
3310 /* We want to exit this command for exit-prefix,
3311 and this is the only way to do it. */
3312 else if (EQ (def
, intern ("exit-prefix")))
3317 /* If we don't clear this, then the next call to read_char will
3318 return quit_char again, and we'll enter an infinite loop. */
3323 if (EQ (xprompt
, prompt
))
3325 args
[0] = build_string ("Please answer y or n. ");
3327 xprompt
= Fconcat (2, args
);
3332 if (! noninteractive
)
3334 cursor_in_echo_area
= -1;
3335 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3339 unbind_to (count
, Qnil
);
3340 return answer
? Qt
: Qnil
;
3343 /* This is how C code calls `yes-or-no-p' and allows the user
3346 Anything that calls this function must protect from GC! */
3349 do_yes_or_no_p (prompt
)
3352 return call1 (intern ("yes-or-no-p"), prompt
);
3355 /* Anything that calls this function must protect from GC! */
3357 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3358 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3359 Takes one argument, which is the string to display to ask the question.
3360 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3361 The user must confirm the answer with RET,
3362 and can edit it until it has been confirmed.
3364 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3365 is nil, and `use-dialog-box' is non-nil. */)
3369 register Lisp_Object ans
;
3370 Lisp_Object args
[2];
3371 struct gcpro gcpro1
;
3373 CHECK_STRING (prompt
);
3376 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3380 Lisp_Object pane
, menu
, obj
;
3381 redisplay_preserve_echo_area (4);
3382 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3383 Fcons (Fcons (build_string ("No"), Qnil
),
3386 menu
= Fcons (prompt
, pane
);
3387 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3391 #endif /* HAVE_MENUS */
3394 args
[1] = build_string ("(yes or no) ");
3395 prompt
= Fconcat (2, args
);
3401 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3402 Qyes_or_no_p_history
, Qnil
,
3404 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3409 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3417 message ("Please answer yes or no.");
3418 Fsleep_for (make_number (2), Qnil
);
3422 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3423 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3425 Each of the three load averages is multiplied by 100, then converted
3428 When USE-FLOATS is non-nil, floats will be used instead of integers.
3429 These floats are not multiplied by 100.
3431 If the 5-minute or 15-minute load averages are not available, return a
3432 shortened list, containing only those averages which are available.
3434 An error is thrown if the load average can't be obtained. In some
3435 cases making it work would require Emacs being installed setuid or
3436 setgid so that it can read kernel information, and that usually isn't
3439 Lisp_Object use_floats
;
3442 int loads
= getloadavg (load_ave
, 3);
3443 Lisp_Object ret
= Qnil
;
3446 error ("load-average not implemented for this operating system");
3450 Lisp_Object load
= (NILP (use_floats
) ?
3451 make_number ((int) (100.0 * load_ave
[loads
]))
3452 : make_float (load_ave
[loads
]));
3453 ret
= Fcons (load
, ret
);
3459 Lisp_Object Vfeatures
, Qsubfeatures
;
3460 extern Lisp_Object Vafter_load_alist
;
3462 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3463 doc
: /* Returns t if FEATURE is present in this Emacs.
3465 Use this to conditionalize execution of lisp code based on the
3466 presence or absence of Emacs or environment extensions.
3467 Use `provide' to declare that a feature is available. This function
3468 looks at the value of the variable `features'. The optional argument
3469 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3470 (feature
, subfeature
)
3471 Lisp_Object feature
, subfeature
;
3473 register Lisp_Object tem
;
3474 CHECK_SYMBOL (feature
);
3475 tem
= Fmemq (feature
, Vfeatures
);
3476 if (!NILP (tem
) && !NILP (subfeature
))
3477 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3478 return (NILP (tem
)) ? Qnil
: Qt
;
3481 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3482 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3483 The optional argument SUBFEATURES should be a list of symbols listing
3484 particular subfeatures supported in this version of FEATURE. */)
3485 (feature
, subfeatures
)
3486 Lisp_Object feature
, subfeatures
;
3488 register Lisp_Object tem
;
3489 CHECK_SYMBOL (feature
);
3490 CHECK_LIST (subfeatures
);
3491 if (!NILP (Vautoload_queue
))
3492 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
3494 tem
= Fmemq (feature
, Vfeatures
);
3496 Vfeatures
= Fcons (feature
, Vfeatures
);
3497 if (!NILP (subfeatures
))
3498 Fput (feature
, Qsubfeatures
, subfeatures
);
3499 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3501 /* Run any load-hooks for this file. */
3502 tem
= Fassq (feature
, Vafter_load_alist
);
3504 Fprogn (XCDR (tem
));
3509 /* `require' and its subroutines. */
3511 /* List of features currently being require'd, innermost first. */
3513 Lisp_Object require_nesting_list
;
3516 require_unwind (old_value
)
3517 Lisp_Object old_value
;
3519 return require_nesting_list
= old_value
;
3522 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3523 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3524 If FEATURE is not a member of the list `features', then the feature
3525 is not loaded; so load the file FILENAME.
3526 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3527 and `load' will try to load this name appended with the suffix `.elc' or
3528 `.el', in that order. The name without appended suffix will not be used.
3529 If the optional third argument NOERROR is non-nil,
3530 then return nil if the file is not found instead of signaling an error.
3531 Normally the return value is FEATURE.
3532 The normal messages at start and end of loading FILENAME are suppressed. */)
3533 (feature
, filename
, noerror
)
3534 Lisp_Object feature
, filename
, noerror
;
3536 register Lisp_Object tem
;
3537 struct gcpro gcpro1
, gcpro2
;
3538 int from_file
= load_in_progress
;
3540 CHECK_SYMBOL (feature
);
3542 /* Record the presence of `require' in this file
3543 even if the feature specified is already loaded.
3544 But not more than once in any file,
3545 and not when we aren't loading or reading from a file. */
3547 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3548 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3553 tem
= Fcons (Qrequire
, feature
);
3554 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3555 LOADHIST_ATTACH (tem
);
3557 tem
= Fmemq (feature
, Vfeatures
);
3561 int count
= SPECPDL_INDEX ();
3564 /* This is to make sure that loadup.el gives a clear picture
3565 of what files are preloaded and when. */
3566 if (! NILP (Vpurify_flag
))
3567 error ("(require %s) while preparing to dump",
3568 SDATA (SYMBOL_NAME (feature
)));
3570 /* A certain amount of recursive `require' is legitimate,
3571 but if we require the same feature recursively 3 times,
3573 tem
= require_nesting_list
;
3574 while (! NILP (tem
))
3576 if (! NILP (Fequal (feature
, XCAR (tem
))))
3581 error ("Recursive `require' for feature `%s'",
3582 SDATA (SYMBOL_NAME (feature
)));
3584 /* Update the list for any nested `require's that occur. */
3585 record_unwind_protect (require_unwind
, require_nesting_list
);
3586 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3588 /* Value saved here is to be restored into Vautoload_queue */
3589 record_unwind_protect (un_autoload
, Vautoload_queue
);
3590 Vautoload_queue
= Qt
;
3592 /* Load the file. */
3593 GCPRO2 (feature
, filename
);
3594 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3595 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3598 /* If load failed entirely, return nil. */
3600 return unbind_to (count
, Qnil
);
3602 tem
= Fmemq (feature
, Vfeatures
);
3604 error ("Required feature `%s' was not provided",
3605 SDATA (SYMBOL_NAME (feature
)));
3607 /* Once loading finishes, don't undo it. */
3608 Vautoload_queue
= Qt
;
3609 feature
= unbind_to (count
, feature
);
3615 /* Primitives for work of the "widget" library.
3616 In an ideal world, this section would not have been necessary.
3617 However, lisp function calls being as slow as they are, it turns
3618 out that some functions in the widget library (wid-edit.el) are the
3619 bottleneck of Widget operation. Here is their translation to C,
3620 for the sole reason of efficiency. */
3622 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3623 doc
: /* Return non-nil if PLIST has the property PROP.
3624 PLIST is a property list, which is a list of the form
3625 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3626 Unlike `plist-get', this allows you to distinguish between a missing
3627 property and a property with the value nil.
3628 The value is actually the tail of PLIST whose car is PROP. */)
3630 Lisp_Object plist
, prop
;
3632 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3635 plist
= XCDR (plist
);
3636 plist
= CDR (plist
);
3641 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3642 doc
: /* In WIDGET, set PROPERTY to VALUE.
3643 The value can later be retrieved with `widget-get'. */)
3644 (widget
, property
, value
)
3645 Lisp_Object widget
, property
, value
;
3647 CHECK_CONS (widget
);
3648 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3652 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3653 doc
: /* In WIDGET, get the value of PROPERTY.
3654 The value could either be specified when the widget was created, or
3655 later with `widget-put'. */)
3657 Lisp_Object widget
, property
;
3665 CHECK_CONS (widget
);
3666 tmp
= Fplist_member (XCDR (widget
), property
);
3672 tmp
= XCAR (widget
);
3675 widget
= Fget (tmp
, Qwidget_type
);
3679 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3680 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3681 ARGS are passed as extra arguments to the function.
3682 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3687 /* This function can GC. */
3688 Lisp_Object newargs
[3];
3689 struct gcpro gcpro1
, gcpro2
;
3692 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3693 newargs
[1] = args
[0];
3694 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3695 GCPRO2 (newargs
[0], newargs
[2]);
3696 result
= Fapply (3, newargs
);
3701 #ifdef HAVE_LANGINFO_CODESET
3702 #include <langinfo.h>
3705 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3706 doc
: /* Access locale data ITEM for the current C locale, if available.
3707 ITEM should be one of the following:
3709 `codeset', returning the character set as a string (locale item CODESET);
3711 `days', returning a 7-element vector of day names (locale items DAY_n);
3713 `months', returning a 12-element vector of month names (locale items MON_n);
3715 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3716 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3718 If the system can't provide such information through a call to
3719 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3721 See also Info node `(libc)Locales'.
3723 The data read from the system are decoded using `locale-coding-system'. */)
3728 #ifdef HAVE_LANGINFO_CODESET
3730 if (EQ (item
, Qcodeset
))
3732 str
= nl_langinfo (CODESET
);
3733 return build_string (str
);
3736 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3738 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3739 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3741 synchronize_system_time_locale ();
3742 for (i
= 0; i
< 7; i
++)
3744 str
= nl_langinfo (days
[i
]);
3745 val
= make_unibyte_string (str
, strlen (str
));
3746 /* Fixme: Is this coding system necessarily right, even if
3747 it is consistent with CODESET? If not, what to do? */
3748 Faset (v
, make_number (i
),
3749 code_convert_string_norecord (val
, Vlocale_coding_system
,
3756 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3758 struct Lisp_Vector
*p
= allocate_vector (12);
3759 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3760 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3762 synchronize_system_time_locale ();
3763 for (i
= 0; i
< 12; i
++)
3765 str
= nl_langinfo (months
[i
]);
3766 val
= make_unibyte_string (str
, strlen (str
));
3768 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3770 XSETVECTOR (val
, p
);
3774 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3775 but is in the locale files. This could be used by ps-print. */
3777 else if (EQ (item
, Qpaper
))
3779 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3780 make_number (nl_langinfo (PAPER_HEIGHT
)));
3782 #endif /* PAPER_WIDTH */
3783 #endif /* HAVE_LANGINFO_CODESET*/
3787 /* base64 encode/decode functions (RFC 2045).
3788 Based on code from GNU recode. */
3790 #define MIME_LINE_LENGTH 76
3792 #define IS_ASCII(Character) \
3794 #define IS_BASE64(Character) \
3795 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3796 #define IS_BASE64_IGNORABLE(Character) \
3797 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3798 || (Character) == '\f' || (Character) == '\r')
3800 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3801 character or return retval if there are no characters left to
3803 #define READ_QUADRUPLET_BYTE(retval) \
3808 if (nchars_return) \
3809 *nchars_return = nchars; \
3814 while (IS_BASE64_IGNORABLE (c))
3816 /* Table of characters coding the 64 values. */
3817 static char base64_value_to_char
[64] =
3819 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3820 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3821 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3822 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3823 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3824 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3825 '8', '9', '+', '/' /* 60-63 */
3828 /* Table of base64 values for first 128 characters. */
3829 static short base64_char_to_value
[128] =
3831 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3832 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3833 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3834 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3835 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3836 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3837 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3838 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3839 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3840 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3841 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3842 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3843 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3846 /* The following diagram shows the logical steps by which three octets
3847 get transformed into four base64 characters.
3849 .--------. .--------. .--------.
3850 |aaaaaabb| |bbbbcccc| |ccdddddd|
3851 `--------' `--------' `--------'
3853 .--------+--------+--------+--------.
3854 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3855 `--------+--------+--------+--------'
3857 .--------+--------+--------+--------.
3858 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3859 `--------+--------+--------+--------'
3861 The octets are divided into 6 bit chunks, which are then encoded into
3862 base64 characters. */
3865 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3866 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3868 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3870 doc
: /* Base64-encode the region between BEG and END.
3871 Return the length of the encoded text.
3872 Optional third argument NO-LINE-BREAK means do not break long lines
3873 into shorter lines. */)
3874 (beg
, end
, no_line_break
)
3875 Lisp_Object beg
, end
, no_line_break
;
3878 int allength
, length
;
3879 int ibeg
, iend
, encoded_length
;
3883 validate_region (&beg
, &end
);
3885 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3886 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3887 move_gap_both (XFASTINT (beg
), ibeg
);
3889 /* We need to allocate enough room for encoding the text.
3890 We need 33 1/3% more space, plus a newline every 76
3891 characters, and then we round up. */
3892 length
= iend
- ibeg
;
3893 allength
= length
+ length
/3 + 1;
3894 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3896 SAFE_ALLOCA (encoded
, char *, allength
);
3897 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3898 NILP (no_line_break
),
3899 !NILP (current_buffer
->enable_multibyte_characters
));
3900 if (encoded_length
> allength
)
3903 if (encoded_length
< 0)
3905 /* The encoding wasn't possible. */
3907 error ("Multibyte character in data for base64 encoding");
3910 /* Now we have encoded the region, so we insert the new contents
3911 and delete the old. (Insert first in order to preserve markers.) */
3912 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3913 insert (encoded
, encoded_length
);
3915 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3917 /* If point was outside of the region, restore it exactly; else just
3918 move to the beginning of the region. */
3919 if (old_pos
>= XFASTINT (end
))
3920 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3921 else if (old_pos
> XFASTINT (beg
))
3922 old_pos
= XFASTINT (beg
);
3925 /* We return the length of the encoded text. */
3926 return make_number (encoded_length
);
3929 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3931 doc
: /* Base64-encode STRING and return the result.
3932 Optional second argument NO-LINE-BREAK means do not break long lines
3933 into shorter lines. */)
3934 (string
, no_line_break
)
3935 Lisp_Object string
, no_line_break
;
3937 int allength
, length
, encoded_length
;
3939 Lisp_Object encoded_string
;
3942 CHECK_STRING (string
);
3944 /* We need to allocate enough room for encoding the text.
3945 We need 33 1/3% more space, plus a newline every 76
3946 characters, and then we round up. */
3947 length
= SBYTES (string
);
3948 allength
= length
+ length
/3 + 1;
3949 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3951 /* We need to allocate enough room for decoding the text. */
3952 SAFE_ALLOCA (encoded
, char *, allength
);
3954 encoded_length
= base64_encode_1 (SDATA (string
),
3955 encoded
, length
, NILP (no_line_break
),
3956 STRING_MULTIBYTE (string
));
3957 if (encoded_length
> allength
)
3960 if (encoded_length
< 0)
3962 /* The encoding wasn't possible. */
3964 error ("Multibyte character in data for base64 encoding");
3967 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3970 return encoded_string
;
3974 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3981 int counter
= 0, i
= 0;
3991 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3999 /* Wrap line every 76 characters. */
4003 if (counter
< MIME_LINE_LENGTH
/ 4)
4012 /* Process first byte of a triplet. */
4014 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
4015 value
= (0x03 & c
) << 4;
4017 /* Process second byte of a triplet. */
4021 *e
++ = base64_value_to_char
[value
];
4029 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4037 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4038 value
= (0x0f & c
) << 2;
4040 /* Process third byte of a triplet. */
4044 *e
++ = base64_value_to_char
[value
];
4051 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4059 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4060 *e
++ = base64_value_to_char
[0x3f & c
];
4067 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4069 doc
: /* Base64-decode the region between BEG and END.
4070 Return the length of the decoded text.
4071 If the region can't be decoded, signal an error and don't modify the buffer. */)
4073 Lisp_Object beg
, end
;
4075 int ibeg
, iend
, length
, allength
;
4080 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4083 validate_region (&beg
, &end
);
4085 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4086 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4088 length
= iend
- ibeg
;
4090 /* We need to allocate enough room for decoding the text. If we are
4091 working on a multibyte buffer, each decoded code may occupy at
4093 allength
= multibyte
? length
* 2 : length
;
4094 SAFE_ALLOCA (decoded
, char *, allength
);
4096 move_gap_both (XFASTINT (beg
), ibeg
);
4097 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4098 multibyte
, &inserted_chars
);
4099 if (decoded_length
> allength
)
4102 if (decoded_length
< 0)
4104 /* The decoding wasn't possible. */
4106 error ("Invalid base64 data");
4109 /* Now we have decoded the region, so we insert the new contents
4110 and delete the old. (Insert first in order to preserve markers.) */
4111 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4112 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4115 /* Delete the original text. */
4116 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4117 iend
+ decoded_length
, 1);
4119 /* If point was outside of the region, restore it exactly; else just
4120 move to the beginning of the region. */
4121 if (old_pos
>= XFASTINT (end
))
4122 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4123 else if (old_pos
> XFASTINT (beg
))
4124 old_pos
= XFASTINT (beg
);
4125 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4127 return make_number (inserted_chars
);
4130 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4132 doc
: /* Base64-decode STRING and return the result. */)
4137 int length
, decoded_length
;
4138 Lisp_Object decoded_string
;
4141 CHECK_STRING (string
);
4143 length
= SBYTES (string
);
4144 /* We need to allocate enough room for decoding the text. */
4145 SAFE_ALLOCA (decoded
, char *, length
);
4147 /* The decoded result should be unibyte. */
4148 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4150 if (decoded_length
> length
)
4152 else if (decoded_length
>= 0)
4153 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4155 decoded_string
= Qnil
;
4158 if (!STRINGP (decoded_string
))
4159 error ("Invalid base64 data");
4161 return decoded_string
;
4164 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4165 MULTIBYTE is nonzero, the decoded result should be in multibyte
4166 form. If NCHARS_RETRUN is not NULL, store the number of produced
4167 characters in *NCHARS_RETURN. */
4170 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4180 unsigned long value
;
4185 /* Process first byte of a quadruplet. */
4187 READ_QUADRUPLET_BYTE (e
-to
);
4191 value
= base64_char_to_value
[c
] << 18;
4193 /* Process second byte of a quadruplet. */
4195 READ_QUADRUPLET_BYTE (-1);
4199 value
|= base64_char_to_value
[c
] << 12;
4201 c
= (unsigned char) (value
>> 16);
4203 e
+= CHAR_STRING (c
, e
);
4208 /* Process third byte of a quadruplet. */
4210 READ_QUADRUPLET_BYTE (-1);
4214 READ_QUADRUPLET_BYTE (-1);
4223 value
|= base64_char_to_value
[c
] << 6;
4225 c
= (unsigned char) (0xff & value
>> 8);
4227 e
+= CHAR_STRING (c
, e
);
4232 /* Process fourth byte of a quadruplet. */
4234 READ_QUADRUPLET_BYTE (-1);
4241 value
|= base64_char_to_value
[c
];
4243 c
= (unsigned char) (0xff & value
);
4245 e
+= CHAR_STRING (c
, e
);
4254 /***********************************************************************
4256 ***** Hash Tables *****
4258 ***********************************************************************/
4260 /* Implemented by gerd@gnu.org. This hash table implementation was
4261 inspired by CMUCL hash tables. */
4265 1. For small tables, association lists are probably faster than
4266 hash tables because they have lower overhead.
4268 For uses of hash tables where the O(1) behavior of table
4269 operations is not a requirement, it might therefore be a good idea
4270 not to hash. Instead, we could just do a linear search in the
4271 key_and_value vector of the hash table. This could be done
4272 if a `:linear-search t' argument is given to make-hash-table. */
4275 /* The list of all weak hash tables. Don't staticpro this one. */
4277 Lisp_Object Vweak_hash_tables
;
4279 /* Various symbols. */
4281 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4282 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4283 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4285 /* Function prototypes. */
4287 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4288 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4289 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4290 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4291 Lisp_Object
, unsigned));
4292 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4293 Lisp_Object
, unsigned));
4294 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4295 unsigned, Lisp_Object
, unsigned));
4296 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4297 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4298 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4299 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4301 static unsigned sxhash_string
P_ ((unsigned char *, int));
4302 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4303 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4304 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4305 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4309 /***********************************************************************
4311 ***********************************************************************/
4313 /* If OBJ is a Lisp hash table, return a pointer to its struct
4314 Lisp_Hash_Table. Otherwise, signal an error. */
4316 static struct Lisp_Hash_Table
*
4317 check_hash_table (obj
)
4320 CHECK_HASH_TABLE (obj
);
4321 return XHASH_TABLE (obj
);
4325 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4329 next_almost_prime (n
)
4342 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4343 which USED[I] is non-zero. If found at index I in ARGS, set
4344 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4345 -1. This function is used to extract a keyword/argument pair from
4346 a DEFUN parameter list. */
4349 get_key_arg (key
, nargs
, args
, used
)
4357 for (i
= 0; i
< nargs
- 1; ++i
)
4358 if (!used
[i
] && EQ (args
[i
], key
))
4373 /* Return a Lisp vector which has the same contents as VEC but has
4374 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4375 vector that are not copied from VEC are set to INIT. */
4378 larger_vector (vec
, new_size
, init
)
4383 struct Lisp_Vector
*v
;
4386 xassert (VECTORP (vec
));
4387 old_size
= XVECTOR (vec
)->size
;
4388 xassert (new_size
>= old_size
);
4390 v
= allocate_vector (new_size
);
4391 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4392 old_size
* sizeof *v
->contents
);
4393 for (i
= old_size
; i
< new_size
; ++i
)
4394 v
->contents
[i
] = init
;
4395 XSETVECTOR (vec
, v
);
4400 /***********************************************************************
4402 ***********************************************************************/
4404 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4405 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4406 KEY2 are the same. */
4409 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4410 struct Lisp_Hash_Table
*h
;
4411 Lisp_Object key1
, key2
;
4412 unsigned hash1
, hash2
;
4414 return (FLOATP (key1
)
4416 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4420 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4421 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4422 KEY2 are the same. */
4425 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4426 struct Lisp_Hash_Table
*h
;
4427 Lisp_Object key1
, key2
;
4428 unsigned hash1
, hash2
;
4430 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4434 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4435 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4436 if KEY1 and KEY2 are the same. */
4439 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4440 struct Lisp_Hash_Table
*h
;
4441 Lisp_Object key1
, key2
;
4442 unsigned hash1
, hash2
;
4446 Lisp_Object args
[3];
4448 args
[0] = h
->user_cmp_function
;
4451 return !NILP (Ffuncall (3, args
));
4458 /* Value is a hash code for KEY for use in hash table H which uses
4459 `eq' to compare keys. The hash code returned is guaranteed to fit
4460 in a Lisp integer. */
4464 struct Lisp_Hash_Table
*h
;
4467 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4468 xassert ((hash
& ~INTMASK
) == 0);
4473 /* Value is a hash code for KEY for use in hash table H which uses
4474 `eql' to compare keys. The hash code returned is guaranteed to fit
4475 in a Lisp integer. */
4479 struct Lisp_Hash_Table
*h
;
4484 hash
= sxhash (key
, 0);
4486 hash
= XUINT (key
) ^ XGCTYPE (key
);
4487 xassert ((hash
& ~INTMASK
) == 0);
4492 /* Value is a hash code for KEY for use in hash table H which uses
4493 `equal' to compare keys. The hash code returned is guaranteed to fit
4494 in a Lisp integer. */
4497 hashfn_equal (h
, key
)
4498 struct Lisp_Hash_Table
*h
;
4501 unsigned hash
= sxhash (key
, 0);
4502 xassert ((hash
& ~INTMASK
) == 0);
4507 /* Value is a hash code for KEY for use in hash table H which uses as
4508 user-defined function to compare keys. The hash code returned is
4509 guaranteed to fit in a Lisp integer. */
4512 hashfn_user_defined (h
, key
)
4513 struct Lisp_Hash_Table
*h
;
4516 Lisp_Object args
[2], hash
;
4518 args
[0] = h
->user_hash_function
;
4520 hash
= Ffuncall (2, args
);
4521 if (!INTEGERP (hash
))
4522 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
4523 return XUINT (hash
);
4527 /* Create and initialize a new hash table.
4529 TEST specifies the test the hash table will use to compare keys.
4530 It must be either one of the predefined tests `eq', `eql' or
4531 `equal' or a symbol denoting a user-defined test named TEST with
4532 test and hash functions USER_TEST and USER_HASH.
4534 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4536 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4537 new size when it becomes full is computed by adding REHASH_SIZE to
4538 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4539 table's new size is computed by multiplying its old size with
4542 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4543 be resized when the ratio of (number of entries in the table) /
4544 (table size) is >= REHASH_THRESHOLD.
4546 WEAK specifies the weakness of the table. If non-nil, it must be
4547 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4550 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4551 user_test
, user_hash
)
4552 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4553 Lisp_Object user_test
, user_hash
;
4555 struct Lisp_Hash_Table
*h
;
4557 int index_size
, i
, sz
;
4559 /* Preconditions. */
4560 xassert (SYMBOLP (test
));
4561 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4562 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4563 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4564 xassert (FLOATP (rehash_threshold
)
4565 && XFLOATINT (rehash_threshold
) > 0
4566 && XFLOATINT (rehash_threshold
) <= 1.0);
4568 if (XFASTINT (size
) == 0)
4569 size
= make_number (1);
4571 /* Allocate a table and initialize it. */
4572 h
= allocate_hash_table ();
4574 /* Initialize hash table slots. */
4575 sz
= XFASTINT (size
);
4578 if (EQ (test
, Qeql
))
4580 h
->cmpfn
= cmpfn_eql
;
4581 h
->hashfn
= hashfn_eql
;
4583 else if (EQ (test
, Qeq
))
4586 h
->hashfn
= hashfn_eq
;
4588 else if (EQ (test
, Qequal
))
4590 h
->cmpfn
= cmpfn_equal
;
4591 h
->hashfn
= hashfn_equal
;
4595 h
->user_cmp_function
= user_test
;
4596 h
->user_hash_function
= user_hash
;
4597 h
->cmpfn
= cmpfn_user_defined
;
4598 h
->hashfn
= hashfn_user_defined
;
4602 h
->rehash_threshold
= rehash_threshold
;
4603 h
->rehash_size
= rehash_size
;
4604 h
->count
= make_number (0);
4605 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4606 h
->hash
= Fmake_vector (size
, Qnil
);
4607 h
->next
= Fmake_vector (size
, Qnil
);
4608 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4609 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4610 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4612 /* Set up the free list. */
4613 for (i
= 0; i
< sz
- 1; ++i
)
4614 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4615 h
->next_free
= make_number (0);
4617 XSET_HASH_TABLE (table
, h
);
4618 xassert (HASH_TABLE_P (table
));
4619 xassert (XHASH_TABLE (table
) == h
);
4621 /* Maybe add this hash table to the list of all weak hash tables. */
4623 h
->next_weak
= Qnil
;
4626 h
->next_weak
= Vweak_hash_tables
;
4627 Vweak_hash_tables
= table
;
4634 /* Return a copy of hash table H1. Keys and values are not copied,
4635 only the table itself is. */
4638 copy_hash_table (h1
)
4639 struct Lisp_Hash_Table
*h1
;
4642 struct Lisp_Hash_Table
*h2
;
4643 struct Lisp_Vector
*next
;
4645 h2
= allocate_hash_table ();
4646 next
= h2
->vec_next
;
4647 bcopy (h1
, h2
, sizeof *h2
);
4648 h2
->vec_next
= next
;
4649 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4650 h2
->hash
= Fcopy_sequence (h1
->hash
);
4651 h2
->next
= Fcopy_sequence (h1
->next
);
4652 h2
->index
= Fcopy_sequence (h1
->index
);
4653 XSET_HASH_TABLE (table
, h2
);
4655 /* Maybe add this hash table to the list of all weak hash tables. */
4656 if (!NILP (h2
->weak
))
4658 h2
->next_weak
= Vweak_hash_tables
;
4659 Vweak_hash_tables
= table
;
4666 /* Resize hash table H if it's too full. If H cannot be resized
4667 because it's already too large, throw an error. */
4670 maybe_resize_hash_table (h
)
4671 struct Lisp_Hash_Table
*h
;
4673 if (NILP (h
->next_free
))
4675 int old_size
= HASH_TABLE_SIZE (h
);
4676 int i
, new_size
, index_size
;
4678 if (INTEGERP (h
->rehash_size
))
4679 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4681 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4682 new_size
= max (old_size
+ 1, new_size
);
4683 index_size
= next_almost_prime ((int)
4685 / XFLOATINT (h
->rehash_threshold
)));
4686 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4687 error ("Hash table too large to resize");
4689 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4690 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4691 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4692 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4694 /* Update the free list. Do it so that new entries are added at
4695 the end of the free list. This makes some operations like
4697 for (i
= old_size
; i
< new_size
- 1; ++i
)
4698 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4700 if (!NILP (h
->next_free
))
4702 Lisp_Object last
, next
;
4704 last
= h
->next_free
;
4705 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4709 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4712 XSETFASTINT (h
->next_free
, old_size
);
4715 for (i
= 0; i
< old_size
; ++i
)
4716 if (!NILP (HASH_HASH (h
, i
)))
4718 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4719 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4720 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4721 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4727 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4728 the hash code of KEY. Value is the index of the entry in H
4729 matching KEY, or -1 if not found. */
4732 hash_lookup (h
, key
, hash
)
4733 struct Lisp_Hash_Table
*h
;
4738 int start_of_bucket
;
4741 hash_code
= h
->hashfn (h
, key
);
4745 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4746 idx
= HASH_INDEX (h
, start_of_bucket
);
4748 /* We need not gcpro idx since it's either an integer or nil. */
4751 int i
= XFASTINT (idx
);
4752 if (EQ (key
, HASH_KEY (h
, i
))
4754 && h
->cmpfn (h
, key
, hash_code
,
4755 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4757 idx
= HASH_NEXT (h
, i
);
4760 return NILP (idx
) ? -1 : XFASTINT (idx
);
4764 /* Put an entry into hash table H that associates KEY with VALUE.
4765 HASH is a previously computed hash code of KEY.
4766 Value is the index of the entry in H matching KEY. */
4769 hash_put (h
, key
, value
, hash
)
4770 struct Lisp_Hash_Table
*h
;
4771 Lisp_Object key
, value
;
4774 int start_of_bucket
, i
;
4776 xassert ((hash
& ~INTMASK
) == 0);
4778 /* Increment count after resizing because resizing may fail. */
4779 maybe_resize_hash_table (h
);
4780 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4782 /* Store key/value in the key_and_value vector. */
4783 i
= XFASTINT (h
->next_free
);
4784 h
->next_free
= HASH_NEXT (h
, i
);
4785 HASH_KEY (h
, i
) = key
;
4786 HASH_VALUE (h
, i
) = value
;
4788 /* Remember its hash code. */
4789 HASH_HASH (h
, i
) = make_number (hash
);
4791 /* Add new entry to its collision chain. */
4792 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4793 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4794 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4799 /* Remove the entry matching KEY from hash table H, if there is one. */
4802 hash_remove (h
, key
)
4803 struct Lisp_Hash_Table
*h
;
4807 int start_of_bucket
;
4808 Lisp_Object idx
, prev
;
4810 hash_code
= h
->hashfn (h
, key
);
4811 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4812 idx
= HASH_INDEX (h
, start_of_bucket
);
4815 /* We need not gcpro idx, prev since they're either integers or nil. */
4818 int i
= XFASTINT (idx
);
4820 if (EQ (key
, HASH_KEY (h
, i
))
4822 && h
->cmpfn (h
, key
, hash_code
,
4823 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4825 /* Take entry out of collision chain. */
4827 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4829 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4831 /* Clear slots in key_and_value and add the slots to
4833 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4834 HASH_NEXT (h
, i
) = h
->next_free
;
4835 h
->next_free
= make_number (i
);
4836 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4837 xassert (XINT (h
->count
) >= 0);
4843 idx
= HASH_NEXT (h
, i
);
4849 /* Clear hash table H. */
4853 struct Lisp_Hash_Table
*h
;
4855 if (XFASTINT (h
->count
) > 0)
4857 int i
, size
= HASH_TABLE_SIZE (h
);
4859 for (i
= 0; i
< size
; ++i
)
4861 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4862 HASH_KEY (h
, i
) = Qnil
;
4863 HASH_VALUE (h
, i
) = Qnil
;
4864 HASH_HASH (h
, i
) = Qnil
;
4867 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4868 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4870 h
->next_free
= make_number (0);
4871 h
->count
= make_number (0);
4877 /************************************************************************
4879 ************************************************************************/
4881 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4882 entries from the table that don't survive the current GC.
4883 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4884 non-zero if anything was marked. */
4887 sweep_weak_table (h
, remove_entries_p
)
4888 struct Lisp_Hash_Table
*h
;
4889 int remove_entries_p
;
4891 int bucket
, n
, marked
;
4893 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4896 for (bucket
= 0; bucket
< n
; ++bucket
)
4898 Lisp_Object idx
, next
, prev
;
4900 /* Follow collision chain, removing entries that
4901 don't survive this garbage collection. */
4903 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4905 int i
= XFASTINT (idx
);
4906 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4907 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4910 if (EQ (h
->weak
, Qkey
))
4911 remove_p
= !key_known_to_survive_p
;
4912 else if (EQ (h
->weak
, Qvalue
))
4913 remove_p
= !value_known_to_survive_p
;
4914 else if (EQ (h
->weak
, Qkey_or_value
))
4915 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4916 else if (EQ (h
->weak
, Qkey_and_value
))
4917 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4921 next
= HASH_NEXT (h
, i
);
4923 if (remove_entries_p
)
4927 /* Take out of collision chain. */
4929 HASH_INDEX (h
, bucket
) = next
;
4931 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4933 /* Add to free list. */
4934 HASH_NEXT (h
, i
) = h
->next_free
;
4937 /* Clear key, value, and hash. */
4938 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4939 HASH_HASH (h
, i
) = Qnil
;
4941 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4952 /* Make sure key and value survive. */
4953 if (!key_known_to_survive_p
)
4955 mark_object (HASH_KEY (h
, i
));
4959 if (!value_known_to_survive_p
)
4961 mark_object (HASH_VALUE (h
, i
));
4972 /* Remove elements from weak hash tables that don't survive the
4973 current garbage collection. Remove weak tables that don't survive
4974 from Vweak_hash_tables. Called from gc_sweep. */
4977 sweep_weak_hash_tables ()
4979 Lisp_Object table
, used
, next
;
4980 struct Lisp_Hash_Table
*h
;
4983 /* Mark all keys and values that are in use. Keep on marking until
4984 there is no more change. This is necessary for cases like
4985 value-weak table A containing an entry X -> Y, where Y is used in a
4986 key-weak table B, Z -> Y. If B comes after A in the list of weak
4987 tables, X -> Y might be removed from A, although when looking at B
4988 one finds that it shouldn't. */
4992 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4994 h
= XHASH_TABLE (table
);
4995 if (h
->size
& ARRAY_MARK_FLAG
)
4996 marked
|= sweep_weak_table (h
, 0);
5001 /* Remove tables and entries that aren't used. */
5002 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
5004 h
= XHASH_TABLE (table
);
5005 next
= h
->next_weak
;
5007 if (h
->size
& ARRAY_MARK_FLAG
)
5009 /* TABLE is marked as used. Sweep its contents. */
5010 if (XFASTINT (h
->count
) > 0)
5011 sweep_weak_table (h
, 1);
5013 /* Add table to the list of used weak hash tables. */
5014 h
->next_weak
= used
;
5019 Vweak_hash_tables
= used
;
5024 /***********************************************************************
5025 Hash Code Computation
5026 ***********************************************************************/
5028 /* Maximum depth up to which to dive into Lisp structures. */
5030 #define SXHASH_MAX_DEPTH 3
5032 /* Maximum length up to which to take list and vector elements into
5035 #define SXHASH_MAX_LEN 7
5037 /* Combine two integers X and Y for hashing. */
5039 #define SXHASH_COMBINE(X, Y) \
5040 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5044 /* Return a hash for string PTR which has length LEN. The hash
5045 code returned is guaranteed to fit in a Lisp integer. */
5048 sxhash_string (ptr
, len
)
5052 unsigned char *p
= ptr
;
5053 unsigned char *end
= p
+ len
;
5062 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
5065 return hash
& INTMASK
;
5069 /* Return a hash for list LIST. DEPTH is the current depth in the
5070 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5073 sxhash_list (list
, depth
)
5080 if (depth
< SXHASH_MAX_DEPTH
)
5082 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5083 list
= XCDR (list
), ++i
)
5085 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5086 hash
= SXHASH_COMBINE (hash
, hash2
);
5091 unsigned hash2
= sxhash (list
, depth
+ 1);
5092 hash
= SXHASH_COMBINE (hash
, hash2
);
5099 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5100 the Lisp structure. */
5103 sxhash_vector (vec
, depth
)
5107 unsigned hash
= XVECTOR (vec
)->size
;
5110 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5111 for (i
= 0; i
< n
; ++i
)
5113 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5114 hash
= SXHASH_COMBINE (hash
, hash2
);
5121 /* Return a hash for bool-vector VECTOR. */
5124 sxhash_bool_vector (vec
)
5127 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5130 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5131 for (i
= 0; i
< n
; ++i
)
5132 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5138 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5139 structure. Value is an unsigned integer clipped to INTMASK. */
5148 if (depth
> SXHASH_MAX_DEPTH
)
5151 switch (XTYPE (obj
))
5162 obj
= SYMBOL_NAME (obj
);
5166 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5169 /* This can be everything from a vector to an overlay. */
5170 case Lisp_Vectorlike
:
5172 /* According to the CL HyperSpec, two arrays are equal only if
5173 they are `eq', except for strings and bit-vectors. In
5174 Emacs, this works differently. We have to compare element
5176 hash
= sxhash_vector (obj
, depth
);
5177 else if (BOOL_VECTOR_P (obj
))
5178 hash
= sxhash_bool_vector (obj
);
5180 /* Others are `equal' if they are `eq', so let's take their
5186 hash
= sxhash_list (obj
, depth
);
5191 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5192 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5193 for (hash
= 0; p
< e
; ++p
)
5194 hash
= SXHASH_COMBINE (hash
, *p
);
5202 return hash
& INTMASK
;
5207 /***********************************************************************
5209 ***********************************************************************/
5212 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5213 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5217 unsigned hash
= sxhash (obj
, 0);;
5218 return make_number (hash
);
5222 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5223 doc
: /* Create and return a new hash table.
5225 Arguments are specified as keyword/argument pairs. The following
5226 arguments are defined:
5228 :test TEST -- TEST must be a symbol that specifies how to compare
5229 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5230 `equal'. User-supplied test and hash functions can be specified via
5231 `define-hash-table-test'.
5233 :size SIZE -- A hint as to how many elements will be put in the table.
5236 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5237 fills up. If REHASH-SIZE is an integer, add that many space. If it
5238 is a float, it must be > 1.0, and the new size is computed by
5239 multiplying the old size with that factor. Default is 1.5.
5241 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5242 Resize the hash table when ratio of the number of entries in the
5243 table. Default is 0.8.
5245 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5246 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5247 returned is a weak table. Key/value pairs are removed from a weak
5248 hash table when there are no non-weak references pointing to their
5249 key, value, one of key or value, or both key and value, depending on
5250 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5253 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5258 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5259 Lisp_Object user_test
, user_hash
;
5263 /* The vector `used' is used to keep track of arguments that
5264 have been consumed. */
5265 used
= (char *) alloca (nargs
* sizeof *used
);
5266 bzero (used
, nargs
* sizeof *used
);
5268 /* See if there's a `:test TEST' among the arguments. */
5269 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5270 test
= i
< 0 ? Qeql
: args
[i
];
5271 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5273 /* See if it is a user-defined test. */
5276 prop
= Fget (test
, Qhash_table_test
);
5277 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5278 signal_error ("Invalid hash table test", test
);
5279 user_test
= XCAR (prop
);
5280 user_hash
= XCAR (XCDR (prop
));
5283 user_test
= user_hash
= Qnil
;
5285 /* See if there's a `:size SIZE' argument. */
5286 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5287 size
= i
< 0 ? Qnil
: args
[i
];
5289 size
= make_number (DEFAULT_HASH_SIZE
);
5290 else if (!INTEGERP (size
) || XINT (size
) < 0)
5291 signal_error ("Invalid hash table size", size
);
5293 /* Look for `:rehash-size SIZE'. */
5294 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5295 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5296 if (!NUMBERP (rehash_size
)
5297 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5298 || XFLOATINT (rehash_size
) <= 1.0)
5299 signal_error ("Invalid hash table rehash size", rehash_size
);
5301 /* Look for `:rehash-threshold THRESHOLD'. */
5302 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5303 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5304 if (!FLOATP (rehash_threshold
)
5305 || XFLOATINT (rehash_threshold
) <= 0.0
5306 || XFLOATINT (rehash_threshold
) > 1.0)
5307 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
5309 /* Look for `:weakness WEAK'. */
5310 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5311 weak
= i
< 0 ? Qnil
: args
[i
];
5313 weak
= Qkey_and_value
;
5316 && !EQ (weak
, Qvalue
)
5317 && !EQ (weak
, Qkey_or_value
)
5318 && !EQ (weak
, Qkey_and_value
))
5319 signal_error ("Invalid hash table weakness", weak
);
5321 /* Now, all args should have been used up, or there's a problem. */
5322 for (i
= 0; i
< nargs
; ++i
)
5324 signal_error ("Invalid argument list", args
[i
]);
5326 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5327 user_test
, user_hash
);
5331 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5332 doc
: /* Return a copy of hash table TABLE. */)
5336 return copy_hash_table (check_hash_table (table
));
5340 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5341 doc
: /* Return the number of elements in TABLE. */)
5345 return check_hash_table (table
)->count
;
5349 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5350 Shash_table_rehash_size
, 1, 1, 0,
5351 doc
: /* Return the current rehash size of TABLE. */)
5355 return check_hash_table (table
)->rehash_size
;
5359 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5360 Shash_table_rehash_threshold
, 1, 1, 0,
5361 doc
: /* Return the current rehash threshold of TABLE. */)
5365 return check_hash_table (table
)->rehash_threshold
;
5369 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5370 doc
: /* Return the size of TABLE.
5371 The size can be used as an argument to `make-hash-table' to create
5372 a hash table than can hold as many elements of TABLE holds
5373 without need for resizing. */)
5377 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5378 return make_number (HASH_TABLE_SIZE (h
));
5382 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5383 doc
: /* Return the test TABLE uses. */)
5387 return check_hash_table (table
)->test
;
5391 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5393 doc
: /* Return the weakness of TABLE. */)
5397 return check_hash_table (table
)->weak
;
5401 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5402 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5406 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5410 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5411 doc
: /* Clear hash table TABLE. */)
5415 hash_clear (check_hash_table (table
));
5420 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5421 doc
: /* Look up KEY in TABLE and return its associated value.
5422 If KEY is not found, return DFLT which defaults to nil. */)
5424 Lisp_Object key
, table
, dflt
;
5426 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5427 int i
= hash_lookup (h
, key
, NULL
);
5428 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5432 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5433 doc
: /* Associate KEY with VALUE in hash table TABLE.
5434 If KEY is already present in table, replace its current value with
5437 Lisp_Object key
, value
, table
;
5439 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5443 i
= hash_lookup (h
, key
, &hash
);
5445 HASH_VALUE (h
, i
) = value
;
5447 hash_put (h
, key
, value
, hash
);
5453 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5454 doc
: /* Remove KEY from TABLE. */)
5456 Lisp_Object key
, table
;
5458 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5459 hash_remove (h
, key
);
5464 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5465 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5466 FUNCTION is called with two arguments, KEY and VALUE. */)
5468 Lisp_Object function
, table
;
5470 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5471 Lisp_Object args
[3];
5474 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5475 if (!NILP (HASH_HASH (h
, i
)))
5478 args
[1] = HASH_KEY (h
, i
);
5479 args
[2] = HASH_VALUE (h
, i
);
5487 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5488 Sdefine_hash_table_test
, 3, 3, 0,
5489 doc
: /* Define a new hash table test with name NAME, a symbol.
5491 In hash tables created with NAME specified as test, use TEST to
5492 compare keys, and HASH for computing hash codes of keys.
5494 TEST must be a function taking two arguments and returning non-nil if
5495 both arguments are the same. HASH must be a function taking one
5496 argument and return an integer that is the hash code of the argument.
5497 Hash code computation should use the whole value range of integers,
5498 including negative integers. */)
5500 Lisp_Object name
, test
, hash
;
5502 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5507 /************************************************************************
5509 ************************************************************************/
5514 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5515 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5517 A message digest is a cryptographic checksum of a document, and the
5518 algorithm to calculate it is defined in RFC 1321.
5520 The two optional arguments START and END are character positions
5521 specifying for which part of OBJECT the message digest should be
5522 computed. If nil or omitted, the digest is computed for the whole
5525 The MD5 message digest is computed from the result of encoding the
5526 text in a coding system, not directly from the internal Emacs form of
5527 the text. The optional fourth argument CODING-SYSTEM specifies which
5528 coding system to encode the text with. It should be the same coding
5529 system that you used or will use when actually writing the text into a
5532 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5533 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5534 system would be chosen by default for writing this text into a file.
5536 If OBJECT is a string, the most preferred coding system (see the
5537 command `prefer-coding-system') is used.
5539 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5540 guesswork fails. Normally, an error is signaled in such case. */)
5541 (object
, start
, end
, coding_system
, noerror
)
5542 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5544 unsigned char digest
[16];
5545 unsigned char value
[33];
5549 int start_char
= 0, end_char
= 0;
5550 int start_byte
= 0, end_byte
= 0;
5552 register struct buffer
*bp
;
5555 if (STRINGP (object
))
5557 if (NILP (coding_system
))
5559 /* Decide the coding-system to encode the data with. */
5561 if (STRING_MULTIBYTE (object
))
5562 /* use default, we can't guess correct value */
5563 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5565 coding_system
= Qraw_text
;
5568 if (NILP (Fcoding_system_p (coding_system
)))
5570 /* Invalid coding system. */
5572 if (!NILP (noerror
))
5573 coding_system
= Qraw_text
;
5575 xsignal1 (Qcoding_system_error
, coding_system
);
5578 if (STRING_MULTIBYTE (object
))
5579 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5581 size
= SCHARS (object
);
5582 size_byte
= SBYTES (object
);
5586 CHECK_NUMBER (start
);
5588 start_char
= XINT (start
);
5593 start_byte
= string_char_to_byte (object
, start_char
);
5599 end_byte
= size_byte
;
5605 end_char
= XINT (end
);
5610 end_byte
= string_char_to_byte (object
, end_char
);
5613 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5614 args_out_of_range_3 (object
, make_number (start_char
),
5615 make_number (end_char
));
5619 struct buffer
*prev
= current_buffer
;
5621 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5623 CHECK_BUFFER (object
);
5625 bp
= XBUFFER (object
);
5626 if (bp
!= current_buffer
)
5627 set_buffer_internal (bp
);
5633 CHECK_NUMBER_COERCE_MARKER (start
);
5641 CHECK_NUMBER_COERCE_MARKER (end
);
5646 temp
= b
, b
= e
, e
= temp
;
5648 if (!(BEGV
<= b
&& e
<= ZV
))
5649 args_out_of_range (start
, end
);
5651 if (NILP (coding_system
))
5653 /* Decide the coding-system to encode the data with.
5654 See fileio.c:Fwrite-region */
5656 if (!NILP (Vcoding_system_for_write
))
5657 coding_system
= Vcoding_system_for_write
;
5660 int force_raw_text
= 0;
5662 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5663 if (NILP (coding_system
)
5664 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5666 coding_system
= Qnil
;
5667 if (NILP (current_buffer
->enable_multibyte_characters
))
5671 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5673 /* Check file-coding-system-alist. */
5674 Lisp_Object args
[4], val
;
5676 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5677 args
[3] = Fbuffer_file_name(object
);
5678 val
= Ffind_operation_coding_system (4, args
);
5679 if (CONSP (val
) && !NILP (XCDR (val
)))
5680 coding_system
= XCDR (val
);
5683 if (NILP (coding_system
)
5684 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5686 /* If we still have not decided a coding system, use the
5687 default value of buffer-file-coding-system. */
5688 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5692 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5693 /* Confirm that VAL can surely encode the current region. */
5694 coding_system
= call4 (Vselect_safe_coding_system_function
,
5695 make_number (b
), make_number (e
),
5696 coding_system
, Qnil
);
5699 coding_system
= Qraw_text
;
5702 if (NILP (Fcoding_system_p (coding_system
)))
5704 /* Invalid coding system. */
5706 if (!NILP (noerror
))
5707 coding_system
= Qraw_text
;
5709 xsignal1 (Qcoding_system_error
, coding_system
);
5713 object
= make_buffer_string (b
, e
, 0);
5714 if (prev
!= current_buffer
)
5715 set_buffer_internal (prev
);
5716 /* Discard the unwind protect for recovering the current
5720 if (STRING_MULTIBYTE (object
))
5721 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5724 md5_buffer (SDATA (object
) + start_byte
,
5725 SBYTES (object
) - (size_byte
- end_byte
),
5728 for (i
= 0; i
< 16; i
++)
5729 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5732 return make_string (value
, 32);
5739 /* Hash table stuff. */
5740 Qhash_table_p
= intern ("hash-table-p");
5741 staticpro (&Qhash_table_p
);
5742 Qeq
= intern ("eq");
5744 Qeql
= intern ("eql");
5746 Qequal
= intern ("equal");
5747 staticpro (&Qequal
);
5748 QCtest
= intern (":test");
5749 staticpro (&QCtest
);
5750 QCsize
= intern (":size");
5751 staticpro (&QCsize
);
5752 QCrehash_size
= intern (":rehash-size");
5753 staticpro (&QCrehash_size
);
5754 QCrehash_threshold
= intern (":rehash-threshold");
5755 staticpro (&QCrehash_threshold
);
5756 QCweakness
= intern (":weakness");
5757 staticpro (&QCweakness
);
5758 Qkey
= intern ("key");
5760 Qvalue
= intern ("value");
5761 staticpro (&Qvalue
);
5762 Qhash_table_test
= intern ("hash-table-test");
5763 staticpro (&Qhash_table_test
);
5764 Qkey_or_value
= intern ("key-or-value");
5765 staticpro (&Qkey_or_value
);
5766 Qkey_and_value
= intern ("key-and-value");
5767 staticpro (&Qkey_and_value
);
5770 defsubr (&Smake_hash_table
);
5771 defsubr (&Scopy_hash_table
);
5772 defsubr (&Shash_table_count
);
5773 defsubr (&Shash_table_rehash_size
);
5774 defsubr (&Shash_table_rehash_threshold
);
5775 defsubr (&Shash_table_size
);
5776 defsubr (&Shash_table_test
);
5777 defsubr (&Shash_table_weakness
);
5778 defsubr (&Shash_table_p
);
5779 defsubr (&Sclrhash
);
5780 defsubr (&Sgethash
);
5781 defsubr (&Sputhash
);
5782 defsubr (&Sremhash
);
5783 defsubr (&Smaphash
);
5784 defsubr (&Sdefine_hash_table_test
);
5786 Qstring_lessp
= intern ("string-lessp");
5787 staticpro (&Qstring_lessp
);
5788 Qprovide
= intern ("provide");
5789 staticpro (&Qprovide
);
5790 Qrequire
= intern ("require");
5791 staticpro (&Qrequire
);
5792 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5793 staticpro (&Qyes_or_no_p_history
);
5794 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5795 staticpro (&Qcursor_in_echo_area
);
5796 Qwidget_type
= intern ("widget-type");
5797 staticpro (&Qwidget_type
);
5799 staticpro (&string_char_byte_cache_string
);
5800 string_char_byte_cache_string
= Qnil
;
5802 require_nesting_list
= Qnil
;
5803 staticpro (&require_nesting_list
);
5805 Fset (Qyes_or_no_p_history
, Qnil
);
5807 DEFVAR_LISP ("features", &Vfeatures
,
5808 doc
: /* A list of symbols which are the features of the executing Emacs.
5809 Used by `featurep' and `require', and altered by `provide'. */);
5810 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5811 Qsubfeatures
= intern ("subfeatures");
5812 staticpro (&Qsubfeatures
);
5814 #ifdef HAVE_LANGINFO_CODESET
5815 Qcodeset
= intern ("codeset");
5816 staticpro (&Qcodeset
);
5817 Qdays
= intern ("days");
5819 Qmonths
= intern ("months");
5820 staticpro (&Qmonths
);
5821 Qpaper
= intern ("paper");
5822 staticpro (&Qpaper
);
5823 #endif /* HAVE_LANGINFO_CODESET */
5825 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5826 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5827 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5828 invoked by mouse clicks and mouse menu items. */);
5831 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5832 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5833 This applies to commands from menus and tool bar buttons. The value of
5834 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5835 used if both `use-dialog-box' and this variable are non-nil. */);
5836 use_file_dialog
= 1;
5838 defsubr (&Sidentity
);
5841 defsubr (&Ssafe_length
);
5842 defsubr (&Sstring_bytes
);
5843 defsubr (&Sstring_equal
);
5844 defsubr (&Scompare_strings
);
5845 defsubr (&Sstring_lessp
);
5848 defsubr (&Svconcat
);
5849 defsubr (&Scopy_sequence
);
5850 defsubr (&Sstring_make_multibyte
);
5851 defsubr (&Sstring_make_unibyte
);
5852 defsubr (&Sstring_as_multibyte
);
5853 defsubr (&Sstring_as_unibyte
);
5854 defsubr (&Sstring_to_multibyte
);
5855 defsubr (&Scopy_alist
);
5856 defsubr (&Ssubstring
);
5857 defsubr (&Ssubstring_no_properties
);
5870 defsubr (&Snreverse
);
5871 defsubr (&Sreverse
);
5873 defsubr (&Splist_get
);
5875 defsubr (&Splist_put
);
5877 defsubr (&Slax_plist_get
);
5878 defsubr (&Slax_plist_put
);
5881 defsubr (&Sequal_including_properties
);
5882 defsubr (&Sfillarray
);
5883 defsubr (&Sclear_string
);
5884 defsubr (&Schar_table_subtype
);
5885 defsubr (&Schar_table_parent
);
5886 defsubr (&Sset_char_table_parent
);
5887 defsubr (&Schar_table_extra_slot
);
5888 defsubr (&Sset_char_table_extra_slot
);
5889 defsubr (&Schar_table_range
);
5890 defsubr (&Sset_char_table_range
);
5891 defsubr (&Sset_char_table_default
);
5892 defsubr (&Soptimize_char_table
);
5893 defsubr (&Smap_char_table
);
5897 defsubr (&Smapconcat
);
5898 defsubr (&Sy_or_n_p
);
5899 defsubr (&Syes_or_no_p
);
5900 defsubr (&Sload_average
);
5901 defsubr (&Sfeaturep
);
5902 defsubr (&Srequire
);
5903 defsubr (&Sprovide
);
5904 defsubr (&Splist_member
);
5905 defsubr (&Swidget_put
);
5906 defsubr (&Swidget_get
);
5907 defsubr (&Swidget_apply
);
5908 defsubr (&Sbase64_encode_region
);
5909 defsubr (&Sbase64_decode_region
);
5910 defsubr (&Sbase64_encode_string
);
5911 defsubr (&Sbase64_decode_string
);
5913 defsubr (&Slocale_info
);
5920 Vweak_hash_tables
= Qnil
;
5923 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5924 (do not change this comment) */