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
));
406 return concat (2, args
, Lisp_String
, 0);
408 return concat (2, &s1
, Lisp_String
, 0);
409 #endif /* NO_ARG_ARRAY */
415 Lisp_Object s1
, s2
, s3
;
422 return concat (3, args
, Lisp_String
, 0);
424 return concat (3, &s1
, Lisp_String
, 0);
425 #endif /* NO_ARG_ARRAY */
428 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
429 doc
: /* Concatenate all the arguments and make the result a list.
430 The result is a list whose elements are the elements of all the arguments.
431 Each argument may be a list, vector or string.
432 The last argument is not copied, just used as the tail of the new list.
433 usage: (append &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_Cons
, 1);
441 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a string.
443 The result is a string whose elements are the elements of all the arguments.
444 Each argument may be a string or a list or vector of characters (integers).
445 usage: (concat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_String
, 0);
453 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
454 doc
: /* Concatenate all the arguments and make the result a vector.
455 The result is a vector whose elements are the elements of all the arguments.
456 Each argument may be a list, vector or string.
457 usage: (vconcat &rest SEQUENCES) */)
462 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
465 /* Return a copy of a sub char table ARG. The elements except for a
466 nested sub char table are not copied. */
468 copy_sub_char_table (arg
)
471 Lisp_Object copy
= make_sub_char_table (Qnil
);
474 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
475 /* Copy all the contents. */
476 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
477 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
478 /* Recursively copy any sub char-tables in the ordinary slots. */
479 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
480 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
481 XCHAR_TABLE (copy
)->contents
[i
]
482 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
488 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
489 doc
: /* Return a copy of a list, vector, string or char-table.
490 The elements of a list or vector are not copied; they are shared
491 with the original. */)
495 if (NILP (arg
)) return arg
;
497 if (CHAR_TABLE_P (arg
))
502 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
503 /* Copy all the slots, including the extra ones. */
504 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
505 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
506 * sizeof (Lisp_Object
)));
508 /* Recursively copy any sub char tables in the ordinary slots
509 for multibyte characters. */
510 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
511 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
512 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
513 XCHAR_TABLE (copy
)->contents
[i
]
514 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
519 if (BOOL_VECTOR_P (arg
))
523 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
524 / BOOL_VECTOR_BITS_PER_CHAR
);
526 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
527 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
532 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
533 wrong_type_argument (Qsequencep
, arg
);
535 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
538 /* This structure holds information of an argument of `concat' that is
539 a string and has text properties to be copied. */
542 int argnum
; /* refer to ARGS (arguments of `concat') */
543 int from
; /* refer to ARGS[argnum] (argument string) */
544 int to
; /* refer to VAL (the target string) */
548 concat (nargs
, args
, target_type
, last_special
)
551 enum Lisp_Type target_type
;
555 register Lisp_Object tail
;
556 register Lisp_Object
this;
558 int toindex_byte
= 0;
559 register int result_len
;
560 register int result_len_byte
;
562 Lisp_Object last_tail
;
565 /* When we make a multibyte string, we can't copy text properties
566 while concatinating each string because the length of resulting
567 string can't be decided until we finish the whole concatination.
568 So, we record strings that have text properties to be copied
569 here, and copy the text properties after the concatination. */
570 struct textprop_rec
*textprops
= NULL
;
571 /* Number of elments in textprops. */
572 int num_textprops
= 0;
577 /* In append, the last arg isn't treated like the others */
578 if (last_special
&& nargs
> 0)
581 last_tail
= args
[nargs
];
586 /* Check each argument. */
587 for (argnum
= 0; argnum
< nargs
; argnum
++)
590 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
591 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
592 wrong_type_argument (Qsequencep
, this);
595 /* Compute total length in chars of arguments in RESULT_LEN.
596 If desired output is a string, also compute length in bytes
597 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
598 whether the result should be a multibyte string. */
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 len
= XFASTINT (Flength (this));
607 if (target_type
== Lisp_String
)
609 /* We must count the number of bytes needed in the string
610 as well as the number of characters. */
616 for (i
= 0; i
< len
; i
++)
618 ch
= XVECTOR (this)->contents
[i
];
620 this_len_byte
= CHAR_BYTES (XINT (ch
));
621 result_len_byte
+= this_len_byte
;
622 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
625 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
626 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
627 else if (CONSP (this))
628 for (; CONSP (this); this = XCDR (this))
632 this_len_byte
= CHAR_BYTES (XINT (ch
));
633 result_len_byte
+= this_len_byte
;
634 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
637 else if (STRINGP (this))
639 if (STRING_MULTIBYTE (this))
642 result_len_byte
+= SBYTES (this);
645 result_len_byte
+= count_size_as_multibyte (SDATA (this),
653 if (! some_multibyte
)
654 result_len_byte
= result_len
;
656 /* Create the output object. */
657 if (target_type
== Lisp_Cons
)
658 val
= Fmake_list (make_number (result_len
), Qnil
);
659 else if (target_type
== Lisp_Vectorlike
)
660 val
= Fmake_vector (make_number (result_len
), Qnil
);
661 else if (some_multibyte
)
662 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
664 val
= make_uninit_string (result_len
);
666 /* In `append', if all but last arg are nil, return last arg. */
667 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
670 /* Copy the contents of the args into the result. */
672 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
674 toindex
= 0, toindex_byte
= 0;
678 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
680 for (argnum
= 0; argnum
< nargs
; argnum
++)
684 register unsigned int thisindex
= 0;
685 register unsigned int thisindex_byte
= 0;
689 thislen
= Flength (this), thisleni
= XINT (thislen
);
691 /* Between strings of the same kind, copy fast. */
692 if (STRINGP (this) && STRINGP (val
)
693 && STRING_MULTIBYTE (this) == some_multibyte
)
695 int thislen_byte
= SBYTES (this);
697 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
699 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
701 textprops
[num_textprops
].argnum
= argnum
;
702 textprops
[num_textprops
].from
= 0;
703 textprops
[num_textprops
++].to
= toindex
;
705 toindex_byte
+= thislen_byte
;
707 STRING_SET_CHARS (val
, SCHARS (val
));
709 /* Copy a single-byte string to a multibyte string. */
710 else if (STRINGP (this) && STRINGP (val
))
712 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
714 textprops
[num_textprops
].argnum
= argnum
;
715 textprops
[num_textprops
].from
= 0;
716 textprops
[num_textprops
++].to
= toindex
;
718 toindex_byte
+= copy_text (SDATA (this),
719 SDATA (val
) + toindex_byte
,
720 SCHARS (this), 0, 1);
724 /* Copy element by element. */
727 register Lisp_Object elt
;
729 /* Fetch next element of `this' arg into `elt', or break if
730 `this' is exhausted. */
731 if (NILP (this)) break;
733 elt
= XCAR (this), this = XCDR (this);
734 else if (thisindex
>= thisleni
)
736 else if (STRINGP (this))
739 if (STRING_MULTIBYTE (this))
741 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
744 XSETFASTINT (elt
, c
);
748 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
750 && (XINT (elt
) >= 0240
751 || (XINT (elt
) >= 0200
752 && ! NILP (Vnonascii_translation_table
)))
753 && XINT (elt
) < 0400)
755 c
= unibyte_char_to_multibyte (XINT (elt
));
760 else if (BOOL_VECTOR_P (this))
763 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
764 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
771 elt
= XVECTOR (this)->contents
[thisindex
++];
773 /* Store this element into the result. */
780 else if (VECTORP (val
))
781 XVECTOR (val
)->contents
[toindex
++] = elt
;
785 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
789 += CHAR_STRING (XINT (elt
),
790 SDATA (val
) + toindex_byte
);
792 SSET (val
, toindex_byte
++, XINT (elt
));
796 /* If we have any multibyte characters,
797 we already decided to make a multibyte string. */
800 /* P exists as a variable
801 to avoid a bug on the Masscomp C compiler. */
802 unsigned char *p
= SDATA (val
) + toindex_byte
;
804 toindex_byte
+= CHAR_STRING (c
, p
);
811 XSETCDR (prev
, last_tail
);
813 if (num_textprops
> 0)
816 int last_to_end
= -1;
818 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
820 this = args
[textprops
[argnum
].argnum
];
821 props
= text_property_list (this,
823 make_number (SCHARS (this)),
825 /* If successive arguments have properites, be sure that the
826 value of `composition' property be the copy. */
827 if (last_to_end
== textprops
[argnum
].to
)
828 make_composition_value_copy (props
);
829 add_text_properties_from_list (val
, props
,
830 make_number (textprops
[argnum
].to
));
831 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
839 static Lisp_Object string_char_byte_cache_string
;
840 static int string_char_byte_cache_charpos
;
841 static int string_char_byte_cache_bytepos
;
844 clear_string_char_byte_cache ()
846 string_char_byte_cache_string
= Qnil
;
849 /* Return the character index corresponding to CHAR_INDEX in STRING. */
852 string_char_to_byte (string
, char_index
)
857 int best_below
, best_below_byte
;
858 int best_above
, best_above_byte
;
860 best_below
= best_below_byte
= 0;
861 best_above
= SCHARS (string
);
862 best_above_byte
= SBYTES (string
);
863 if (best_above
== best_above_byte
)
866 if (EQ (string
, string_char_byte_cache_string
))
868 if (string_char_byte_cache_charpos
< char_index
)
870 best_below
= string_char_byte_cache_charpos
;
871 best_below_byte
= string_char_byte_cache_bytepos
;
875 best_above
= string_char_byte_cache_charpos
;
876 best_above_byte
= string_char_byte_cache_bytepos
;
880 if (char_index
- best_below
< best_above
- char_index
)
882 while (best_below
< char_index
)
885 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
886 best_below
, best_below_byte
);
889 i_byte
= best_below_byte
;
893 while (best_above
> char_index
)
895 unsigned char *pend
= SDATA (string
) + best_above_byte
;
896 unsigned char *pbeg
= pend
- best_above_byte
;
897 unsigned char *p
= pend
- 1;
900 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
901 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
902 if (bytes
== pend
- p
)
903 best_above_byte
-= bytes
;
904 else if (bytes
> pend
- p
)
905 best_above_byte
-= (pend
- p
);
911 i_byte
= best_above_byte
;
914 string_char_byte_cache_bytepos
= i_byte
;
915 string_char_byte_cache_charpos
= i
;
916 string_char_byte_cache_string
= string
;
921 /* Return the character index corresponding to BYTE_INDEX in STRING. */
924 string_byte_to_char (string
, byte_index
)
929 int best_below
, best_below_byte
;
930 int best_above
, best_above_byte
;
932 best_below
= best_below_byte
= 0;
933 best_above
= SCHARS (string
);
934 best_above_byte
= SBYTES (string
);
935 if (best_above
== best_above_byte
)
938 if (EQ (string
, string_char_byte_cache_string
))
940 if (string_char_byte_cache_bytepos
< byte_index
)
942 best_below
= string_char_byte_cache_charpos
;
943 best_below_byte
= string_char_byte_cache_bytepos
;
947 best_above
= string_char_byte_cache_charpos
;
948 best_above_byte
= string_char_byte_cache_bytepos
;
952 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
954 while (best_below_byte
< byte_index
)
957 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
958 best_below
, best_below_byte
);
961 i_byte
= best_below_byte
;
965 while (best_above_byte
> byte_index
)
967 unsigned char *pend
= SDATA (string
) + best_above_byte
;
968 unsigned char *pbeg
= pend
- best_above_byte
;
969 unsigned char *p
= pend
- 1;
972 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
973 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
974 if (bytes
== pend
- p
)
975 best_above_byte
-= bytes
;
976 else if (bytes
> pend
- p
)
977 best_above_byte
-= (pend
- p
);
983 i_byte
= best_above_byte
;
986 string_char_byte_cache_bytepos
= i_byte
;
987 string_char_byte_cache_charpos
= i
;
988 string_char_byte_cache_string
= string
;
993 /* Convert STRING to a multibyte string.
994 Single-byte characters 0240 through 0377 are converted
995 by adding nonascii_insert_offset to each. */
998 string_make_multibyte (string
)
1006 if (STRING_MULTIBYTE (string
))
1009 nbytes
= count_size_as_multibyte (SDATA (string
),
1011 /* If all the chars are ASCII, they won't need any more bytes
1012 once converted. In that case, we can return STRING itself. */
1013 if (nbytes
== SBYTES (string
))
1016 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1017 copy_text (SDATA (string
), buf
, SBYTES (string
),
1020 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1027 /* Convert STRING to a multibyte string without changing each
1028 character codes. Thus, characters 0200 trough 0237 are converted
1029 to eight-bit-control characters, and characters 0240 through 0377
1030 are converted eight-bit-graphic characters. */
1033 string_to_multibyte (string
)
1041 if (STRING_MULTIBYTE (string
))
1044 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1045 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1046 any more bytes once converted. */
1047 if (nbytes
== SBYTES (string
))
1048 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1050 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1051 bcopy (SDATA (string
), buf
, SBYTES (string
));
1052 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1054 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1061 /* Convert STRING to a single-byte string. */
1064 string_make_unibyte (string
)
1072 if (! STRING_MULTIBYTE (string
))
1075 nchars
= SCHARS (string
);
1077 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1078 copy_text (SDATA (string
), buf
, SBYTES (string
),
1081 ret
= make_unibyte_string (buf
, nchars
);
1087 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1089 doc
: /* Return the multibyte equivalent of STRING.
1090 If STRING is unibyte and contains non-ASCII characters, the function
1091 `unibyte-char-to-multibyte' is used to convert each unibyte character
1092 to a multibyte character. In this case, the returned string is a
1093 newly created string with no text properties. If STRING is multibyte
1094 or entirely ASCII, it is returned unchanged. In particular, when
1095 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1096 \(When the characters are all ASCII, Emacs primitives will treat the
1097 string the same way whether it is unibyte or multibyte.) */)
1101 CHECK_STRING (string
);
1103 return string_make_multibyte (string
);
1106 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1108 doc
: /* Return the unibyte equivalent of STRING.
1109 Multibyte character codes are converted to unibyte according to
1110 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1111 If the lookup in the translation table fails, this function takes just
1112 the low 8 bits of each character. */)
1116 CHECK_STRING (string
);
1118 return string_make_unibyte (string
);
1121 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1123 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1124 If STRING is unibyte, the result is STRING itself.
1125 Otherwise it is a newly created string, with no text properties.
1126 If STRING is multibyte and contains a character of charset
1127 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1128 corresponding single byte. */)
1132 CHECK_STRING (string
);
1134 if (STRING_MULTIBYTE (string
))
1136 int bytes
= SBYTES (string
);
1137 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1139 bcopy (SDATA (string
), str
, bytes
);
1140 bytes
= str_as_unibyte (str
, bytes
);
1141 string
= make_unibyte_string (str
, bytes
);
1147 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1149 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1150 If STRING is multibyte, the result is STRING itself.
1151 Otherwise it is a newly created string, with no text properties.
1152 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1153 part of a multibyte form), it is converted to the corresponding
1154 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1155 Beware, this often doesn't really do what you think it does.
1156 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1157 If you're not sure, whether to use `string-as-multibyte' or
1158 `string-to-multibyte', use `string-to-multibyte'. Beware:
1159 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1160 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1161 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1162 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1164 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1165 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1169 CHECK_STRING (string
);
1171 if (! STRING_MULTIBYTE (string
))
1173 Lisp_Object new_string
;
1176 parse_str_as_multibyte (SDATA (string
),
1179 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1180 bcopy (SDATA (string
), SDATA (new_string
),
1182 if (nbytes
!= SBYTES (string
))
1183 str_as_multibyte (SDATA (new_string
), nbytes
,
1184 SBYTES (string
), NULL
);
1185 string
= new_string
;
1186 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1191 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1193 doc
: /* Return a multibyte string with the same individual chars as STRING.
1194 If STRING is multibyte, the result is STRING itself.
1195 Otherwise it is a newly created string, with no text properties.
1196 Characters 0200 through 0237 are converted to eight-bit-control
1197 characters of the same character code. Characters 0240 through 0377
1198 are converted to eight-bit-graphic characters of the same character
1200 This is similar to (decode-coding-string STRING 'binary) */)
1204 CHECK_STRING (string
);
1206 return string_to_multibyte (string
);
1210 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1211 doc
: /* Return a copy of ALIST.
1212 This is an alist which represents the same mapping from objects to objects,
1213 but does not share the alist structure with ALIST.
1214 The objects mapped (cars and cdrs of elements of the alist)
1215 are shared, however.
1216 Elements of ALIST that are not conses are also shared. */)
1220 register Lisp_Object tem
;
1225 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1226 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1228 register Lisp_Object car
;
1232 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1237 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1238 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1239 TO may be nil or omitted; then the substring runs to the end of STRING.
1240 FROM and TO start at 0. If either is negative, it counts from the end.
1242 This function allows vectors as well as strings. */)
1245 register Lisp_Object from
, to
;
1250 int from_char
, to_char
;
1251 int from_byte
= 0, to_byte
= 0;
1253 CHECK_VECTOR_OR_STRING (string
);
1254 CHECK_NUMBER (from
);
1256 if (STRINGP (string
))
1258 size
= SCHARS (string
);
1259 size_byte
= SBYTES (string
);
1262 size
= XVECTOR (string
)->size
;
1267 to_byte
= size_byte
;
1273 to_char
= XINT (to
);
1277 if (STRINGP (string
))
1278 to_byte
= string_char_to_byte (string
, to_char
);
1281 from_char
= XINT (from
);
1284 if (STRINGP (string
))
1285 from_byte
= string_char_to_byte (string
, from_char
);
1287 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1288 args_out_of_range_3 (string
, make_number (from_char
),
1289 make_number (to_char
));
1291 if (STRINGP (string
))
1293 res
= make_specified_string (SDATA (string
) + from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1296 copy_text_properties (make_number (from_char
), make_number (to_char
),
1297 string
, make_number (0), res
, Qnil
);
1300 res
= Fvector (to_char
- from_char
,
1301 XVECTOR (string
)->contents
+ from_char
);
1307 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1308 doc
: /* Return a substring of STRING, without text properties.
1309 It starts at index FROM and ending before TO.
1310 TO may be nil or omitted; then the substring runs to the end of STRING.
1311 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1312 If FROM or TO is negative, it counts from the end.
1314 With one argument, just copy STRING without its properties. */)
1317 register Lisp_Object from
, to
;
1319 int size
, size_byte
;
1320 int from_char
, to_char
;
1321 int from_byte
, to_byte
;
1323 CHECK_STRING (string
);
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 from_char
= from_byte
= 0;
1332 CHECK_NUMBER (from
);
1333 from_char
= XINT (from
);
1337 from_byte
= string_char_to_byte (string
, from_char
);
1343 to_byte
= size_byte
;
1349 to_char
= XINT (to
);
1353 to_byte
= string_char_to_byte (string
, to_char
);
1356 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1357 args_out_of_range_3 (string
, make_number (from_char
),
1358 make_number (to_char
));
1360 return make_specified_string (SDATA (string
) + from_byte
,
1361 to_char
- from_char
, to_byte
- from_byte
,
1362 STRING_MULTIBYTE (string
));
1365 /* Extract a substring of STRING, giving start and end positions
1366 both in characters and in bytes. */
1369 substring_both (string
, from
, from_byte
, to
, to_byte
)
1371 int from
, from_byte
, to
, to_byte
;
1377 CHECK_VECTOR_OR_STRING (string
);
1379 if (STRINGP (string
))
1381 size
= SCHARS (string
);
1382 size_byte
= SBYTES (string
);
1385 size
= XVECTOR (string
)->size
;
1387 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1388 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1390 if (STRINGP (string
))
1392 res
= make_specified_string (SDATA (string
) + from_byte
,
1393 to
- from
, to_byte
- from_byte
,
1394 STRING_MULTIBYTE (string
));
1395 copy_text_properties (make_number (from
), make_number (to
),
1396 string
, make_number (0), res
, Qnil
);
1399 res
= Fvector (to
- from
,
1400 XVECTOR (string
)->contents
+ from
);
1405 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1406 doc
: /* Take cdr N times on LIST, returns the result. */)
1409 register Lisp_Object list
;
1411 register int i
, num
;
1414 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1417 CHECK_LIST_CONS (list
, list
);
1423 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1424 doc
: /* Return the Nth element of LIST.
1425 N counts from zero. If LIST is not that long, nil is returned. */)
1427 Lisp_Object n
, list
;
1429 return Fcar (Fnthcdr (n
, list
));
1432 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1433 doc
: /* Return element of SEQUENCE at index N. */)
1435 register Lisp_Object sequence
, n
;
1438 if (CONSP (sequence
) || NILP (sequence
))
1439 return Fcar (Fnthcdr (n
, sequence
));
1441 /* Faref signals a "not array" error, so check here. */
1442 CHECK_ARRAY (sequence
, Qsequencep
);
1443 return Faref (sequence
, n
);
1446 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1447 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1448 The value is actually the tail of LIST whose car is ELT. */)
1450 register Lisp_Object elt
;
1453 register Lisp_Object tail
;
1454 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1456 register Lisp_Object tem
;
1457 CHECK_LIST_CONS (tail
, list
);
1459 if (! NILP (Fequal (elt
, tem
)))
1466 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1467 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1468 The value is actually the tail of LIST whose car is ELT. */)
1470 register Lisp_Object elt
, list
;
1474 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1478 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1493 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1494 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1495 The value is actually the tail of LIST whose car is ELT. */)
1497 register Lisp_Object elt
;
1500 register Lisp_Object tail
;
1503 return Fmemq (elt
, list
);
1505 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1507 register Lisp_Object tem
;
1508 CHECK_LIST_CONS (tail
, list
);
1510 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1517 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1518 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1519 The value is actually the first element of LIST whose car is KEY.
1520 Elements of LIST that are not conses are ignored. */)
1522 Lisp_Object key
, list
;
1527 || (CONSP (XCAR (list
))
1528 && EQ (XCAR (XCAR (list
)), key
)))
1533 || (CONSP (XCAR (list
))
1534 && EQ (XCAR (XCAR (list
)), key
)))
1539 || (CONSP (XCAR (list
))
1540 && EQ (XCAR (XCAR (list
)), key
)))
1550 /* Like Fassq but never report an error and do not allow quits.
1551 Use only on lists known never to be circular. */
1554 assq_no_quit (key
, list
)
1555 Lisp_Object key
, list
;
1558 && (!CONSP (XCAR (list
))
1559 || !EQ (XCAR (XCAR (list
)), key
)))
1562 return CAR_SAFE (list
);
1565 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1566 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1567 The value is actually the first element of LIST whose car equals KEY. */)
1569 Lisp_Object key
, list
;
1576 || (CONSP (XCAR (list
))
1577 && (car
= XCAR (XCAR (list
)),
1578 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1583 || (CONSP (XCAR (list
))
1584 && (car
= XCAR (XCAR (list
)),
1585 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1590 || (CONSP (XCAR (list
))
1591 && (car
= XCAR (XCAR (list
)),
1592 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1602 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1603 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1604 The value is actually the first element of LIST whose cdr is KEY. */)
1606 register Lisp_Object key
;
1612 || (CONSP (XCAR (list
))
1613 && EQ (XCDR (XCAR (list
)), key
)))
1618 || (CONSP (XCAR (list
))
1619 && EQ (XCDR (XCAR (list
)), key
)))
1624 || (CONSP (XCAR (list
))
1625 && EQ (XCDR (XCAR (list
)), key
)))
1635 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1636 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1637 The value is actually the first element of LIST whose cdr equals KEY. */)
1639 Lisp_Object key
, list
;
1646 || (CONSP (XCAR (list
))
1647 && (cdr
= XCDR (XCAR (list
)),
1648 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1653 || (CONSP (XCAR (list
))
1654 && (cdr
= XCDR (XCAR (list
)),
1655 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1660 || (CONSP (XCAR (list
))
1661 && (cdr
= XCDR (XCAR (list
)),
1662 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1672 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1673 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1674 The modified LIST is returned. Comparison is done with `eq'.
1675 If the first member of LIST is ELT, there is no way to remove it by side effect;
1676 therefore, write `(setq foo (delq element foo))'
1677 to be sure of changing the value of `foo'. */)
1679 register Lisp_Object elt
;
1682 register Lisp_Object tail
, prev
;
1683 register Lisp_Object tem
;
1687 while (!NILP (tail
))
1689 CHECK_LIST_CONS (tail
, list
);
1696 Fsetcdr (prev
, XCDR (tail
));
1706 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1707 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1708 SEQ must be a list, a vector, or a string.
1709 The modified SEQ is returned. Comparison is done with `equal'.
1710 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1711 is not a side effect; it is simply using a different sequence.
1712 Therefore, write `(setq foo (delete element foo))'
1713 to be sure of changing the value of `foo'. */)
1715 Lisp_Object elt
, seq
;
1721 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1722 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1725 if (n
!= ASIZE (seq
))
1727 struct Lisp_Vector
*p
= allocate_vector (n
);
1729 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1730 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1731 p
->contents
[n
++] = AREF (seq
, i
);
1733 XSETVECTOR (seq
, p
);
1736 else if (STRINGP (seq
))
1738 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1741 for (i
= nchars
= nbytes
= ibyte
= 0;
1743 ++i
, ibyte
+= cbytes
)
1745 if (STRING_MULTIBYTE (seq
))
1747 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1748 SBYTES (seq
) - ibyte
);
1749 cbytes
= CHAR_BYTES (c
);
1757 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1764 if (nchars
!= SCHARS (seq
))
1768 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1769 if (!STRING_MULTIBYTE (seq
))
1770 STRING_SET_UNIBYTE (tem
);
1772 for (i
= nchars
= nbytes
= ibyte
= 0;
1774 ++i
, ibyte
+= cbytes
)
1776 if (STRING_MULTIBYTE (seq
))
1778 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1779 SBYTES (seq
) - ibyte
);
1780 cbytes
= CHAR_BYTES (c
);
1788 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1790 unsigned char *from
= SDATA (seq
) + ibyte
;
1791 unsigned char *to
= SDATA (tem
) + nbytes
;
1797 for (n
= cbytes
; n
--; )
1807 Lisp_Object tail
, prev
;
1809 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1811 CHECK_LIST_CONS (tail
, seq
);
1813 if (!NILP (Fequal (elt
, XCAR (tail
))))
1818 Fsetcdr (prev
, XCDR (tail
));
1829 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1830 doc
: /* Reverse LIST by modifying cdr pointers.
1831 Return the reversed list. */)
1835 register Lisp_Object prev
, tail
, next
;
1837 if (NILP (list
)) return list
;
1840 while (!NILP (tail
))
1843 CHECK_LIST_CONS (tail
, list
);
1845 Fsetcdr (tail
, prev
);
1852 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1853 doc
: /* Reverse LIST, copying. Return the reversed list.
1854 See also the function `nreverse', which is used more often. */)
1860 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1863 new = Fcons (XCAR (list
), new);
1865 CHECK_LIST_END (list
, list
);
1869 Lisp_Object
merge ();
1871 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1872 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1873 Returns the sorted list. LIST is modified by side effects.
1874 PREDICATE is called with two elements of LIST, and should return non-nil
1875 if the first element should sort before the second. */)
1877 Lisp_Object list
, predicate
;
1879 Lisp_Object front
, back
;
1880 register Lisp_Object len
, tem
;
1881 struct gcpro gcpro1
, gcpro2
;
1882 register int length
;
1885 len
= Flength (list
);
1886 length
= XINT (len
);
1890 XSETINT (len
, (length
/ 2) - 1);
1891 tem
= Fnthcdr (len
, list
);
1893 Fsetcdr (tem
, Qnil
);
1895 GCPRO2 (front
, back
);
1896 front
= Fsort (front
, predicate
);
1897 back
= Fsort (back
, predicate
);
1899 return merge (front
, back
, predicate
);
1903 merge (org_l1
, org_l2
, pred
)
1904 Lisp_Object org_l1
, org_l2
;
1908 register Lisp_Object tail
;
1910 register Lisp_Object l1
, l2
;
1911 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1918 /* It is sufficient to protect org_l1 and org_l2.
1919 When l1 and l2 are updated, we copy the new values
1920 back into the org_ vars. */
1921 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1941 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1957 Fsetcdr (tail
, tem
);
1963 #if 0 /* Unsafe version. */
1964 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1965 doc
: /* Extract a value from a property list.
1966 PLIST is a property list, which is a list of the form
1967 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1968 corresponding to the given PROP, or nil if PROP is not
1969 one of the properties on the list. */)
1977 CONSP (tail
) && CONSP (XCDR (tail
));
1978 tail
= XCDR (XCDR (tail
)))
1980 if (EQ (prop
, XCAR (tail
)))
1981 return XCAR (XCDR (tail
));
1983 /* This function can be called asynchronously
1984 (setup_coding_system). Don't QUIT in that case. */
1985 if (!interrupt_input_blocked
)
1989 CHECK_LIST_END (tail
, prop
);
1995 /* This does not check for quits. That is safe since it must terminate. */
1997 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1998 doc
: /* Extract a value from a property list.
1999 PLIST is a property list, which is a list of the form
2000 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2001 corresponding to the given PROP, or nil if PROP is not one of the
2002 properties on the list. This function never signals an error. */)
2007 Lisp_Object tail
, halftail
;
2009 /* halftail is used to detect circular lists. */
2010 tail
= halftail
= plist
;
2011 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2013 if (EQ (prop
, XCAR (tail
)))
2014 return XCAR (XCDR (tail
));
2016 tail
= XCDR (XCDR (tail
));
2017 halftail
= XCDR (halftail
);
2018 if (EQ (tail
, halftail
))
2025 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2026 doc
: /* Return the value of SYMBOL's PROPNAME property.
2027 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2029 Lisp_Object symbol
, propname
;
2031 CHECK_SYMBOL (symbol
);
2032 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2035 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2036 doc
: /* Change value in PLIST of PROP to VAL.
2037 PLIST is a property list, which is a list of the form
2038 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2039 If PROP is already a property on the list, its value is set to VAL,
2040 otherwise the new PROP VAL pair is added. The new plist is returned;
2041 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2042 The PLIST is modified by side effects. */)
2045 register Lisp_Object prop
;
2048 register Lisp_Object tail
, prev
;
2049 Lisp_Object newcell
;
2051 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2052 tail
= XCDR (XCDR (tail
)))
2054 if (EQ (prop
, XCAR (tail
)))
2056 Fsetcar (XCDR (tail
), val
);
2063 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2067 Fsetcdr (XCDR (prev
), newcell
);
2071 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2072 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2073 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2074 (symbol
, propname
, value
)
2075 Lisp_Object symbol
, propname
, value
;
2077 CHECK_SYMBOL (symbol
);
2078 XSYMBOL (symbol
)->plist
2079 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2083 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2084 doc
: /* Extract a value from a property list, comparing with `equal'.
2085 PLIST is a property list, which is a list of the form
2086 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2087 corresponding to the given PROP, or nil if PROP is not
2088 one of the properties on the list. */)
2096 CONSP (tail
) && CONSP (XCDR (tail
));
2097 tail
= XCDR (XCDR (tail
)))
2099 if (! NILP (Fequal (prop
, XCAR (tail
))))
2100 return XCAR (XCDR (tail
));
2105 CHECK_LIST_END (tail
, prop
);
2110 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2111 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2112 PLIST is a property list, which is a list of the form
2113 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2114 If PROP is already a property on the list, its value is set to VAL,
2115 otherwise the new PROP VAL pair is added. The new plist is returned;
2116 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2117 The PLIST is modified by side effects. */)
2120 register Lisp_Object prop
;
2123 register Lisp_Object tail
, prev
;
2124 Lisp_Object newcell
;
2126 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2127 tail
= XCDR (XCDR (tail
)))
2129 if (! NILP (Fequal (prop
, XCAR (tail
))))
2131 Fsetcar (XCDR (tail
), val
);
2138 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2142 Fsetcdr (XCDR (prev
), newcell
);
2146 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2147 doc
: /* Return t if the two args are the same Lisp object.
2148 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2150 Lisp_Object obj1
, obj2
;
2153 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2155 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2158 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2159 doc
: /* Return t if two Lisp objects have similar structure and contents.
2160 They must have the same data type.
2161 Conses are compared by comparing the cars and the cdrs.
2162 Vectors and strings are compared element by element.
2163 Numbers are compared by value, but integers cannot equal floats.
2164 (Use `=' if you want integers and floats to be able to be equal.)
2165 Symbols must match exactly. */)
2167 register Lisp_Object o1
, o2
;
2169 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2172 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2173 doc
: /* Return t if two Lisp objects have similar structure and contents.
2174 This is like `equal' except that it compares the text properties
2175 of strings. (`equal' ignores text properties.) */)
2177 register Lisp_Object o1
, o2
;
2179 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2182 /* DEPTH is current depth of recursion. Signal an error if it
2184 PROPS, if non-nil, means compare string text properties too. */
2187 internal_equal (o1
, o2
, depth
, props
)
2188 register Lisp_Object o1
, o2
;
2192 error ("Stack overflow in equal");
2198 if (XTYPE (o1
) != XTYPE (o2
))
2207 d1
= extract_float (o1
);
2208 d2
= extract_float (o2
);
2209 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2210 though they are not =. */
2211 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2215 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2222 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2226 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2228 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2231 o1
= XOVERLAY (o1
)->plist
;
2232 o2
= XOVERLAY (o2
)->plist
;
2237 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2238 && (XMARKER (o1
)->buffer
== 0
2239 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2243 case Lisp_Vectorlike
:
2246 EMACS_INT size
= XVECTOR (o1
)->size
;
2247 /* Pseudovectors have the type encoded in the size field, so this test
2248 actually checks that the objects have the same type as well as the
2250 if (XVECTOR (o2
)->size
!= size
)
2252 /* Boolvectors are compared much like strings. */
2253 if (BOOL_VECTOR_P (o1
))
2256 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2257 / BOOL_VECTOR_BITS_PER_CHAR
);
2259 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2261 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2266 if (WINDOW_CONFIGURATIONP (o1
))
2267 return compare_window_configurations (o1
, o2
, 0);
2269 /* Aside from them, only true vectors, char-tables, and compiled
2270 functions are sensible to compare, so eliminate the others now. */
2271 if (size
& PSEUDOVECTOR_FLAG
)
2273 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2275 size
&= PSEUDOVECTOR_SIZE_MASK
;
2277 for (i
= 0; i
< size
; i
++)
2280 v1
= XVECTOR (o1
)->contents
[i
];
2281 v2
= XVECTOR (o2
)->contents
[i
];
2282 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2290 if (SCHARS (o1
) != SCHARS (o2
))
2292 if (SBYTES (o1
) != SBYTES (o2
))
2294 if (bcmp (SDATA (o1
), SDATA (o2
),
2297 if (props
&& !compare_string_intervals (o1
, o2
))
2303 case Lisp_Type_Limit
:
2310 extern Lisp_Object
Fmake_char_internal ();
2312 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2313 doc
: /* Store each element of ARRAY with ITEM.
2314 ARRAY is a vector, string, char-table, or bool-vector. */)
2316 Lisp_Object array
, item
;
2318 register int size
, index
, charval
;
2319 if (VECTORP (array
))
2321 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2322 size
= XVECTOR (array
)->size
;
2323 for (index
= 0; index
< size
; index
++)
2326 else if (CHAR_TABLE_P (array
))
2328 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2329 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2330 for (index
= 0; index
< size
; index
++)
2332 XCHAR_TABLE (array
)->defalt
= Qnil
;
2334 else if (STRINGP (array
))
2336 register unsigned char *p
= SDATA (array
);
2337 CHECK_NUMBER (item
);
2338 charval
= XINT (item
);
2339 size
= SCHARS (array
);
2340 if (STRING_MULTIBYTE (array
))
2342 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2343 int len
= CHAR_STRING (charval
, str
);
2344 int size_byte
= SBYTES (array
);
2345 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2348 if (size
!= size_byte
)
2351 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2352 if (len
!= this_len
)
2353 error ("Attempt to change byte length of a string");
2356 for (i
= 0; i
< size_byte
; i
++)
2357 *p
++ = str
[i
% len
];
2360 for (index
= 0; index
< size
; index
++)
2363 else if (BOOL_VECTOR_P (array
))
2365 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2367 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2368 / BOOL_VECTOR_BITS_PER_CHAR
);
2370 charval
= (! NILP (item
) ? -1 : 0);
2371 for (index
= 0; index
< size_in_chars
- 1; index
++)
2373 if (index
< size_in_chars
)
2375 /* Mask out bits beyond the vector size. */
2376 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2377 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2382 wrong_type_argument (Qarrayp
, array
);
2386 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2388 doc
: /* Clear the contents of STRING.
2389 This makes STRING unibyte and may change its length. */)
2394 CHECK_STRING (string
);
2395 len
= SBYTES (string
);
2396 bzero (SDATA (string
), len
);
2397 STRING_SET_CHARS (string
, len
);
2398 STRING_SET_UNIBYTE (string
);
2402 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2404 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2406 Lisp_Object char_table
;
2408 CHECK_CHAR_TABLE (char_table
);
2410 return XCHAR_TABLE (char_table
)->purpose
;
2413 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2415 doc
: /* Return the parent char-table of CHAR-TABLE.
2416 The value is either nil or another char-table.
2417 If CHAR-TABLE holds nil for a given character,
2418 then the actual applicable value is inherited from the parent char-table
2419 \(or from its parents, if necessary). */)
2421 Lisp_Object char_table
;
2423 CHECK_CHAR_TABLE (char_table
);
2425 return XCHAR_TABLE (char_table
)->parent
;
2428 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2430 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2431 Return PARENT. PARENT must be either nil or another char-table. */)
2432 (char_table
, parent
)
2433 Lisp_Object char_table
, parent
;
2437 CHECK_CHAR_TABLE (char_table
);
2441 CHECK_CHAR_TABLE (parent
);
2443 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2444 if (EQ (temp
, char_table
))
2445 error ("Attempt to make a chartable be its own parent");
2448 XCHAR_TABLE (char_table
)->parent
= parent
;
2453 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2455 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2457 Lisp_Object char_table
, n
;
2459 CHECK_CHAR_TABLE (char_table
);
2462 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2463 args_out_of_range (char_table
, n
);
2465 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2468 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2469 Sset_char_table_extra_slot
,
2471 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2472 (char_table
, n
, value
)
2473 Lisp_Object char_table
, n
, value
;
2475 CHECK_CHAR_TABLE (char_table
);
2478 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2479 args_out_of_range (char_table
, n
);
2481 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2485 char_table_range (table
, from
, to
, defalt
)
2492 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2493 defalt
= XCHAR_TABLE (table
)->defalt
;
2494 val
= XCHAR_TABLE (table
)->contents
[from
];
2495 if (SUB_CHAR_TABLE_P (val
))
2496 val
= char_table_range (val
, 32, 127, defalt
);
2497 else if (NILP (val
))
2499 for (from
++; from
<= to
; from
++)
2501 Lisp_Object this_val
;
2503 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2504 if (SUB_CHAR_TABLE_P (this_val
))
2505 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2506 else if (NILP (this_val
))
2508 if (! EQ (val
, this_val
))
2509 error ("Characters in the range have inconsistent values");
2515 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2517 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2518 RANGE should be nil (for the default value),
2519 a vector which identifies a character set or a row of a character set,
2520 a character set name, or a character code.
2521 If the characters in the specified range have different values,
2522 an error is signaled.
2524 Note that this function doesn't check the parent of CHAR-TABLE. */)
2526 Lisp_Object char_table
, range
;
2528 int charset_id
, c1
= 0, c2
= 0;
2530 Lisp_Object ch
, val
, current_default
;
2532 CHECK_CHAR_TABLE (char_table
);
2534 if (EQ (range
, Qnil
))
2535 return XCHAR_TABLE (char_table
)->defalt
;
2536 if (INTEGERP (range
))
2538 int c
= XINT (range
);
2539 if (! CHAR_VALID_P (c
, 0))
2540 error ("Invalid character code: %d", c
);
2542 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2544 else if (SYMBOLP (range
))
2546 Lisp_Object charset_info
;
2548 charset_info
= Fget (range
, Qcharset
);
2549 CHECK_VECTOR (charset_info
);
2550 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2551 ch
= Fmake_char_internal (make_number (charset_id
),
2552 make_number (0), make_number (0));
2554 else if (VECTORP (range
))
2556 size
= ASIZE (range
);
2558 args_out_of_range (range
, make_number (0));
2559 CHECK_NUMBER (AREF (range
, 0));
2560 charset_id
= XINT (AREF (range
, 0));
2563 CHECK_NUMBER (AREF (range
, 1));
2564 c1
= XINT (AREF (range
, 1));
2567 CHECK_NUMBER (AREF (range
, 2));
2568 c2
= XINT (AREF (range
, 2));
2572 /* This checks if charset_id, c0, and c1 are all valid or not. */
2573 ch
= Fmake_char_internal (make_number (charset_id
),
2574 make_number (c1
), make_number (c2
));
2577 error ("Invalid RANGE argument to `char-table-range'");
2579 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2581 /* Fully specified character. */
2582 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2584 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2585 val
= Faref (char_table
, ch
);
2586 XCHAR_TABLE (char_table
)->parent
= parent
;
2590 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2591 if (charset_id
== CHARSET_ASCII
2592 || charset_id
== CHARSET_8_BIT_CONTROL
2593 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2595 int from
, to
, defalt
;
2597 if (charset_id
== CHARSET_ASCII
)
2598 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2599 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2600 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2602 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2603 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2604 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2605 return char_table_range (char_table
, from
, to
, current_default
);
2608 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2609 if (! SUB_CHAR_TABLE_P (val
))
2610 return (NILP (val
) ? current_default
: val
);
2611 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2612 current_default
= XCHAR_TABLE (val
)->defalt
;
2614 return char_table_range (val
, 32, 127, current_default
);
2615 val
= XCHAR_TABLE (val
)->contents
[c1
];
2616 if (! SUB_CHAR_TABLE_P (val
))
2617 return (NILP (val
) ? current_default
: val
);
2618 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2619 current_default
= XCHAR_TABLE (val
)->defalt
;
2620 return char_table_range (val
, 32, 127, current_default
);
2623 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2625 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2626 RANGE should be t (for all characters), nil (for the default value),
2627 a character set, a vector which identifies a character set, a row of a
2628 character set, or a character code. Return VALUE. */)
2629 (char_table
, range
, value
)
2630 Lisp_Object char_table
, range
, value
;
2634 CHECK_CHAR_TABLE (char_table
);
2637 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2639 /* Don't set these special slots used for default values of
2640 ascii, eight-bit-control, and eight-bit-graphic. */
2641 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2642 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2643 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2644 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2646 else if (EQ (range
, Qnil
))
2647 XCHAR_TABLE (char_table
)->defalt
= value
;
2648 else if (SYMBOLP (range
))
2650 Lisp_Object charset_info
;
2653 charset_info
= Fget (range
, Qcharset
);
2654 if (! VECTORP (charset_info
)
2655 || ! NATNUMP (AREF (charset_info
, 0))
2656 || (charset_id
= XINT (AREF (charset_info
, 0)),
2657 ! CHARSET_DEFINED_P (charset_id
)))
2658 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2660 if (charset_id
== CHARSET_ASCII
)
2661 for (i
= 0; i
< 128; i
++)
2662 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2663 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2664 for (i
= 128; i
< 160; i
++)
2665 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2666 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2667 for (i
= 160; i
< 256; i
++)
2668 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2670 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2672 else if (INTEGERP (range
))
2673 Faset (char_table
, range
, value
);
2674 else if (VECTORP (range
))
2676 int size
= XVECTOR (range
)->size
;
2677 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2678 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2679 size
<= 1 ? Qnil
: val
[1],
2680 size
<= 2 ? Qnil
: val
[2]);
2681 Faset (char_table
, ch
, value
);
2684 error ("Invalid RANGE argument to `set-char-table-range'");
2689 DEFUN ("set-char-table-default", Fset_char_table_default
,
2690 Sset_char_table_default
, 3, 3, 0,
2691 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2692 The generic character specifies the group of characters.
2693 If CH is a normal character, set the default value for a group of
2694 characters to which CH belongs.
2695 See also the documentation of `make-char'. */)
2696 (char_table
, ch
, value
)
2697 Lisp_Object char_table
, ch
, value
;
2699 int c
, charset
, code1
, code2
;
2702 CHECK_CHAR_TABLE (char_table
);
2706 SPLIT_CHAR (c
, charset
, code1
, code2
);
2708 /* Since we may want to set the default value for a character set
2709 not yet defined, we check only if the character set is in the
2710 valid range or not, instead of it is already defined or not. */
2711 if (! CHARSET_VALID_P (charset
))
2712 invalid_character (c
);
2714 if (SINGLE_BYTE_CHAR_P (c
))
2716 /* We use special slots for the default values of single byte
2719 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2720 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2721 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2723 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2726 /* Even if C is not a generic char, we had better behave as if a
2727 generic char is specified. */
2728 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2730 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2731 if (! SUB_CHAR_TABLE_P (temp
))
2733 temp
= make_sub_char_table (temp
);
2734 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2738 XCHAR_TABLE (temp
)->defalt
= value
;
2742 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2743 if (SUB_CHAR_TABLE_P (temp
))
2744 XCHAR_TABLE (temp
)->defalt
= value
;
2746 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2750 /* Look up the element in TABLE at index CH,
2751 and return it as an integer.
2752 If the element is nil, return CH itself.
2753 (Actually we do that for any non-integer.) */
2756 char_table_translate (table
, ch
)
2761 value
= Faref (table
, make_number (ch
));
2762 if (! INTEGERP (value
))
2764 return XINT (value
);
2768 optimize_sub_char_table (table
, chars
)
2776 from
= 33, to
= 127;
2778 from
= 32, to
= 128;
2780 if (!SUB_CHAR_TABLE_P (*table
)
2781 || ! NILP (XCHAR_TABLE (*table
)->defalt
))
2783 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2784 for (; from
< to
; from
++)
2785 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2790 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2791 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2799 CHECK_CHAR_TABLE (table
);
2801 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2803 elt
= XCHAR_TABLE (table
)->contents
[i
];
2804 if (!SUB_CHAR_TABLE_P (elt
))
2806 dim
= CHARSET_DIMENSION (i
- 128);
2807 chars
= CHARSET_CHARS (i
- 128);
2809 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2810 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, chars
);
2811 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, chars
);
2817 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2818 character or group of characters that share a value.
2819 DEPTH is the current depth in the originally specified
2820 chartable, and INDICES contains the vector indices
2821 for the levels our callers have descended.
2823 ARG is passed to C_FUNCTION when that is called. */
2826 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2827 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2828 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2832 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2834 GCPRO4 (arg
, table
, subtable
, function
);
2838 /* At first, handle ASCII and 8-bit European characters. */
2839 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2841 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2843 elt
= XCHAR_TABLE (subtable
)->defalt
;
2845 elt
= Faref (subtable
, make_number (i
));
2847 (*c_function
) (arg
, make_number (i
), elt
);
2849 call2 (function
, make_number (i
), elt
);
2851 #if 0 /* If the char table has entries for higher characters,
2852 we should report them. */
2853 if (NILP (current_buffer
->enable_multibyte_characters
))
2859 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2863 int charset
= XFASTINT (indices
[0]) - 128;
2866 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2867 if (CHARSET_CHARS (charset
) == 94)
2876 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2877 XSETFASTINT (indices
[depth
], i
);
2878 charset
= XFASTINT (indices
[0]) - 128;
2880 && (!CHARSET_DEFINED_P (charset
)
2881 || charset
== CHARSET_8_BIT_CONTROL
2882 || charset
== CHARSET_8_BIT_GRAPHIC
))
2885 if (SUB_CHAR_TABLE_P (elt
))
2888 error ("Too deep char table");
2889 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2895 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2896 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2897 c
= MAKE_CHAR (charset
, c1
, c2
);
2900 elt
= XCHAR_TABLE (subtable
)->defalt
;
2902 elt
= Faref (table
, make_number (c
));
2905 (*c_function
) (arg
, make_number (c
), elt
);
2907 call2 (function
, make_number (c
), elt
);
2913 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2915 void_call2 (a
, b
, c
)
2916 Lisp_Object a
, b
, c
;
2921 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2923 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2924 FUNCTION is called with two arguments--a key and a value.
2925 The key is always a possible IDX argument to `aref'. */)
2926 (function
, char_table
)
2927 Lisp_Object function
, char_table
;
2929 /* The depth of char table is at most 3. */
2930 Lisp_Object indices
[3];
2932 CHECK_CHAR_TABLE (char_table
);
2934 /* When Lisp_Object is represented as a union, `call2' cannot directly
2935 be passed to map_char_table because it returns a Lisp_Object rather
2936 than returning nothing.
2937 Casting leads to crashes on some architectures. -stef */
2938 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2942 /* Return a value for character C in char-table TABLE. Store the
2943 actual index for that value in *IDX. Ignore the default value of
2947 char_table_ref_and_index (table
, c
, idx
)
2951 int charset
, c1
, c2
;
2954 if (SINGLE_BYTE_CHAR_P (c
))
2957 return XCHAR_TABLE (table
)->contents
[c
];
2959 SPLIT_CHAR (c
, charset
, c1
, c2
);
2960 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2961 *idx
= MAKE_CHAR (charset
, 0, 0);
2962 if (!SUB_CHAR_TABLE_P (elt
))
2964 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2965 return XCHAR_TABLE (elt
)->defalt
;
2966 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2967 *idx
= MAKE_CHAR (charset
, c1
, 0);
2968 if (!SUB_CHAR_TABLE_P (elt
))
2970 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2971 return XCHAR_TABLE (elt
)->defalt
;
2973 return XCHAR_TABLE (elt
)->contents
[c2
];
2983 Lisp_Object args
[2];
2986 return Fnconc (2, args
);
2988 return Fnconc (2, &s1
);
2989 #endif /* NO_ARG_ARRAY */
2992 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2993 doc
: /* Concatenate any number of lists by altering them.
2994 Only the last argument is not altered, and need not be a list.
2995 usage: (nconc &rest LISTS) */)
3000 register int argnum
;
3001 register Lisp_Object tail
, tem
, val
;
3005 for (argnum
= 0; argnum
< nargs
; argnum
++)
3008 if (NILP (tem
)) continue;
3013 if (argnum
+ 1 == nargs
) break;
3015 CHECK_LIST_CONS (tem
, tem
);
3024 tem
= args
[argnum
+ 1];
3025 Fsetcdr (tail
, tem
);
3027 args
[argnum
+ 1] = tail
;
3033 /* This is the guts of all mapping functions.
3034 Apply FN to each element of SEQ, one by one,
3035 storing the results into elements of VALS, a C vector of Lisp_Objects.
3036 LENI is the length of VALS, which should also be the length of SEQ. */
3039 mapcar1 (leni
, vals
, fn
, seq
)
3042 Lisp_Object fn
, seq
;
3044 register Lisp_Object tail
;
3047 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3051 /* Don't let vals contain any garbage when GC happens. */
3052 for (i
= 0; i
< leni
; i
++)
3055 GCPRO3 (dummy
, fn
, seq
);
3057 gcpro1
.nvars
= leni
;
3061 /* We need not explicitly protect `tail' because it is used only on lists, and
3062 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3066 for (i
= 0; i
< leni
; i
++)
3068 dummy
= XVECTOR (seq
)->contents
[i
];
3069 dummy
= call1 (fn
, dummy
);
3074 else if (BOOL_VECTOR_P (seq
))
3076 for (i
= 0; i
< leni
; i
++)
3079 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3080 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3085 dummy
= call1 (fn
, dummy
);
3090 else if (STRINGP (seq
))
3094 for (i
= 0, i_byte
= 0; i
< leni
;)
3099 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3100 XSETFASTINT (dummy
, c
);
3101 dummy
= call1 (fn
, dummy
);
3103 vals
[i_before
] = dummy
;
3106 else /* Must be a list, since Flength did not get an error */
3109 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3111 dummy
= call1 (fn
, XCAR (tail
));
3121 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3122 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3123 In between each pair of results, stick in SEPARATOR. Thus, " " as
3124 SEPARATOR results in spaces between the values returned by FUNCTION.
3125 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3126 (function
, sequence
, separator
)
3127 Lisp_Object function
, sequence
, separator
;
3132 register Lisp_Object
*args
;
3134 struct gcpro gcpro1
;
3138 len
= Flength (sequence
);
3140 nargs
= leni
+ leni
- 1;
3141 if (nargs
< 0) return build_string ("");
3143 SAFE_ALLOCA_LISP (args
, nargs
);
3146 mapcar1 (leni
, args
, function
, sequence
);
3149 for (i
= leni
- 1; i
> 0; i
--)
3150 args
[i
+ i
] = args
[i
];
3152 for (i
= 1; i
< nargs
; i
+= 2)
3153 args
[i
] = separator
;
3155 ret
= Fconcat (nargs
, args
);
3161 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3162 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3163 The result is a list just as long as SEQUENCE.
3164 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3165 (function
, sequence
)
3166 Lisp_Object function
, sequence
;
3168 register Lisp_Object len
;
3170 register Lisp_Object
*args
;
3174 len
= Flength (sequence
);
3175 leni
= XFASTINT (len
);
3177 SAFE_ALLOCA_LISP (args
, leni
);
3179 mapcar1 (leni
, args
, function
, sequence
);
3181 ret
= Flist (leni
, args
);
3187 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3188 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3189 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3190 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3191 (function
, sequence
)
3192 Lisp_Object function
, sequence
;
3196 leni
= XFASTINT (Flength (sequence
));
3197 mapcar1 (leni
, 0, function
, sequence
);
3202 /* Anything that calls this function must protect from GC! */
3204 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3205 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3206 Takes one argument, which is the string to display to ask the question.
3207 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3208 No confirmation of the answer is requested; a single character is enough.
3209 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3210 the bindings in `query-replace-map'; see the documentation of that variable
3211 for more information. In this case, the useful bindings are `act', `skip',
3212 `recenter', and `quit'.\)
3214 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3215 is nil and `use-dialog-box' is non-nil. */)
3219 register Lisp_Object obj
, key
, def
, map
;
3220 register int answer
;
3221 Lisp_Object xprompt
;
3222 Lisp_Object args
[2];
3223 struct gcpro gcpro1
, gcpro2
;
3224 int count
= SPECPDL_INDEX ();
3226 specbind (Qcursor_in_echo_area
, Qt
);
3228 map
= Fsymbol_value (intern ("query-replace-map"));
3230 CHECK_STRING (prompt
);
3232 GCPRO2 (prompt
, xprompt
);
3234 #ifdef HAVE_X_WINDOWS
3235 if (display_hourglass_p
)
3236 cancel_hourglass ();
3243 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3247 Lisp_Object pane
, menu
;
3248 redisplay_preserve_echo_area (3);
3249 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3250 Fcons (Fcons (build_string ("No"), Qnil
),
3252 menu
= Fcons (prompt
, pane
);
3253 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3254 answer
= !NILP (obj
);
3257 #endif /* HAVE_MENUS */
3258 cursor_in_echo_area
= 1;
3259 choose_minibuf_frame ();
3262 Lisp_Object pargs
[3];
3264 /* Colorize prompt according to `minibuffer-prompt' face. */
3265 pargs
[0] = build_string ("%s(y or n) ");
3266 pargs
[1] = intern ("face");
3267 pargs
[2] = intern ("minibuffer-prompt");
3268 args
[0] = Fpropertize (3, pargs
);
3273 if (minibuffer_auto_raise
)
3275 Lisp_Object mini_frame
;
3277 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3279 Fraise_frame (mini_frame
);
3282 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
3283 cursor_in_echo_area
= 0;
3284 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3287 key
= Fmake_vector (make_number (1), obj
);
3288 def
= Flookup_key (map
, key
, Qt
);
3290 if (EQ (def
, intern ("skip")))
3295 else if (EQ (def
, intern ("act")))
3300 else if (EQ (def
, intern ("recenter")))
3306 else if (EQ (def
, intern ("quit")))
3308 /* We want to exit this command for exit-prefix,
3309 and this is the only way to do it. */
3310 else if (EQ (def
, intern ("exit-prefix")))
3315 /* If we don't clear this, then the next call to read_char will
3316 return quit_char again, and we'll enter an infinite loop. */
3321 if (EQ (xprompt
, prompt
))
3323 args
[0] = build_string ("Please answer y or n. ");
3325 xprompt
= Fconcat (2, args
);
3330 if (! noninteractive
)
3332 cursor_in_echo_area
= -1;
3333 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3337 unbind_to (count
, Qnil
);
3338 return answer
? Qt
: Qnil
;
3341 /* This is how C code calls `yes-or-no-p' and allows the user
3344 Anything that calls this function must protect from GC! */
3347 do_yes_or_no_p (prompt
)
3350 return call1 (intern ("yes-or-no-p"), prompt
);
3353 /* Anything that calls this function must protect from GC! */
3355 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3356 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3357 Takes one argument, which is the string to display to ask the question.
3358 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3359 The user must confirm the answer with RET,
3360 and can edit it until it has been confirmed.
3362 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3363 is nil, and `use-dialog-box' is non-nil. */)
3367 register Lisp_Object ans
;
3368 Lisp_Object args
[2];
3369 struct gcpro gcpro1
;
3371 CHECK_STRING (prompt
);
3374 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3378 Lisp_Object pane
, menu
, obj
;
3379 redisplay_preserve_echo_area (4);
3380 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3381 Fcons (Fcons (build_string ("No"), Qnil
),
3384 menu
= Fcons (prompt
, pane
);
3385 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3389 #endif /* HAVE_MENUS */
3392 args
[1] = build_string ("(yes or no) ");
3393 prompt
= Fconcat (2, args
);
3399 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3400 Qyes_or_no_p_history
, Qnil
,
3402 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3407 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3415 message ("Please answer yes or no.");
3416 Fsleep_for (make_number (2), Qnil
);
3420 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3421 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3423 Each of the three load averages is multiplied by 100, then converted
3426 When USE-FLOATS is non-nil, floats will be used instead of integers.
3427 These floats are not multiplied by 100.
3429 If the 5-minute or 15-minute load averages are not available, return a
3430 shortened list, containing only those averages which are available.
3432 An error is thrown if the load average can't be obtained. In some
3433 cases making it work would require Emacs being installed setuid or
3434 setgid so that it can read kernel information, and that usually isn't
3437 Lisp_Object use_floats
;
3440 int loads
= getloadavg (load_ave
, 3);
3441 Lisp_Object ret
= Qnil
;
3444 error ("load-average not implemented for this operating system");
3448 Lisp_Object load
= (NILP (use_floats
) ?
3449 make_number ((int) (100.0 * load_ave
[loads
]))
3450 : make_float (load_ave
[loads
]));
3451 ret
= Fcons (load
, ret
);
3457 Lisp_Object Vfeatures
, Qsubfeatures
;
3458 extern Lisp_Object Vafter_load_alist
;
3460 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3461 doc
: /* Returns t if FEATURE is present in this Emacs.
3463 Use this to conditionalize execution of lisp code based on the
3464 presence or absence of Emacs or environment extensions.
3465 Use `provide' to declare that a feature is available. This function
3466 looks at the value of the variable `features'. The optional argument
3467 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3468 (feature
, subfeature
)
3469 Lisp_Object feature
, subfeature
;
3471 register Lisp_Object tem
;
3472 CHECK_SYMBOL (feature
);
3473 tem
= Fmemq (feature
, Vfeatures
);
3474 if (!NILP (tem
) && !NILP (subfeature
))
3475 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3476 return (NILP (tem
)) ? Qnil
: Qt
;
3479 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3480 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3481 The optional argument SUBFEATURES should be a list of symbols listing
3482 particular subfeatures supported in this version of FEATURE. */)
3483 (feature
, subfeatures
)
3484 Lisp_Object feature
, subfeatures
;
3486 register Lisp_Object tem
;
3487 CHECK_SYMBOL (feature
);
3488 CHECK_LIST (subfeatures
);
3489 if (!NILP (Vautoload_queue
))
3490 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
3492 tem
= Fmemq (feature
, Vfeatures
);
3494 Vfeatures
= Fcons (feature
, Vfeatures
);
3495 if (!NILP (subfeatures
))
3496 Fput (feature
, Qsubfeatures
, subfeatures
);
3497 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3499 /* Run any load-hooks for this file. */
3500 tem
= Fassq (feature
, Vafter_load_alist
);
3502 Fprogn (XCDR (tem
));
3507 /* `require' and its subroutines. */
3509 /* List of features currently being require'd, innermost first. */
3511 Lisp_Object require_nesting_list
;
3514 require_unwind (old_value
)
3515 Lisp_Object old_value
;
3517 return require_nesting_list
= old_value
;
3520 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3521 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3522 If FEATURE is not a member of the list `features', then the feature
3523 is not loaded; so load the file FILENAME.
3524 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3525 and `load' will try to load this name appended with the suffix `.elc' or
3526 `.el', in that order. The name without appended suffix will not be used.
3527 If the optional third argument NOERROR is non-nil,
3528 then return nil if the file is not found instead of signaling an error.
3529 Normally the return value is FEATURE.
3530 The normal messages at start and end of loading FILENAME are suppressed. */)
3531 (feature
, filename
, noerror
)
3532 Lisp_Object feature
, filename
, noerror
;
3534 register Lisp_Object tem
;
3535 struct gcpro gcpro1
, gcpro2
;
3536 int from_file
= load_in_progress
;
3538 CHECK_SYMBOL (feature
);
3540 /* Record the presence of `require' in this file
3541 even if the feature specified is already loaded.
3542 But not more than once in any file,
3543 and not when we aren't loading or reading from a file. */
3545 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3546 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3551 tem
= Fcons (Qrequire
, feature
);
3552 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3553 LOADHIST_ATTACH (tem
);
3555 tem
= Fmemq (feature
, Vfeatures
);
3559 int count
= SPECPDL_INDEX ();
3562 /* This is to make sure that loadup.el gives a clear picture
3563 of what files are preloaded and when. */
3564 if (! NILP (Vpurify_flag
))
3565 error ("(require %s) while preparing to dump",
3566 SDATA (SYMBOL_NAME (feature
)));
3568 /* A certain amount of recursive `require' is legitimate,
3569 but if we require the same feature recursively 3 times,
3571 tem
= require_nesting_list
;
3572 while (! NILP (tem
))
3574 if (! NILP (Fequal (feature
, XCAR (tem
))))
3579 error ("Recursive `require' for feature `%s'",
3580 SDATA (SYMBOL_NAME (feature
)));
3582 /* Update the list for any nested `require's that occur. */
3583 record_unwind_protect (require_unwind
, require_nesting_list
);
3584 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3586 /* Value saved here is to be restored into Vautoload_queue */
3587 record_unwind_protect (un_autoload
, Vautoload_queue
);
3588 Vautoload_queue
= Qt
;
3590 /* Load the file. */
3591 GCPRO2 (feature
, filename
);
3592 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3593 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3596 /* If load failed entirely, return nil. */
3598 return unbind_to (count
, Qnil
);
3600 tem
= Fmemq (feature
, Vfeatures
);
3602 error ("Required feature `%s' was not provided",
3603 SDATA (SYMBOL_NAME (feature
)));
3605 /* Once loading finishes, don't undo it. */
3606 Vautoload_queue
= Qt
;
3607 feature
= unbind_to (count
, feature
);
3613 /* Primitives for work of the "widget" library.
3614 In an ideal world, this section would not have been necessary.
3615 However, lisp function calls being as slow as they are, it turns
3616 out that some functions in the widget library (wid-edit.el) are the
3617 bottleneck of Widget operation. Here is their translation to C,
3618 for the sole reason of efficiency. */
3620 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3621 doc
: /* Return non-nil if PLIST has the property PROP.
3622 PLIST is a property list, which is a list of the form
3623 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3624 Unlike `plist-get', this allows you to distinguish between a missing
3625 property and a property with the value nil.
3626 The value is actually the tail of PLIST whose car is PROP. */)
3628 Lisp_Object plist
, prop
;
3630 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3633 plist
= XCDR (plist
);
3634 plist
= CDR (plist
);
3639 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3640 doc
: /* In WIDGET, set PROPERTY to VALUE.
3641 The value can later be retrieved with `widget-get'. */)
3642 (widget
, property
, value
)
3643 Lisp_Object widget
, property
, value
;
3645 CHECK_CONS (widget
);
3646 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3650 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3651 doc
: /* In WIDGET, get the value of PROPERTY.
3652 The value could either be specified when the widget was created, or
3653 later with `widget-put'. */)
3655 Lisp_Object widget
, property
;
3663 CHECK_CONS (widget
);
3664 tmp
= Fplist_member (XCDR (widget
), property
);
3670 tmp
= XCAR (widget
);
3673 widget
= Fget (tmp
, Qwidget_type
);
3677 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3678 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3679 ARGS are passed as extra arguments to the function.
3680 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3685 /* This function can GC. */
3686 Lisp_Object newargs
[3];
3687 struct gcpro gcpro1
, gcpro2
;
3690 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3691 newargs
[1] = args
[0];
3692 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3693 GCPRO2 (newargs
[0], newargs
[2]);
3694 result
= Fapply (3, newargs
);
3699 #ifdef HAVE_LANGINFO_CODESET
3700 #include <langinfo.h>
3703 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3704 doc
: /* Access locale data ITEM for the current C locale, if available.
3705 ITEM should be one of the following:
3707 `codeset', returning the character set as a string (locale item CODESET);
3709 `days', returning a 7-element vector of day names (locale items DAY_n);
3711 `months', returning a 12-element vector of month names (locale items MON_n);
3713 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3714 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3716 If the system can't provide such information through a call to
3717 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3719 See also Info node `(libc)Locales'.
3721 The data read from the system are decoded using `locale-coding-system'. */)
3726 #ifdef HAVE_LANGINFO_CODESET
3728 if (EQ (item
, Qcodeset
))
3730 str
= nl_langinfo (CODESET
);
3731 return build_string (str
);
3734 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3736 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3737 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3739 synchronize_system_time_locale ();
3740 for (i
= 0; i
< 7; i
++)
3742 str
= nl_langinfo (days
[i
]);
3743 val
= make_unibyte_string (str
, strlen (str
));
3744 /* Fixme: Is this coding system necessarily right, even if
3745 it is consistent with CODESET? If not, what to do? */
3746 Faset (v
, make_number (i
),
3747 code_convert_string_norecord (val
, Vlocale_coding_system
,
3754 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3756 struct Lisp_Vector
*p
= allocate_vector (12);
3757 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3758 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3760 synchronize_system_time_locale ();
3761 for (i
= 0; i
< 12; i
++)
3763 str
= nl_langinfo (months
[i
]);
3764 val
= make_unibyte_string (str
, strlen (str
));
3766 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3768 XSETVECTOR (val
, p
);
3772 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3773 but is in the locale files. This could be used by ps-print. */
3775 else if (EQ (item
, Qpaper
))
3777 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3778 make_number (nl_langinfo (PAPER_HEIGHT
)));
3780 #endif /* PAPER_WIDTH */
3781 #endif /* HAVE_LANGINFO_CODESET*/
3785 /* base64 encode/decode functions (RFC 2045).
3786 Based on code from GNU recode. */
3788 #define MIME_LINE_LENGTH 76
3790 #define IS_ASCII(Character) \
3792 #define IS_BASE64(Character) \
3793 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3794 #define IS_BASE64_IGNORABLE(Character) \
3795 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3796 || (Character) == '\f' || (Character) == '\r')
3798 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3799 character or return retval if there are no characters left to
3801 #define READ_QUADRUPLET_BYTE(retval) \
3806 if (nchars_return) \
3807 *nchars_return = nchars; \
3812 while (IS_BASE64_IGNORABLE (c))
3814 /* Table of characters coding the 64 values. */
3815 static char base64_value_to_char
[64] =
3817 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3818 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3819 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3820 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3821 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3822 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3823 '8', '9', '+', '/' /* 60-63 */
3826 /* Table of base64 values for first 128 characters. */
3827 static short base64_char_to_value
[128] =
3829 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3830 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3831 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3832 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3833 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3834 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3835 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3836 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3837 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3838 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3839 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3840 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3841 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3844 /* The following diagram shows the logical steps by which three octets
3845 get transformed into four base64 characters.
3847 .--------. .--------. .--------.
3848 |aaaaaabb| |bbbbcccc| |ccdddddd|
3849 `--------' `--------' `--------'
3851 .--------+--------+--------+--------.
3852 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3853 `--------+--------+--------+--------'
3855 .--------+--------+--------+--------.
3856 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3857 `--------+--------+--------+--------'
3859 The octets are divided into 6 bit chunks, which are then encoded into
3860 base64 characters. */
3863 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3864 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3866 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3868 doc
: /* Base64-encode the region between BEG and END.
3869 Return the length of the encoded text.
3870 Optional third argument NO-LINE-BREAK means do not break long lines
3871 into shorter lines. */)
3872 (beg
, end
, no_line_break
)
3873 Lisp_Object beg
, end
, no_line_break
;
3876 int allength
, length
;
3877 int ibeg
, iend
, encoded_length
;
3881 validate_region (&beg
, &end
);
3883 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3884 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3885 move_gap_both (XFASTINT (beg
), ibeg
);
3887 /* We need to allocate enough room for encoding the text.
3888 We need 33 1/3% more space, plus a newline every 76
3889 characters, and then we round up. */
3890 length
= iend
- ibeg
;
3891 allength
= length
+ length
/3 + 1;
3892 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3894 SAFE_ALLOCA (encoded
, char *, allength
);
3895 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3896 NILP (no_line_break
),
3897 !NILP (current_buffer
->enable_multibyte_characters
));
3898 if (encoded_length
> allength
)
3901 if (encoded_length
< 0)
3903 /* The encoding wasn't possible. */
3905 error ("Multibyte character in data for base64 encoding");
3908 /* Now we have encoded the region, so we insert the new contents
3909 and delete the old. (Insert first in order to preserve markers.) */
3910 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3911 insert (encoded
, encoded_length
);
3913 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3915 /* If point was outside of the region, restore it exactly; else just
3916 move to the beginning of the region. */
3917 if (old_pos
>= XFASTINT (end
))
3918 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3919 else if (old_pos
> XFASTINT (beg
))
3920 old_pos
= XFASTINT (beg
);
3923 /* We return the length of the encoded text. */
3924 return make_number (encoded_length
);
3927 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3929 doc
: /* Base64-encode STRING and return the result.
3930 Optional second argument NO-LINE-BREAK means do not break long lines
3931 into shorter lines. */)
3932 (string
, no_line_break
)
3933 Lisp_Object string
, no_line_break
;
3935 int allength
, length
, encoded_length
;
3937 Lisp_Object encoded_string
;
3940 CHECK_STRING (string
);
3942 /* We need to allocate enough room for encoding the text.
3943 We need 33 1/3% more space, plus a newline every 76
3944 characters, and then we round up. */
3945 length
= SBYTES (string
);
3946 allength
= length
+ length
/3 + 1;
3947 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3949 /* We need to allocate enough room for decoding the text. */
3950 SAFE_ALLOCA (encoded
, char *, allength
);
3952 encoded_length
= base64_encode_1 (SDATA (string
),
3953 encoded
, length
, NILP (no_line_break
),
3954 STRING_MULTIBYTE (string
));
3955 if (encoded_length
> allength
)
3958 if (encoded_length
< 0)
3960 /* The encoding wasn't possible. */
3962 error ("Multibyte character in data for base64 encoding");
3965 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3968 return encoded_string
;
3972 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3979 int counter
= 0, i
= 0;
3989 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3997 /* Wrap line every 76 characters. */
4001 if (counter
< MIME_LINE_LENGTH
/ 4)
4010 /* Process first byte of a triplet. */
4012 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
4013 value
= (0x03 & c
) << 4;
4015 /* Process second byte of a triplet. */
4019 *e
++ = base64_value_to_char
[value
];
4027 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4035 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4036 value
= (0x0f & c
) << 2;
4038 /* Process third byte of a triplet. */
4042 *e
++ = base64_value_to_char
[value
];
4049 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4057 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4058 *e
++ = base64_value_to_char
[0x3f & c
];
4065 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4067 doc
: /* Base64-decode the region between BEG and END.
4068 Return the length of the decoded text.
4069 If the region can't be decoded, signal an error and don't modify the buffer. */)
4071 Lisp_Object beg
, end
;
4073 int ibeg
, iend
, length
, allength
;
4078 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4081 validate_region (&beg
, &end
);
4083 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4084 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4086 length
= iend
- ibeg
;
4088 /* We need to allocate enough room for decoding the text. If we are
4089 working on a multibyte buffer, each decoded code may occupy at
4091 allength
= multibyte
? length
* 2 : length
;
4092 SAFE_ALLOCA (decoded
, char *, allength
);
4094 move_gap_both (XFASTINT (beg
), ibeg
);
4095 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4096 multibyte
, &inserted_chars
);
4097 if (decoded_length
> allength
)
4100 if (decoded_length
< 0)
4102 /* The decoding wasn't possible. */
4104 error ("Invalid base64 data");
4107 /* Now we have decoded the region, so we insert the new contents
4108 and delete the old. (Insert first in order to preserve markers.) */
4109 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4110 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4113 /* Delete the original text. */
4114 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4115 iend
+ decoded_length
, 1);
4117 /* If point was outside of the region, restore it exactly; else just
4118 move to the beginning of the region. */
4119 if (old_pos
>= XFASTINT (end
))
4120 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4121 else if (old_pos
> XFASTINT (beg
))
4122 old_pos
= XFASTINT (beg
);
4123 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4125 return make_number (inserted_chars
);
4128 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4130 doc
: /* Base64-decode STRING and return the result. */)
4135 int length
, decoded_length
;
4136 Lisp_Object decoded_string
;
4139 CHECK_STRING (string
);
4141 length
= SBYTES (string
);
4142 /* We need to allocate enough room for decoding the text. */
4143 SAFE_ALLOCA (decoded
, char *, length
);
4145 /* The decoded result should be unibyte. */
4146 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4148 if (decoded_length
> length
)
4150 else if (decoded_length
>= 0)
4151 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4153 decoded_string
= Qnil
;
4156 if (!STRINGP (decoded_string
))
4157 error ("Invalid base64 data");
4159 return decoded_string
;
4162 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4163 MULTIBYTE is nonzero, the decoded result should be in multibyte
4164 form. If NCHARS_RETRUN is not NULL, store the number of produced
4165 characters in *NCHARS_RETURN. */
4168 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4178 unsigned long value
;
4183 /* Process first byte of a quadruplet. */
4185 READ_QUADRUPLET_BYTE (e
-to
);
4189 value
= base64_char_to_value
[c
] << 18;
4191 /* Process second byte of a quadruplet. */
4193 READ_QUADRUPLET_BYTE (-1);
4197 value
|= base64_char_to_value
[c
] << 12;
4199 c
= (unsigned char) (value
>> 16);
4201 e
+= CHAR_STRING (c
, e
);
4206 /* Process third byte of a quadruplet. */
4208 READ_QUADRUPLET_BYTE (-1);
4212 READ_QUADRUPLET_BYTE (-1);
4221 value
|= base64_char_to_value
[c
] << 6;
4223 c
= (unsigned char) (0xff & value
>> 8);
4225 e
+= CHAR_STRING (c
, e
);
4230 /* Process fourth byte of a quadruplet. */
4232 READ_QUADRUPLET_BYTE (-1);
4239 value
|= base64_char_to_value
[c
];
4241 c
= (unsigned char) (0xff & value
);
4243 e
+= CHAR_STRING (c
, e
);
4252 /***********************************************************************
4254 ***** Hash Tables *****
4256 ***********************************************************************/
4258 /* Implemented by gerd@gnu.org. This hash table implementation was
4259 inspired by CMUCL hash tables. */
4263 1. For small tables, association lists are probably faster than
4264 hash tables because they have lower overhead.
4266 For uses of hash tables where the O(1) behavior of table
4267 operations is not a requirement, it might therefore be a good idea
4268 not to hash. Instead, we could just do a linear search in the
4269 key_and_value vector of the hash table. This could be done
4270 if a `:linear-search t' argument is given to make-hash-table. */
4273 /* The list of all weak hash tables. Don't staticpro this one. */
4275 Lisp_Object Vweak_hash_tables
;
4277 /* Various symbols. */
4279 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4280 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4281 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4283 /* Function prototypes. */
4285 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4286 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4287 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4288 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4289 Lisp_Object
, unsigned));
4290 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4291 Lisp_Object
, unsigned));
4292 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4293 unsigned, Lisp_Object
, unsigned));
4294 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4295 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4296 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4297 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4299 static unsigned sxhash_string
P_ ((unsigned char *, int));
4300 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4301 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4302 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4303 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4307 /***********************************************************************
4309 ***********************************************************************/
4311 /* If OBJ is a Lisp hash table, return a pointer to its struct
4312 Lisp_Hash_Table. Otherwise, signal an error. */
4314 static struct Lisp_Hash_Table
*
4315 check_hash_table (obj
)
4318 CHECK_HASH_TABLE (obj
);
4319 return XHASH_TABLE (obj
);
4323 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4327 next_almost_prime (n
)
4340 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4341 which USED[I] is non-zero. If found at index I in ARGS, set
4342 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4343 -1. This function is used to extract a keyword/argument pair from
4344 a DEFUN parameter list. */
4347 get_key_arg (key
, nargs
, args
, used
)
4355 for (i
= 0; i
< nargs
- 1; ++i
)
4356 if (!used
[i
] && EQ (args
[i
], key
))
4371 /* Return a Lisp vector which has the same contents as VEC but has
4372 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4373 vector that are not copied from VEC are set to INIT. */
4376 larger_vector (vec
, new_size
, init
)
4381 struct Lisp_Vector
*v
;
4384 xassert (VECTORP (vec
));
4385 old_size
= XVECTOR (vec
)->size
;
4386 xassert (new_size
>= old_size
);
4388 v
= allocate_vector (new_size
);
4389 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4390 old_size
* sizeof *v
->contents
);
4391 for (i
= old_size
; i
< new_size
; ++i
)
4392 v
->contents
[i
] = init
;
4393 XSETVECTOR (vec
, v
);
4398 /***********************************************************************
4400 ***********************************************************************/
4402 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4403 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4404 KEY2 are the same. */
4407 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4408 struct Lisp_Hash_Table
*h
;
4409 Lisp_Object key1
, key2
;
4410 unsigned hash1
, hash2
;
4412 return (FLOATP (key1
)
4414 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4418 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4419 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4420 KEY2 are the same. */
4423 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4424 struct Lisp_Hash_Table
*h
;
4425 Lisp_Object key1
, key2
;
4426 unsigned hash1
, hash2
;
4428 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4432 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4433 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4434 if KEY1 and KEY2 are the same. */
4437 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4438 struct Lisp_Hash_Table
*h
;
4439 Lisp_Object key1
, key2
;
4440 unsigned hash1
, hash2
;
4444 Lisp_Object args
[3];
4446 args
[0] = h
->user_cmp_function
;
4449 return !NILP (Ffuncall (3, args
));
4456 /* Value is a hash code for KEY for use in hash table H which uses
4457 `eq' to compare keys. The hash code returned is guaranteed to fit
4458 in a Lisp integer. */
4462 struct Lisp_Hash_Table
*h
;
4465 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4466 xassert ((hash
& ~INTMASK
) == 0);
4471 /* Value is a hash code for KEY for use in hash table H which uses
4472 `eql' to compare keys. The hash code returned is guaranteed to fit
4473 in a Lisp integer. */
4477 struct Lisp_Hash_Table
*h
;
4482 hash
= sxhash (key
, 0);
4484 hash
= XUINT (key
) ^ XGCTYPE (key
);
4485 xassert ((hash
& ~INTMASK
) == 0);
4490 /* Value is a hash code for KEY for use in hash table H which uses
4491 `equal' to compare keys. The hash code returned is guaranteed to fit
4492 in a Lisp integer. */
4495 hashfn_equal (h
, key
)
4496 struct Lisp_Hash_Table
*h
;
4499 unsigned hash
= sxhash (key
, 0);
4500 xassert ((hash
& ~INTMASK
) == 0);
4505 /* Value is a hash code for KEY for use in hash table H which uses as
4506 user-defined function to compare keys. The hash code returned is
4507 guaranteed to fit in a Lisp integer. */
4510 hashfn_user_defined (h
, key
)
4511 struct Lisp_Hash_Table
*h
;
4514 Lisp_Object args
[2], hash
;
4516 args
[0] = h
->user_hash_function
;
4518 hash
= Ffuncall (2, args
);
4519 if (!INTEGERP (hash
))
4520 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
4521 return XUINT (hash
);
4525 /* Create and initialize a new hash table.
4527 TEST specifies the test the hash table will use to compare keys.
4528 It must be either one of the predefined tests `eq', `eql' or
4529 `equal' or a symbol denoting a user-defined test named TEST with
4530 test and hash functions USER_TEST and USER_HASH.
4532 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4534 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4535 new size when it becomes full is computed by adding REHASH_SIZE to
4536 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4537 table's new size is computed by multiplying its old size with
4540 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4541 be resized when the ratio of (number of entries in the table) /
4542 (table size) is >= REHASH_THRESHOLD.
4544 WEAK specifies the weakness of the table. If non-nil, it must be
4545 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4548 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4549 user_test
, user_hash
)
4550 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4551 Lisp_Object user_test
, user_hash
;
4553 struct Lisp_Hash_Table
*h
;
4555 int index_size
, i
, sz
;
4557 /* Preconditions. */
4558 xassert (SYMBOLP (test
));
4559 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4560 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4561 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4562 xassert (FLOATP (rehash_threshold
)
4563 && XFLOATINT (rehash_threshold
) > 0
4564 && XFLOATINT (rehash_threshold
) <= 1.0);
4566 if (XFASTINT (size
) == 0)
4567 size
= make_number (1);
4569 /* Allocate a table and initialize it. */
4570 h
= allocate_hash_table ();
4572 /* Initialize hash table slots. */
4573 sz
= XFASTINT (size
);
4576 if (EQ (test
, Qeql
))
4578 h
->cmpfn
= cmpfn_eql
;
4579 h
->hashfn
= hashfn_eql
;
4581 else if (EQ (test
, Qeq
))
4584 h
->hashfn
= hashfn_eq
;
4586 else if (EQ (test
, Qequal
))
4588 h
->cmpfn
= cmpfn_equal
;
4589 h
->hashfn
= hashfn_equal
;
4593 h
->user_cmp_function
= user_test
;
4594 h
->user_hash_function
= user_hash
;
4595 h
->cmpfn
= cmpfn_user_defined
;
4596 h
->hashfn
= hashfn_user_defined
;
4600 h
->rehash_threshold
= rehash_threshold
;
4601 h
->rehash_size
= rehash_size
;
4602 h
->count
= make_number (0);
4603 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4604 h
->hash
= Fmake_vector (size
, Qnil
);
4605 h
->next
= Fmake_vector (size
, Qnil
);
4606 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4607 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4608 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4610 /* Set up the free list. */
4611 for (i
= 0; i
< sz
- 1; ++i
)
4612 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4613 h
->next_free
= make_number (0);
4615 XSET_HASH_TABLE (table
, h
);
4616 xassert (HASH_TABLE_P (table
));
4617 xassert (XHASH_TABLE (table
) == h
);
4619 /* Maybe add this hash table to the list of all weak hash tables. */
4621 h
->next_weak
= Qnil
;
4624 h
->next_weak
= Vweak_hash_tables
;
4625 Vweak_hash_tables
= table
;
4632 /* Return a copy of hash table H1. Keys and values are not copied,
4633 only the table itself is. */
4636 copy_hash_table (h1
)
4637 struct Lisp_Hash_Table
*h1
;
4640 struct Lisp_Hash_Table
*h2
;
4641 struct Lisp_Vector
*next
;
4643 h2
= allocate_hash_table ();
4644 next
= h2
->vec_next
;
4645 bcopy (h1
, h2
, sizeof *h2
);
4646 h2
->vec_next
= next
;
4647 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4648 h2
->hash
= Fcopy_sequence (h1
->hash
);
4649 h2
->next
= Fcopy_sequence (h1
->next
);
4650 h2
->index
= Fcopy_sequence (h1
->index
);
4651 XSET_HASH_TABLE (table
, h2
);
4653 /* Maybe add this hash table to the list of all weak hash tables. */
4654 if (!NILP (h2
->weak
))
4656 h2
->next_weak
= Vweak_hash_tables
;
4657 Vweak_hash_tables
= table
;
4664 /* Resize hash table H if it's too full. If H cannot be resized
4665 because it's already too large, throw an error. */
4668 maybe_resize_hash_table (h
)
4669 struct Lisp_Hash_Table
*h
;
4671 if (NILP (h
->next_free
))
4673 int old_size
= HASH_TABLE_SIZE (h
);
4674 int i
, new_size
, index_size
;
4676 if (INTEGERP (h
->rehash_size
))
4677 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4679 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4680 new_size
= max (old_size
+ 1, new_size
);
4681 index_size
= next_almost_prime ((int)
4683 / XFLOATINT (h
->rehash_threshold
)));
4684 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4685 error ("Hash table too large to resize");
4687 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4688 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4689 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4690 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4692 /* Update the free list. Do it so that new entries are added at
4693 the end of the free list. This makes some operations like
4695 for (i
= old_size
; i
< new_size
- 1; ++i
)
4696 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4698 if (!NILP (h
->next_free
))
4700 Lisp_Object last
, next
;
4702 last
= h
->next_free
;
4703 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4707 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4710 XSETFASTINT (h
->next_free
, old_size
);
4713 for (i
= 0; i
< old_size
; ++i
)
4714 if (!NILP (HASH_HASH (h
, i
)))
4716 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4717 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4718 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4719 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4725 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4726 the hash code of KEY. Value is the index of the entry in H
4727 matching KEY, or -1 if not found. */
4730 hash_lookup (h
, key
, hash
)
4731 struct Lisp_Hash_Table
*h
;
4736 int start_of_bucket
;
4739 hash_code
= h
->hashfn (h
, key
);
4743 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4744 idx
= HASH_INDEX (h
, start_of_bucket
);
4746 /* We need not gcpro idx since it's either an integer or nil. */
4749 int i
= XFASTINT (idx
);
4750 if (EQ (key
, HASH_KEY (h
, i
))
4752 && h
->cmpfn (h
, key
, hash_code
,
4753 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4755 idx
= HASH_NEXT (h
, i
);
4758 return NILP (idx
) ? -1 : XFASTINT (idx
);
4762 /* Put an entry into hash table H that associates KEY with VALUE.
4763 HASH is a previously computed hash code of KEY.
4764 Value is the index of the entry in H matching KEY. */
4767 hash_put (h
, key
, value
, hash
)
4768 struct Lisp_Hash_Table
*h
;
4769 Lisp_Object key
, value
;
4772 int start_of_bucket
, i
;
4774 xassert ((hash
& ~INTMASK
) == 0);
4776 /* Increment count after resizing because resizing may fail. */
4777 maybe_resize_hash_table (h
);
4778 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4780 /* Store key/value in the key_and_value vector. */
4781 i
= XFASTINT (h
->next_free
);
4782 h
->next_free
= HASH_NEXT (h
, i
);
4783 HASH_KEY (h
, i
) = key
;
4784 HASH_VALUE (h
, i
) = value
;
4786 /* Remember its hash code. */
4787 HASH_HASH (h
, i
) = make_number (hash
);
4789 /* Add new entry to its collision chain. */
4790 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4791 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4792 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4797 /* Remove the entry matching KEY from hash table H, if there is one. */
4800 hash_remove (h
, key
)
4801 struct Lisp_Hash_Table
*h
;
4805 int start_of_bucket
;
4806 Lisp_Object idx
, prev
;
4808 hash_code
= h
->hashfn (h
, key
);
4809 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4810 idx
= HASH_INDEX (h
, start_of_bucket
);
4813 /* We need not gcpro idx, prev since they're either integers or nil. */
4816 int i
= XFASTINT (idx
);
4818 if (EQ (key
, HASH_KEY (h
, i
))
4820 && h
->cmpfn (h
, key
, hash_code
,
4821 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4823 /* Take entry out of collision chain. */
4825 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4827 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4829 /* Clear slots in key_and_value and add the slots to
4831 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4832 HASH_NEXT (h
, i
) = h
->next_free
;
4833 h
->next_free
= make_number (i
);
4834 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4835 xassert (XINT (h
->count
) >= 0);
4841 idx
= HASH_NEXT (h
, i
);
4847 /* Clear hash table H. */
4851 struct Lisp_Hash_Table
*h
;
4853 if (XFASTINT (h
->count
) > 0)
4855 int i
, size
= HASH_TABLE_SIZE (h
);
4857 for (i
= 0; i
< size
; ++i
)
4859 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4860 HASH_KEY (h
, i
) = Qnil
;
4861 HASH_VALUE (h
, i
) = Qnil
;
4862 HASH_HASH (h
, i
) = Qnil
;
4865 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4866 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4868 h
->next_free
= make_number (0);
4869 h
->count
= make_number (0);
4875 /************************************************************************
4877 ************************************************************************/
4879 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4880 entries from the table that don't survive the current GC.
4881 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4882 non-zero if anything was marked. */
4885 sweep_weak_table (h
, remove_entries_p
)
4886 struct Lisp_Hash_Table
*h
;
4887 int remove_entries_p
;
4889 int bucket
, n
, marked
;
4891 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4894 for (bucket
= 0; bucket
< n
; ++bucket
)
4896 Lisp_Object idx
, next
, prev
;
4898 /* Follow collision chain, removing entries that
4899 don't survive this garbage collection. */
4901 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4903 int i
= XFASTINT (idx
);
4904 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4905 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4908 if (EQ (h
->weak
, Qkey
))
4909 remove_p
= !key_known_to_survive_p
;
4910 else if (EQ (h
->weak
, Qvalue
))
4911 remove_p
= !value_known_to_survive_p
;
4912 else if (EQ (h
->weak
, Qkey_or_value
))
4913 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4914 else if (EQ (h
->weak
, Qkey_and_value
))
4915 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4919 next
= HASH_NEXT (h
, i
);
4921 if (remove_entries_p
)
4925 /* Take out of collision chain. */
4927 HASH_INDEX (h
, bucket
) = next
;
4929 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4931 /* Add to free list. */
4932 HASH_NEXT (h
, i
) = h
->next_free
;
4935 /* Clear key, value, and hash. */
4936 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4937 HASH_HASH (h
, i
) = Qnil
;
4939 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4950 /* Make sure key and value survive. */
4951 if (!key_known_to_survive_p
)
4953 mark_object (HASH_KEY (h
, i
));
4957 if (!value_known_to_survive_p
)
4959 mark_object (HASH_VALUE (h
, i
));
4970 /* Remove elements from weak hash tables that don't survive the
4971 current garbage collection. Remove weak tables that don't survive
4972 from Vweak_hash_tables. Called from gc_sweep. */
4975 sweep_weak_hash_tables ()
4977 Lisp_Object table
, used
, next
;
4978 struct Lisp_Hash_Table
*h
;
4981 /* Mark all keys and values that are in use. Keep on marking until
4982 there is no more change. This is necessary for cases like
4983 value-weak table A containing an entry X -> Y, where Y is used in a
4984 key-weak table B, Z -> Y. If B comes after A in the list of weak
4985 tables, X -> Y might be removed from A, although when looking at B
4986 one finds that it shouldn't. */
4990 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4992 h
= XHASH_TABLE (table
);
4993 if (h
->size
& ARRAY_MARK_FLAG
)
4994 marked
|= sweep_weak_table (h
, 0);
4999 /* Remove tables and entries that aren't used. */
5000 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
5002 h
= XHASH_TABLE (table
);
5003 next
= h
->next_weak
;
5005 if (h
->size
& ARRAY_MARK_FLAG
)
5007 /* TABLE is marked as used. Sweep its contents. */
5008 if (XFASTINT (h
->count
) > 0)
5009 sweep_weak_table (h
, 1);
5011 /* Add table to the list of used weak hash tables. */
5012 h
->next_weak
= used
;
5017 Vweak_hash_tables
= used
;
5022 /***********************************************************************
5023 Hash Code Computation
5024 ***********************************************************************/
5026 /* Maximum depth up to which to dive into Lisp structures. */
5028 #define SXHASH_MAX_DEPTH 3
5030 /* Maximum length up to which to take list and vector elements into
5033 #define SXHASH_MAX_LEN 7
5035 /* Combine two integers X and Y for hashing. */
5037 #define SXHASH_COMBINE(X, Y) \
5038 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5042 /* Return a hash for string PTR which has length LEN. The hash
5043 code returned is guaranteed to fit in a Lisp integer. */
5046 sxhash_string (ptr
, len
)
5050 unsigned char *p
= ptr
;
5051 unsigned char *end
= p
+ len
;
5060 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
5063 return hash
& INTMASK
;
5067 /* Return a hash for list LIST. DEPTH is the current depth in the
5068 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5071 sxhash_list (list
, depth
)
5078 if (depth
< SXHASH_MAX_DEPTH
)
5080 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5081 list
= XCDR (list
), ++i
)
5083 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5084 hash
= SXHASH_COMBINE (hash
, hash2
);
5089 unsigned hash2
= sxhash (list
, depth
+ 1);
5090 hash
= SXHASH_COMBINE (hash
, hash2
);
5097 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5098 the Lisp structure. */
5101 sxhash_vector (vec
, depth
)
5105 unsigned hash
= XVECTOR (vec
)->size
;
5108 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5109 for (i
= 0; i
< n
; ++i
)
5111 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5112 hash
= SXHASH_COMBINE (hash
, hash2
);
5119 /* Return a hash for bool-vector VECTOR. */
5122 sxhash_bool_vector (vec
)
5125 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5128 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5129 for (i
= 0; i
< n
; ++i
)
5130 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5136 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5137 structure. Value is an unsigned integer clipped to INTMASK. */
5146 if (depth
> SXHASH_MAX_DEPTH
)
5149 switch (XTYPE (obj
))
5160 obj
= SYMBOL_NAME (obj
);
5164 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5167 /* This can be everything from a vector to an overlay. */
5168 case Lisp_Vectorlike
:
5170 /* According to the CL HyperSpec, two arrays are equal only if
5171 they are `eq', except for strings and bit-vectors. In
5172 Emacs, this works differently. We have to compare element
5174 hash
= sxhash_vector (obj
, depth
);
5175 else if (BOOL_VECTOR_P (obj
))
5176 hash
= sxhash_bool_vector (obj
);
5178 /* Others are `equal' if they are `eq', so let's take their
5184 hash
= sxhash_list (obj
, depth
);
5189 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5190 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5191 for (hash
= 0; p
< e
; ++p
)
5192 hash
= SXHASH_COMBINE (hash
, *p
);
5200 return hash
& INTMASK
;
5205 /***********************************************************************
5207 ***********************************************************************/
5210 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5211 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5215 unsigned hash
= sxhash (obj
, 0);;
5216 return make_number (hash
);
5220 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5221 doc
: /* Create and return a new hash table.
5223 Arguments are specified as keyword/argument pairs. The following
5224 arguments are defined:
5226 :test TEST -- TEST must be a symbol that specifies how to compare
5227 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5228 `equal'. User-supplied test and hash functions can be specified via
5229 `define-hash-table-test'.
5231 :size SIZE -- A hint as to how many elements will be put in the table.
5234 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5235 fills up. If REHASH-SIZE is an integer, add that many space. If it
5236 is a float, it must be > 1.0, and the new size is computed by
5237 multiplying the old size with that factor. Default is 1.5.
5239 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5240 Resize the hash table when ratio of the number of entries in the
5241 table. Default is 0.8.
5243 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5244 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5245 returned is a weak table. Key/value pairs are removed from a weak
5246 hash table when there are no non-weak references pointing to their
5247 key, value, one of key or value, or both key and value, depending on
5248 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5251 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5256 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5257 Lisp_Object user_test
, user_hash
;
5261 /* The vector `used' is used to keep track of arguments that
5262 have been consumed. */
5263 used
= (char *) alloca (nargs
* sizeof *used
);
5264 bzero (used
, nargs
* sizeof *used
);
5266 /* See if there's a `:test TEST' among the arguments. */
5267 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5268 test
= i
< 0 ? Qeql
: args
[i
];
5269 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5271 /* See if it is a user-defined test. */
5274 prop
= Fget (test
, Qhash_table_test
);
5275 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5276 signal_error ("Invalid hash table test", test
);
5277 user_test
= XCAR (prop
);
5278 user_hash
= XCAR (XCDR (prop
));
5281 user_test
= user_hash
= Qnil
;
5283 /* See if there's a `:size SIZE' argument. */
5284 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5285 size
= i
< 0 ? Qnil
: args
[i
];
5287 size
= make_number (DEFAULT_HASH_SIZE
);
5288 else if (!INTEGERP (size
) || XINT (size
) < 0)
5289 signal_error ("Invalid hash table size", size
);
5291 /* Look for `:rehash-size SIZE'. */
5292 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5293 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5294 if (!NUMBERP (rehash_size
)
5295 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5296 || XFLOATINT (rehash_size
) <= 1.0)
5297 signal_error ("Invalid hash table rehash size", rehash_size
);
5299 /* Look for `:rehash-threshold THRESHOLD'. */
5300 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5301 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5302 if (!FLOATP (rehash_threshold
)
5303 || XFLOATINT (rehash_threshold
) <= 0.0
5304 || XFLOATINT (rehash_threshold
) > 1.0)
5305 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
5307 /* Look for `:weakness WEAK'. */
5308 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5309 weak
= i
< 0 ? Qnil
: args
[i
];
5311 weak
= Qkey_and_value
;
5314 && !EQ (weak
, Qvalue
)
5315 && !EQ (weak
, Qkey_or_value
)
5316 && !EQ (weak
, Qkey_and_value
))
5317 signal_error ("Invalid hash table weakness", weak
);
5319 /* Now, all args should have been used up, or there's a problem. */
5320 for (i
= 0; i
< nargs
; ++i
)
5322 signal_error ("Invalid argument list", args
[i
]);
5324 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5325 user_test
, user_hash
);
5329 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5330 doc
: /* Return a copy of hash table TABLE. */)
5334 return copy_hash_table (check_hash_table (table
));
5338 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5339 doc
: /* Return the number of elements in TABLE. */)
5343 return check_hash_table (table
)->count
;
5347 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5348 Shash_table_rehash_size
, 1, 1, 0,
5349 doc
: /* Return the current rehash size of TABLE. */)
5353 return check_hash_table (table
)->rehash_size
;
5357 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5358 Shash_table_rehash_threshold
, 1, 1, 0,
5359 doc
: /* Return the current rehash threshold of TABLE. */)
5363 return check_hash_table (table
)->rehash_threshold
;
5367 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5368 doc
: /* Return the size of TABLE.
5369 The size can be used as an argument to `make-hash-table' to create
5370 a hash table than can hold as many elements of TABLE holds
5371 without need for resizing. */)
5375 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5376 return make_number (HASH_TABLE_SIZE (h
));
5380 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5381 doc
: /* Return the test TABLE uses. */)
5385 return check_hash_table (table
)->test
;
5389 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5391 doc
: /* Return the weakness of TABLE. */)
5395 return check_hash_table (table
)->weak
;
5399 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5400 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5404 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5408 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5409 doc
: /* Clear hash table TABLE. */)
5413 hash_clear (check_hash_table (table
));
5418 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5419 doc
: /* Look up KEY in TABLE and return its associated value.
5420 If KEY is not found, return DFLT which defaults to nil. */)
5422 Lisp_Object key
, table
, dflt
;
5424 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5425 int i
= hash_lookup (h
, key
, NULL
);
5426 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5430 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5431 doc
: /* Associate KEY with VALUE in hash table TABLE.
5432 If KEY is already present in table, replace its current value with
5435 Lisp_Object key
, value
, table
;
5437 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5441 i
= hash_lookup (h
, key
, &hash
);
5443 HASH_VALUE (h
, i
) = value
;
5445 hash_put (h
, key
, value
, hash
);
5451 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5452 doc
: /* Remove KEY from TABLE. */)
5454 Lisp_Object key
, table
;
5456 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5457 hash_remove (h
, key
);
5462 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5463 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5464 FUNCTION is called with two arguments, KEY and VALUE. */)
5466 Lisp_Object function
, table
;
5468 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5469 Lisp_Object args
[3];
5472 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5473 if (!NILP (HASH_HASH (h
, i
)))
5476 args
[1] = HASH_KEY (h
, i
);
5477 args
[2] = HASH_VALUE (h
, i
);
5485 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5486 Sdefine_hash_table_test
, 3, 3, 0,
5487 doc
: /* Define a new hash table test with name NAME, a symbol.
5489 In hash tables created with NAME specified as test, use TEST to
5490 compare keys, and HASH for computing hash codes of keys.
5492 TEST must be a function taking two arguments and returning non-nil if
5493 both arguments are the same. HASH must be a function taking one
5494 argument and return an integer that is the hash code of the argument.
5495 Hash code computation should use the whole value range of integers,
5496 including negative integers. */)
5498 Lisp_Object name
, test
, hash
;
5500 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5505 /************************************************************************
5507 ************************************************************************/
5512 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5513 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5515 A message digest is a cryptographic checksum of a document, and the
5516 algorithm to calculate it is defined in RFC 1321.
5518 The two optional arguments START and END are character positions
5519 specifying for which part of OBJECT the message digest should be
5520 computed. If nil or omitted, the digest is computed for the whole
5523 The MD5 message digest is computed from the result of encoding the
5524 text in a coding system, not directly from the internal Emacs form of
5525 the text. The optional fourth argument CODING-SYSTEM specifies which
5526 coding system to encode the text with. It should be the same coding
5527 system that you used or will use when actually writing the text into a
5530 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5531 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5532 system would be chosen by default for writing this text into a file.
5534 If OBJECT is a string, the most preferred coding system (see the
5535 command `prefer-coding-system') is used.
5537 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5538 guesswork fails. Normally, an error is signaled in such case. */)
5539 (object
, start
, end
, coding_system
, noerror
)
5540 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5542 unsigned char digest
[16];
5543 unsigned char value
[33];
5547 int start_char
= 0, end_char
= 0;
5548 int start_byte
= 0, end_byte
= 0;
5550 register struct buffer
*bp
;
5553 if (STRINGP (object
))
5555 if (NILP (coding_system
))
5557 /* Decide the coding-system to encode the data with. */
5559 if (STRING_MULTIBYTE (object
))
5560 /* use default, we can't guess correct value */
5561 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5563 coding_system
= Qraw_text
;
5566 if (NILP (Fcoding_system_p (coding_system
)))
5568 /* Invalid coding system. */
5570 if (!NILP (noerror
))
5571 coding_system
= Qraw_text
;
5573 xsignal1 (Qcoding_system_error
, coding_system
);
5576 if (STRING_MULTIBYTE (object
))
5577 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5579 size
= SCHARS (object
);
5580 size_byte
= SBYTES (object
);
5584 CHECK_NUMBER (start
);
5586 start_char
= XINT (start
);
5591 start_byte
= string_char_to_byte (object
, start_char
);
5597 end_byte
= size_byte
;
5603 end_char
= XINT (end
);
5608 end_byte
= string_char_to_byte (object
, end_char
);
5611 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5612 args_out_of_range_3 (object
, make_number (start_char
),
5613 make_number (end_char
));
5617 struct buffer
*prev
= current_buffer
;
5619 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5621 CHECK_BUFFER (object
);
5623 bp
= XBUFFER (object
);
5624 if (bp
!= current_buffer
)
5625 set_buffer_internal (bp
);
5631 CHECK_NUMBER_COERCE_MARKER (start
);
5639 CHECK_NUMBER_COERCE_MARKER (end
);
5644 temp
= b
, b
= e
, e
= temp
;
5646 if (!(BEGV
<= b
&& e
<= ZV
))
5647 args_out_of_range (start
, end
);
5649 if (NILP (coding_system
))
5651 /* Decide the coding-system to encode the data with.
5652 See fileio.c:Fwrite-region */
5654 if (!NILP (Vcoding_system_for_write
))
5655 coding_system
= Vcoding_system_for_write
;
5658 int force_raw_text
= 0;
5660 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5661 if (NILP (coding_system
)
5662 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5664 coding_system
= Qnil
;
5665 if (NILP (current_buffer
->enable_multibyte_characters
))
5669 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5671 /* Check file-coding-system-alist. */
5672 Lisp_Object args
[4], val
;
5674 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5675 args
[3] = Fbuffer_file_name(object
);
5676 val
= Ffind_operation_coding_system (4, args
);
5677 if (CONSP (val
) && !NILP (XCDR (val
)))
5678 coding_system
= XCDR (val
);
5681 if (NILP (coding_system
)
5682 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5684 /* If we still have not decided a coding system, use the
5685 default value of buffer-file-coding-system. */
5686 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5690 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5691 /* Confirm that VAL can surely encode the current region. */
5692 coding_system
= call4 (Vselect_safe_coding_system_function
,
5693 make_number (b
), make_number (e
),
5694 coding_system
, Qnil
);
5697 coding_system
= Qraw_text
;
5700 if (NILP (Fcoding_system_p (coding_system
)))
5702 /* Invalid coding system. */
5704 if (!NILP (noerror
))
5705 coding_system
= Qraw_text
;
5707 xsignal1 (Qcoding_system_error
, coding_system
);
5711 object
= make_buffer_string (b
, e
, 0);
5712 if (prev
!= current_buffer
)
5713 set_buffer_internal (prev
);
5714 /* Discard the unwind protect for recovering the current
5718 if (STRING_MULTIBYTE (object
))
5719 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5722 md5_buffer (SDATA (object
) + start_byte
,
5723 SBYTES (object
) - (size_byte
- end_byte
),
5726 for (i
= 0; i
< 16; i
++)
5727 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5730 return make_string (value
, 32);
5737 /* Hash table stuff. */
5738 Qhash_table_p
= intern ("hash-table-p");
5739 staticpro (&Qhash_table_p
);
5740 Qeq
= intern ("eq");
5742 Qeql
= intern ("eql");
5744 Qequal
= intern ("equal");
5745 staticpro (&Qequal
);
5746 QCtest
= intern (":test");
5747 staticpro (&QCtest
);
5748 QCsize
= intern (":size");
5749 staticpro (&QCsize
);
5750 QCrehash_size
= intern (":rehash-size");
5751 staticpro (&QCrehash_size
);
5752 QCrehash_threshold
= intern (":rehash-threshold");
5753 staticpro (&QCrehash_threshold
);
5754 QCweakness
= intern (":weakness");
5755 staticpro (&QCweakness
);
5756 Qkey
= intern ("key");
5758 Qvalue
= intern ("value");
5759 staticpro (&Qvalue
);
5760 Qhash_table_test
= intern ("hash-table-test");
5761 staticpro (&Qhash_table_test
);
5762 Qkey_or_value
= intern ("key-or-value");
5763 staticpro (&Qkey_or_value
);
5764 Qkey_and_value
= intern ("key-and-value");
5765 staticpro (&Qkey_and_value
);
5768 defsubr (&Smake_hash_table
);
5769 defsubr (&Scopy_hash_table
);
5770 defsubr (&Shash_table_count
);
5771 defsubr (&Shash_table_rehash_size
);
5772 defsubr (&Shash_table_rehash_threshold
);
5773 defsubr (&Shash_table_size
);
5774 defsubr (&Shash_table_test
);
5775 defsubr (&Shash_table_weakness
);
5776 defsubr (&Shash_table_p
);
5777 defsubr (&Sclrhash
);
5778 defsubr (&Sgethash
);
5779 defsubr (&Sputhash
);
5780 defsubr (&Sremhash
);
5781 defsubr (&Smaphash
);
5782 defsubr (&Sdefine_hash_table_test
);
5784 Qstring_lessp
= intern ("string-lessp");
5785 staticpro (&Qstring_lessp
);
5786 Qprovide
= intern ("provide");
5787 staticpro (&Qprovide
);
5788 Qrequire
= intern ("require");
5789 staticpro (&Qrequire
);
5790 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5791 staticpro (&Qyes_or_no_p_history
);
5792 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5793 staticpro (&Qcursor_in_echo_area
);
5794 Qwidget_type
= intern ("widget-type");
5795 staticpro (&Qwidget_type
);
5797 staticpro (&string_char_byte_cache_string
);
5798 string_char_byte_cache_string
= Qnil
;
5800 require_nesting_list
= Qnil
;
5801 staticpro (&require_nesting_list
);
5803 Fset (Qyes_or_no_p_history
, Qnil
);
5805 DEFVAR_LISP ("features", &Vfeatures
,
5806 doc
: /* A list of symbols which are the features of the executing Emacs.
5807 Used by `featurep' and `require', and altered by `provide'. */);
5808 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5809 Qsubfeatures
= intern ("subfeatures");
5810 staticpro (&Qsubfeatures
);
5812 #ifdef HAVE_LANGINFO_CODESET
5813 Qcodeset
= intern ("codeset");
5814 staticpro (&Qcodeset
);
5815 Qdays
= intern ("days");
5817 Qmonths
= intern ("months");
5818 staticpro (&Qmonths
);
5819 Qpaper
= intern ("paper");
5820 staticpro (&Qpaper
);
5821 #endif /* HAVE_LANGINFO_CODESET */
5823 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5824 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5825 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5826 invoked by mouse clicks and mouse menu items. */);
5829 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5830 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5831 This applies to commands from menus and tool bar buttons. The value of
5832 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5833 used if both `use-dialog-box' and this variable are non-nil. */);
5834 use_file_dialog
= 1;
5836 defsubr (&Sidentity
);
5839 defsubr (&Ssafe_length
);
5840 defsubr (&Sstring_bytes
);
5841 defsubr (&Sstring_equal
);
5842 defsubr (&Scompare_strings
);
5843 defsubr (&Sstring_lessp
);
5846 defsubr (&Svconcat
);
5847 defsubr (&Scopy_sequence
);
5848 defsubr (&Sstring_make_multibyte
);
5849 defsubr (&Sstring_make_unibyte
);
5850 defsubr (&Sstring_as_multibyte
);
5851 defsubr (&Sstring_as_unibyte
);
5852 defsubr (&Sstring_to_multibyte
);
5853 defsubr (&Scopy_alist
);
5854 defsubr (&Ssubstring
);
5855 defsubr (&Ssubstring_no_properties
);
5868 defsubr (&Snreverse
);
5869 defsubr (&Sreverse
);
5871 defsubr (&Splist_get
);
5873 defsubr (&Splist_put
);
5875 defsubr (&Slax_plist_get
);
5876 defsubr (&Slax_plist_put
);
5879 defsubr (&Sequal_including_properties
);
5880 defsubr (&Sfillarray
);
5881 defsubr (&Sclear_string
);
5882 defsubr (&Schar_table_subtype
);
5883 defsubr (&Schar_table_parent
);
5884 defsubr (&Sset_char_table_parent
);
5885 defsubr (&Schar_table_extra_slot
);
5886 defsubr (&Sset_char_table_extra_slot
);
5887 defsubr (&Schar_table_range
);
5888 defsubr (&Sset_char_table_range
);
5889 defsubr (&Sset_char_table_default
);
5890 defsubr (&Soptimize_char_table
);
5891 defsubr (&Smap_char_table
);
5895 defsubr (&Smapconcat
);
5896 defsubr (&Sy_or_n_p
);
5897 defsubr (&Syes_or_no_p
);
5898 defsubr (&Sload_average
);
5899 defsubr (&Sfeaturep
);
5900 defsubr (&Srequire
);
5901 defsubr (&Sprovide
);
5902 defsubr (&Splist_member
);
5903 defsubr (&Swidget_put
);
5904 defsubr (&Swidget_get
);
5905 defsubr (&Swidget_apply
);
5906 defsubr (&Sbase64_encode_region
);
5907 defsubr (&Sbase64_decode_region
);
5908 defsubr (&Sbase64_encode_string
);
5909 defsubr (&Sbase64_decode_string
);
5911 defsubr (&Slocale_info
);
5918 Vweak_hash_tables
= Qnil
;
5921 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5922 (do not change this comment) */