Doc fixes.
[emacs.git] / src / fns.c
blobe31d065c017f07415dfafc7a1cc3b58eb18f9654
1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
23 #include <config.h>
25 #ifdef HAVE_UNISTD_H
26 #include <unistd.h>
27 #endif
28 #include <time.h>
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
32 #undef vector
33 #define vector *****
35 #include "lisp.h"
36 #include "commands.h"
37 #include "charset.h"
39 #include "buffer.h"
40 #include "keyboard.h"
41 #include "intervals.h"
42 #include "frame.h"
43 #include "window.h"
44 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
45 #include "xterm.h"
46 #endif
48 #ifndef NULL
49 #define NULL (void *)0
50 #endif
52 #ifndef min
53 #define min(a, b) ((a) < (b) ? (a) : (b))
54 #define max(a, b) ((a) > (b) ? (a) : (b))
55 #endif
57 /* Nonzero enables use of dialog boxes for questions
58 asked by mouse commands. */
59 int use_dialog_box;
61 extern int minibuffer_auto_raise;
62 extern Lisp_Object minibuf_window;
64 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
65 Lisp_Object Qyes_or_no_p_history;
66 Lisp_Object Qcursor_in_echo_area;
67 Lisp_Object Qwidget_type;
69 extern Lisp_Object Qinput_method_function;
71 static int internal_equal ();
73 extern long get_random ();
74 extern void seed_random ();
76 #ifndef HAVE_UNISTD_H
77 extern long time ();
78 #endif
80 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
81 "Return the argument unchanged.")
82 (arg)
83 Lisp_Object arg;
85 return arg;
88 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
89 "Return a pseudo-random number.\n\
90 All integers representable in Lisp are equally likely.\n\
91 On most systems, this is 28 bits' worth.\n\
92 With positive integer argument N, return random number in interval [0,N).\n\
93 With argument t, set the random number seed from the current time and pid.")
94 (n)
95 Lisp_Object n;
97 EMACS_INT val;
98 Lisp_Object lispy_val;
99 unsigned long denominator;
101 if (EQ (n, Qt))
102 seed_random (getpid () + time (NULL));
103 if (NATNUMP (n) && XFASTINT (n) != 0)
105 /* Try to take our random number from the higher bits of VAL,
106 not the lower, since (says Gentzel) the low bits of `random'
107 are less random than the higher ones. We do this by using the
108 quotient rather than the remainder. At the high end of the RNG
109 it's possible to get a quotient larger than n; discarding
110 these values eliminates the bias that would otherwise appear
111 when using a large n. */
112 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
114 val = get_random () / denominator;
115 while (val >= XFASTINT (n));
117 else
118 val = get_random ();
119 XSETINT (lispy_val, val);
120 return lispy_val;
123 /* Random data-structure functions */
125 DEFUN ("length", Flength, Slength, 1, 1, 0,
126 "Return the length of vector, list or string SEQUENCE.\n\
127 A byte-code function object is also allowed.\n\
128 If the string contains multibyte characters, this is not the necessarily\n\
129 the number of bytes in the string; it is the number of characters.\n\
130 To get the number of bytes, use `string-bytes'")
131 (sequence)
132 register Lisp_Object sequence;
134 register Lisp_Object val;
135 register int i;
137 retry:
138 if (STRINGP (sequence))
139 XSETFASTINT (val, XSTRING (sequence)->size);
140 else if (VECTORP (sequence))
141 XSETFASTINT (val, XVECTOR (sequence)->size);
142 else if (CHAR_TABLE_P (sequence))
143 XSETFASTINT (val, MAX_CHAR);
144 else if (BOOL_VECTOR_P (sequence))
145 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
146 else if (COMPILEDP (sequence))
147 XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
148 else if (CONSP (sequence))
150 i = 0;
151 while (CONSP (sequence))
153 sequence = XCDR (sequence);
154 ++i;
156 if (!CONSP (sequence))
157 break;
159 sequence = XCDR (sequence);
160 ++i;
161 QUIT;
164 if (!NILP (sequence))
165 wrong_type_argument (Qlistp, sequence);
167 val = make_number (i);
169 else if (NILP (sequence))
170 XSETFASTINT (val, 0);
171 else
173 sequence = wrong_type_argument (Qsequencep, sequence);
174 goto retry;
176 return val;
179 /* This does not check for quits. That is safe
180 since it must terminate. */
182 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
183 "Return the length of a list, but avoid error or infinite loop.\n\
184 This function never gets an error. If LIST is not really a list,\n\
185 it returns 0. If LIST is circular, it returns a finite value\n\
186 which is at least the number of distinct elements.")
187 (list)
188 Lisp_Object list;
190 Lisp_Object tail, halftail, length;
191 int len = 0;
193 /* halftail is used to detect circular lists. */
194 halftail = list;
195 for (tail = list; CONSP (tail); tail = XCDR (tail))
197 if (EQ (tail, halftail) && len != 0)
198 break;
199 len++;
200 if ((len & 1) == 0)
201 halftail = XCDR (halftail);
204 XSETINT (length, len);
205 return length;
208 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
209 "Return the number of bytes in STRING.\n\
210 If STRING is a multibyte string, this is greater than the length of STRING.")
211 (string)
212 Lisp_Object string;
214 CHECK_STRING (string, 1);
215 return make_number (STRING_BYTES (XSTRING (string)));
218 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
219 "Return t if two strings have identical contents.\n\
220 Case is significant, but text properties are ignored.\n\
221 Symbols are also allowed; their print names are used instead.")
222 (s1, s2)
223 register Lisp_Object s1, s2;
225 if (SYMBOLP (s1))
226 XSETSTRING (s1, XSYMBOL (s1)->name);
227 if (SYMBOLP (s2))
228 XSETSTRING (s2, XSYMBOL (s2)->name);
229 CHECK_STRING (s1, 0);
230 CHECK_STRING (s2, 1);
232 if (XSTRING (s1)->size != XSTRING (s2)->size
233 || STRING_BYTES (XSTRING (s1)) != STRING_BYTES (XSTRING (s2))
234 || bcmp (XSTRING (s1)->data, XSTRING (s2)->data, STRING_BYTES (XSTRING (s1))))
235 return Qnil;
236 return Qt;
239 DEFUN ("compare-strings", Fcompare_strings,
240 Scompare_strings, 6, 7, 0,
241 "Compare the contents of two strings, converting to multibyte if needed.\n\
242 In string STR1, skip the first START1 characters and stop at END1.\n\
243 In string STR2, skip the first START2 characters and stop at END2.\n\
244 END1 and END2 default to the full lengths of the respective strings.\n\
246 Case is significant in this comparison if IGNORE-CASE is nil.\n\
247 Unibyte strings are converted to multibyte for comparison.\n\
249 The value is t if the strings (or specified portions) match.\n\
250 If string STR1 is less, the value is a negative number N;\n\
251 - 1 - N is the number of characters that match at the beginning.\n\
252 If string STR1 is greater, the value is a positive number N;\n\
253 N - 1 is the number of characters that match at the beginning.")
254 (str1, start1, end1, str2, start2, end2, ignore_case)
255 Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
257 register int end1_char, end2_char;
258 register int i1, i1_byte, i2, i2_byte;
260 CHECK_STRING (str1, 0);
261 CHECK_STRING (str2, 1);
262 if (NILP (start1))
263 start1 = make_number (0);
264 if (NILP (start2))
265 start2 = make_number (0);
266 CHECK_NATNUM (start1, 2);
267 CHECK_NATNUM (start2, 3);
268 if (! NILP (end1))
269 CHECK_NATNUM (end1, 4);
270 if (! NILP (end2))
271 CHECK_NATNUM (end2, 4);
273 i1 = XINT (start1);
274 i2 = XINT (start2);
276 i1_byte = string_char_to_byte (str1, i1);
277 i2_byte = string_char_to_byte (str2, i2);
279 end1_char = XSTRING (str1)->size;
280 if (! NILP (end1) && end1_char > XINT (end1))
281 end1_char = XINT (end1);
283 end2_char = XSTRING (str2)->size;
284 if (! NILP (end2) && end2_char > XINT (end2))
285 end2_char = XINT (end2);
287 while (i1 < end1_char && i2 < end2_char)
289 /* When we find a mismatch, we must compare the
290 characters, not just the bytes. */
291 int c1, c2;
293 if (STRING_MULTIBYTE (str1))
294 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
295 else
297 c1 = XSTRING (str1)->data[i1++];
298 c1 = unibyte_char_to_multibyte (c1);
301 if (STRING_MULTIBYTE (str2))
302 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
303 else
305 c2 = XSTRING (str2)->data[i2++];
306 c2 = unibyte_char_to_multibyte (c2);
309 if (c1 == c2)
310 continue;
312 if (! NILP (ignore_case))
314 Lisp_Object tem;
316 tem = Fupcase (make_number (c1));
317 c1 = XINT (tem);
318 tem = Fupcase (make_number (c2));
319 c2 = XINT (tem);
322 if (c1 == c2)
323 continue;
325 /* Note that I1 has already been incremented
326 past the character that we are comparing;
327 hence we don't add or subtract 1 here. */
328 if (c1 < c2)
329 return make_number (- i1);
330 else
331 return make_number (i1);
334 if (i1 < end1_char)
335 return make_number (i1 - XINT (start1) + 1);
336 if (i2 < end2_char)
337 return make_number (- i1 + XINT (start1) - 1);
339 return Qt;
342 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
343 "Return t if first arg string is less than second in lexicographic order.\n\
344 Case is significant.\n\
345 Symbols are also allowed; their print names are used instead.")
346 (s1, s2)
347 register Lisp_Object s1, s2;
349 register int end;
350 register int i1, i1_byte, i2, i2_byte;
352 if (SYMBOLP (s1))
353 XSETSTRING (s1, XSYMBOL (s1)->name);
354 if (SYMBOLP (s2))
355 XSETSTRING (s2, XSYMBOL (s2)->name);
356 CHECK_STRING (s1, 0);
357 CHECK_STRING (s2, 1);
359 i1 = i1_byte = i2 = i2_byte = 0;
361 end = XSTRING (s1)->size;
362 if (end > XSTRING (s2)->size)
363 end = XSTRING (s2)->size;
365 while (i1 < end)
367 /* When we find a mismatch, we must compare the
368 characters, not just the bytes. */
369 int c1, c2;
371 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
372 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
374 if (c1 != c2)
375 return c1 < c2 ? Qt : Qnil;
377 return i1 < XSTRING (s2)->size ? Qt : Qnil;
380 static Lisp_Object concat ();
382 /* ARGSUSED */
383 Lisp_Object
384 concat2 (s1, s2)
385 Lisp_Object s1, s2;
387 #ifdef NO_ARG_ARRAY
388 Lisp_Object args[2];
389 args[0] = s1;
390 args[1] = s2;
391 return concat (2, args, Lisp_String, 0);
392 #else
393 return concat (2, &s1, Lisp_String, 0);
394 #endif /* NO_ARG_ARRAY */
397 /* ARGSUSED */
398 Lisp_Object
399 concat3 (s1, s2, s3)
400 Lisp_Object s1, s2, s3;
402 #ifdef NO_ARG_ARRAY
403 Lisp_Object args[3];
404 args[0] = s1;
405 args[1] = s2;
406 args[2] = s3;
407 return concat (3, args, Lisp_String, 0);
408 #else
409 return concat (3, &s1, Lisp_String, 0);
410 #endif /* NO_ARG_ARRAY */
413 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
414 "Concatenate all the arguments and make the result a list.\n\
415 The result is a list whose elements are the elements of all the arguments.\n\
416 Each argument may be a list, vector or string.\n\
417 The last argument is not copied, just used as the tail of the new list.")
418 (nargs, args)
419 int nargs;
420 Lisp_Object *args;
422 return concat (nargs, args, Lisp_Cons, 1);
425 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
426 "Concatenate all the arguments and make the result a string.\n\
427 The result is a string whose elements are the elements of all the arguments.\n\
428 Each argument may be a string or a list or vector of characters (integers).")
429 (nargs, args)
430 int nargs;
431 Lisp_Object *args;
433 return concat (nargs, args, Lisp_String, 0);
436 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
437 "Concatenate all the arguments and make the result a vector.\n\
438 The result is a vector whose elements are the elements of all the arguments.\n\
439 Each argument may be a list, vector or string.")
440 (nargs, args)
441 int nargs;
442 Lisp_Object *args;
444 return concat (nargs, args, Lisp_Vectorlike, 0);
447 /* Retrun a copy of a sub char table ARG. The elements except for a
448 nested sub char table are not copied. */
449 static Lisp_Object
450 copy_sub_char_table (arg)
451 Lisp_Object arg;
453 Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
454 int i;
456 /* Copy all the contents. */
457 bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
458 SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
459 /* Recursively copy any sub char-tables in the ordinary slots. */
460 for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
461 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
462 XCHAR_TABLE (copy)->contents[i]
463 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
465 return copy;
469 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
470 "Return a copy of a list, vector or string.\n\
471 The elements of a list or vector are not copied; they are shared\n\
472 with the original.")
473 (arg)
474 Lisp_Object arg;
476 if (NILP (arg)) return arg;
478 if (CHAR_TABLE_P (arg))
480 int i;
481 Lisp_Object copy;
483 copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
484 /* Copy all the slots, including the extra ones. */
485 bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
486 ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
487 * sizeof (Lisp_Object)));
489 /* Recursively copy any sub char tables in the ordinary slots
490 for multibyte characters. */
491 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
492 i < CHAR_TABLE_ORDINARY_SLOTS; i++)
493 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
494 XCHAR_TABLE (copy)->contents[i]
495 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
497 return copy;
500 if (BOOL_VECTOR_P (arg))
502 Lisp_Object val;
503 int size_in_chars
504 = (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
506 val = Fmake_bool_vector (Flength (arg), Qnil);
507 bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
508 size_in_chars);
509 return val;
512 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
513 arg = wrong_type_argument (Qsequencep, arg);
514 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
517 /* In string STR of length LEN, see if bytes before STR[I] combine
518 with bytes after STR[I] to form a single character. If so, return
519 the number of bytes after STR[I] which combine in this way.
520 Otherwize, return 0. */
522 static int
523 count_combining (str, len, i)
524 unsigned char *str;
525 int len, i;
527 int j = i - 1, bytes;
529 if (i == 0 || i == len || CHAR_HEAD_P (str[i]))
530 return 0;
531 while (j >= 0 && !CHAR_HEAD_P (str[j])) j--;
532 if (j < 0 || ! BASE_LEADING_CODE_P (str[j]))
533 return 0;
534 PARSE_MULTIBYTE_SEQ (str + j, len - j, bytes);
535 return (bytes <= i - j ? 0 : bytes - (i - j));
538 /* This structure holds information of an argument of `concat' that is
539 a string and has text properties to be copied. */
540 struct textprop_rec
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) */
547 static Lisp_Object
548 concat (nargs, args, target_type, last_special)
549 int nargs;
550 Lisp_Object *args;
551 enum Lisp_Type target_type;
552 int last_special;
554 Lisp_Object val;
555 register Lisp_Object tail;
556 register Lisp_Object this;
557 int toindex;
558 int toindex_byte = 0;
559 register int result_len;
560 register int result_len_byte;
561 register int argnum;
562 Lisp_Object last_tail;
563 Lisp_Object prev;
564 int some_multibyte;
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;
574 tail = Qnil;
576 /* In append, the last arg isn't treated like the others */
577 if (last_special && nargs > 0)
579 nargs--;
580 last_tail = args[nargs];
582 else
583 last_tail = Qnil;
585 /* Canonicalize each argument. */
586 for (argnum = 0; argnum < nargs; argnum++)
588 this = args[argnum];
589 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
590 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
592 args[argnum] = wrong_type_argument (Qsequencep, this);
596 /* Compute total length in chars of arguments in RESULT_LEN.
597 If desired output is a string, also compute length in bytes
598 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
599 whether the result should be a multibyte string. */
600 result_len_byte = 0;
601 result_len = 0;
602 some_multibyte = 0;
603 for (argnum = 0; argnum < nargs; argnum++)
605 int len;
606 this = args[argnum];
607 len = XFASTINT (Flength (this));
608 if (target_type == Lisp_String)
610 /* We must count the number of bytes needed in the string
611 as well as the number of characters. */
612 int i;
613 Lisp_Object ch;
614 int this_len_byte;
616 if (VECTORP (this))
617 for (i = 0; i < len; i++)
619 ch = XVECTOR (this)->contents[i];
620 if (! INTEGERP (ch))
621 wrong_type_argument (Qintegerp, ch);
622 this_len_byte = CHAR_BYTES (XINT (ch));
623 result_len_byte += this_len_byte;
624 if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
625 some_multibyte = 1;
627 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
628 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
629 else if (CONSP (this))
630 for (; CONSP (this); this = XCDR (this))
632 ch = XCAR (this);
633 if (! INTEGERP (ch))
634 wrong_type_argument (Qintegerp, ch);
635 this_len_byte = CHAR_BYTES (XINT (ch));
636 result_len_byte += this_len_byte;
637 if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
638 some_multibyte = 1;
640 else if (STRINGP (this))
642 if (STRING_MULTIBYTE (this))
644 some_multibyte = 1;
645 result_len_byte += STRING_BYTES (XSTRING (this));
647 else
648 result_len_byte += count_size_as_multibyte (XSTRING (this)->data,
649 XSTRING (this)->size);
653 result_len += len;
656 if (! some_multibyte)
657 result_len_byte = result_len;
659 /* Create the output object. */
660 if (target_type == Lisp_Cons)
661 val = Fmake_list (make_number (result_len), Qnil);
662 else if (target_type == Lisp_Vectorlike)
663 val = Fmake_vector (make_number (result_len), Qnil);
664 else if (some_multibyte)
665 val = make_uninit_multibyte_string (result_len, result_len_byte);
666 else
667 val = make_uninit_string (result_len);
669 /* In `append', if all but last arg are nil, return last arg. */
670 if (target_type == Lisp_Cons && EQ (val, Qnil))
671 return last_tail;
673 /* Copy the contents of the args into the result. */
674 if (CONSP (val))
675 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
676 else
677 toindex = 0, toindex_byte = 0;
679 prev = Qnil;
680 if (STRINGP (val))
681 textprops
682 = (struct textprop_rec *) alloca (sizeof (struct textprop_rec) * nargs);
684 for (argnum = 0; argnum < nargs; argnum++)
686 Lisp_Object thislen;
687 int thisleni = 0;
688 register unsigned int thisindex = 0;
689 register unsigned int thisindex_byte = 0;
691 this = args[argnum];
692 if (!CONSP (this))
693 thislen = Flength (this), thisleni = XINT (thislen);
695 /* Between strings of the same kind, copy fast. */
696 if (STRINGP (this) && STRINGP (val)
697 && STRING_MULTIBYTE (this) == some_multibyte)
699 int thislen_byte = STRING_BYTES (XSTRING (this));
700 int combined;
702 bcopy (XSTRING (this)->data, XSTRING (val)->data + toindex_byte,
703 STRING_BYTES (XSTRING (this)));
704 combined = (some_multibyte && toindex_byte > 0
705 ? count_combining (XSTRING (val)->data,
706 toindex_byte + thislen_byte,
707 toindex_byte)
708 : 0);
709 if (! NULL_INTERVAL_P (XSTRING (this)->intervals))
711 textprops[num_textprops].argnum = argnum;
712 /* We ignore text properties on characters being combined. */
713 textprops[num_textprops].from = combined;
714 textprops[num_textprops++].to = toindex;
716 toindex_byte += thislen_byte;
717 toindex += thisleni - combined;
718 XSTRING (val)->size -= combined;
720 /* Copy a single-byte string to a multibyte string. */
721 else if (STRINGP (this) && STRINGP (val))
723 if (! NULL_INTERVAL_P (XSTRING (this)->intervals))
725 textprops[num_textprops].argnum = argnum;
726 textprops[num_textprops].from = 0;
727 textprops[num_textprops++].to = toindex;
729 toindex_byte += copy_text (XSTRING (this)->data,
730 XSTRING (val)->data + toindex_byte,
731 XSTRING (this)->size, 0, 1);
732 toindex += thisleni;
734 else
735 /* Copy element by element. */
736 while (1)
738 register Lisp_Object elt;
740 /* Fetch next element of `this' arg into `elt', or break if
741 `this' is exhausted. */
742 if (NILP (this)) break;
743 if (CONSP (this))
744 elt = XCAR (this), this = XCDR (this);
745 else if (thisindex >= thisleni)
746 break;
747 else if (STRINGP (this))
749 int c;
750 if (STRING_MULTIBYTE (this))
752 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
753 thisindex,
754 thisindex_byte);
755 XSETFASTINT (elt, c);
757 else
759 XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
760 if (some_multibyte
761 && (XINT (elt) >= 0240
762 || (XINT (elt) >= 0200
763 && ! NILP (Vnonascii_translation_table)))
764 && XINT (elt) < 0400)
766 c = unibyte_char_to_multibyte (XINT (elt));
767 XSETINT (elt, c);
771 else if (BOOL_VECTOR_P (this))
773 int byte;
774 byte = XBOOL_VECTOR (this)->data[thisindex / BITS_PER_CHAR];
775 if (byte & (1 << (thisindex % BITS_PER_CHAR)))
776 elt = Qt;
777 else
778 elt = Qnil;
779 thisindex++;
781 else
782 elt = XVECTOR (this)->contents[thisindex++];
784 /* Store this element into the result. */
785 if (toindex < 0)
787 XCAR (tail) = elt;
788 prev = tail;
789 tail = XCDR (tail);
791 else if (VECTORP (val))
792 XVECTOR (val)->contents[toindex++] = elt;
793 else
795 CHECK_NUMBER (elt, 0);
796 if (SINGLE_BYTE_CHAR_P (XINT (elt)))
798 if (some_multibyte)
799 toindex_byte
800 += CHAR_STRING (XINT (elt),
801 XSTRING (val)->data + toindex_byte);
802 else
803 XSTRING (val)->data[toindex_byte++] = XINT (elt);
804 if (some_multibyte
805 && toindex_byte > 0
806 && count_combining (XSTRING (val)->data,
807 toindex_byte, toindex_byte - 1))
808 XSTRING (val)->size--;
809 else
810 toindex++;
812 else
813 /* If we have any multibyte characters,
814 we already decided to make a multibyte string. */
816 int c = XINT (elt);
817 /* P exists as a variable
818 to avoid a bug on the Masscomp C compiler. */
819 unsigned char *p = & XSTRING (val)->data[toindex_byte];
821 toindex_byte += CHAR_STRING (c, p);
822 toindex++;
827 if (!NILP (prev))
828 XCDR (prev) = last_tail;
830 if (num_textprops > 0)
832 Lisp_Object props;
833 int last_to_end = -1;
835 for (argnum = 0; argnum < num_textprops; argnum++)
837 this = args[textprops[argnum].argnum];
838 props = text_property_list (this,
839 make_number (0),
840 make_number (XSTRING (this)->size),
841 Qnil);
842 /* If successive arguments have properites, be sure that the
843 value of `composition' property be the copy. */
844 if (last_to_end == textprops[argnum].to)
845 make_composition_value_copy (props);
846 add_text_properties_from_list (val, props,
847 make_number (textprops[argnum].to));
848 last_to_end = textprops[argnum].to + XSTRING (this)->size;
851 return val;
854 static Lisp_Object string_char_byte_cache_string;
855 static int string_char_byte_cache_charpos;
856 static int string_char_byte_cache_bytepos;
858 void
859 clear_string_char_byte_cache ()
861 string_char_byte_cache_string = Qnil;
864 /* Return the character index corresponding to CHAR_INDEX in STRING. */
867 string_char_to_byte (string, char_index)
868 Lisp_Object string;
869 int char_index;
871 int i, i_byte;
872 int best_below, best_below_byte;
873 int best_above, best_above_byte;
875 if (! STRING_MULTIBYTE (string))
876 return char_index;
878 best_below = best_below_byte = 0;
879 best_above = XSTRING (string)->size;
880 best_above_byte = STRING_BYTES (XSTRING (string));
882 if (EQ (string, string_char_byte_cache_string))
884 if (string_char_byte_cache_charpos < char_index)
886 best_below = string_char_byte_cache_charpos;
887 best_below_byte = string_char_byte_cache_bytepos;
889 else
891 best_above = string_char_byte_cache_charpos;
892 best_above_byte = string_char_byte_cache_bytepos;
896 if (char_index - best_below < best_above - char_index)
898 while (best_below < char_index)
900 int c;
901 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
902 best_below, best_below_byte);
904 i = best_below;
905 i_byte = best_below_byte;
907 else
909 while (best_above > char_index)
911 unsigned char *pend = XSTRING (string)->data + best_above_byte;
912 unsigned char *pbeg = pend - best_above_byte;
913 unsigned char *p = pend - 1;
914 int bytes;
916 while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
917 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
918 if (bytes == pend - p)
919 best_above_byte -= bytes;
920 else if (bytes > pend - p)
921 best_above_byte -= (pend - p);
922 else
923 best_above_byte--;
924 best_above--;
926 i = best_above;
927 i_byte = best_above_byte;
930 string_char_byte_cache_bytepos = i_byte;
931 string_char_byte_cache_charpos = i;
932 string_char_byte_cache_string = string;
934 return i_byte;
937 /* Return the character index corresponding to BYTE_INDEX in STRING. */
940 string_byte_to_char (string, byte_index)
941 Lisp_Object string;
942 int byte_index;
944 int i, i_byte;
945 int best_below, best_below_byte;
946 int best_above, best_above_byte;
948 if (! STRING_MULTIBYTE (string))
949 return byte_index;
951 best_below = best_below_byte = 0;
952 best_above = XSTRING (string)->size;
953 best_above_byte = STRING_BYTES (XSTRING (string));
955 if (EQ (string, string_char_byte_cache_string))
957 if (string_char_byte_cache_bytepos < byte_index)
959 best_below = string_char_byte_cache_charpos;
960 best_below_byte = string_char_byte_cache_bytepos;
962 else
964 best_above = string_char_byte_cache_charpos;
965 best_above_byte = string_char_byte_cache_bytepos;
969 if (byte_index - best_below_byte < best_above_byte - byte_index)
971 while (best_below_byte < byte_index)
973 int c;
974 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
975 best_below, best_below_byte);
977 i = best_below;
978 i_byte = best_below_byte;
980 else
982 while (best_above_byte > byte_index)
984 unsigned char *pend = XSTRING (string)->data + best_above_byte;
985 unsigned char *pbeg = pend - best_above_byte;
986 unsigned char *p = pend - 1;
987 int bytes;
989 while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
990 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
991 if (bytes == pend - p)
992 best_above_byte -= bytes;
993 else if (bytes > pend - p)
994 best_above_byte -= (pend - p);
995 else
996 best_above_byte--;
997 best_above--;
999 i = best_above;
1000 i_byte = best_above_byte;
1003 string_char_byte_cache_bytepos = i_byte;
1004 string_char_byte_cache_charpos = i;
1005 string_char_byte_cache_string = string;
1007 return i;
1010 /* Convert STRING to a multibyte string.
1011 Single-byte characters 0240 through 0377 are converted
1012 by adding nonascii_insert_offset to each. */
1014 Lisp_Object
1015 string_make_multibyte (string)
1016 Lisp_Object string;
1018 unsigned char *buf;
1019 int nbytes;
1021 if (STRING_MULTIBYTE (string))
1022 return string;
1024 nbytes = count_size_as_multibyte (XSTRING (string)->data,
1025 XSTRING (string)->size);
1026 /* If all the chars are ASCII, they won't need any more bytes
1027 once converted. In that case, we can return STRING itself. */
1028 if (nbytes == STRING_BYTES (XSTRING (string)))
1029 return string;
1031 buf = (unsigned char *) alloca (nbytes);
1032 copy_text (XSTRING (string)->data, buf, STRING_BYTES (XSTRING (string)),
1033 0, 1);
1035 return make_multibyte_string (buf, XSTRING (string)->size, nbytes);
1038 /* Convert STRING to a single-byte string. */
1040 Lisp_Object
1041 string_make_unibyte (string)
1042 Lisp_Object string;
1044 unsigned char *buf;
1046 if (! STRING_MULTIBYTE (string))
1047 return string;
1049 buf = (unsigned char *) alloca (XSTRING (string)->size);
1051 copy_text (XSTRING (string)->data, buf, STRING_BYTES (XSTRING (string)),
1052 1, 0);
1054 return make_unibyte_string (buf, XSTRING (string)->size);
1057 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1058 1, 1, 0,
1059 "Return the multibyte equivalent of STRING.\n\
1060 The function `unibyte-char-to-multibyte' is used to convert\n\
1061 each unibyte character to a multibyte character.")
1062 (string)
1063 Lisp_Object string;
1065 CHECK_STRING (string, 0);
1067 return string_make_multibyte (string);
1070 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1071 1, 1, 0,
1072 "Return the unibyte equivalent of STRING.\n\
1073 Multibyte character codes are converted to unibyte\n\
1074 by using just the low 8 bits.")
1075 (string)
1076 Lisp_Object string;
1078 CHECK_STRING (string, 0);
1080 return string_make_unibyte (string);
1083 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1084 1, 1, 0,
1085 "Return a unibyte string with the same individual bytes as STRING.\n\
1086 If STRING is unibyte, the result is STRING itself.\n\
1087 Otherwise it is a newly created string, with no text properties.\n\
1088 If STRING is multibyte and contains a character of charset\n\
1089 `eight-bit-control' or `eight-bit-graphic', it is converted to the\n\
1090 corresponding single byte.")
1091 (string)
1092 Lisp_Object string;
1094 CHECK_STRING (string, 0);
1096 if (STRING_MULTIBYTE (string))
1098 int bytes = STRING_BYTES (XSTRING (string));
1099 unsigned char *str = (unsigned char *) xmalloc (bytes);
1101 bcopy (XSTRING (string)->data, str, bytes);
1102 bytes = str_as_unibyte (str, bytes);
1103 string = make_unibyte_string (str, bytes);
1104 xfree (str);
1106 return string;
1109 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1110 1, 1, 0,
1111 "Return a multibyte string with the same individual bytes as STRING.\n\
1112 If STRING is multibyte, the result is STRING itself.\n\
1113 Otherwise it is a newly created string, with no text properties.\n\
1114 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1115 part of a multibyte form), it is converted to the corresponding\n\
1116 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.")
1117 (string)
1118 Lisp_Object string;
1120 CHECK_STRING (string, 0);
1122 if (! STRING_MULTIBYTE (string))
1124 Lisp_Object new_string;
1125 int nchars, nbytes;
1127 parse_str_as_multibyte (XSTRING (string)->data,
1128 STRING_BYTES (XSTRING (string)),
1129 &nchars, &nbytes);
1130 new_string = make_uninit_multibyte_string (nchars, nbytes);
1131 bcopy (XSTRING (string)->data, XSTRING (new_string)->data,
1132 STRING_BYTES (XSTRING (string)));
1133 if (nbytes != STRING_BYTES (XSTRING (string)))
1134 str_as_multibyte (XSTRING (new_string)->data, nbytes,
1135 STRING_BYTES (XSTRING (string)), NULL);
1136 string = new_string;
1137 XSTRING (string)->intervals = NULL_INTERVAL;
1139 return string;
1142 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1143 "Return a copy of ALIST.\n\
1144 This is an alist which represents the same mapping from objects to objects,\n\
1145 but does not share the alist structure with ALIST.\n\
1146 The objects mapped (cars and cdrs of elements of the alist)\n\
1147 are shared, however.\n\
1148 Elements of ALIST that are not conses are also shared.")
1149 (alist)
1150 Lisp_Object alist;
1152 register Lisp_Object tem;
1154 CHECK_LIST (alist, 0);
1155 if (NILP (alist))
1156 return alist;
1157 alist = concat (1, &alist, Lisp_Cons, 0);
1158 for (tem = alist; CONSP (tem); tem = XCDR (tem))
1160 register Lisp_Object car;
1161 car = XCAR (tem);
1163 if (CONSP (car))
1164 XCAR (tem) = Fcons (XCAR (car), XCDR (car));
1166 return alist;
1169 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
1170 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1171 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1172 If FROM or TO is negative, it counts from the end.\n\
1174 This function allows vectors as well as strings.")
1175 (string, from, to)
1176 Lisp_Object string;
1177 register Lisp_Object from, to;
1179 Lisp_Object res;
1180 int size;
1181 int size_byte = 0;
1182 int from_char, to_char;
1183 int from_byte = 0, to_byte = 0;
1185 if (! (STRINGP (string) || VECTORP (string)))
1186 wrong_type_argument (Qarrayp, string);
1188 CHECK_NUMBER (from, 1);
1190 if (STRINGP (string))
1192 size = XSTRING (string)->size;
1193 size_byte = STRING_BYTES (XSTRING (string));
1195 else
1196 size = XVECTOR (string)->size;
1198 if (NILP (to))
1200 to_char = size;
1201 to_byte = size_byte;
1203 else
1205 CHECK_NUMBER (to, 2);
1207 to_char = XINT (to);
1208 if (to_char < 0)
1209 to_char += size;
1211 if (STRINGP (string))
1212 to_byte = string_char_to_byte (string, to_char);
1215 from_char = XINT (from);
1216 if (from_char < 0)
1217 from_char += size;
1218 if (STRINGP (string))
1219 from_byte = string_char_to_byte (string, from_char);
1221 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1222 args_out_of_range_3 (string, make_number (from_char),
1223 make_number (to_char));
1225 if (STRINGP (string))
1227 res = make_specified_string (XSTRING (string)->data + from_byte,
1228 to_char - from_char, to_byte - from_byte,
1229 STRING_MULTIBYTE (string));
1230 copy_text_properties (make_number (from_char), make_number (to_char),
1231 string, make_number (0), res, Qnil);
1233 else
1234 res = Fvector (to_char - from_char,
1235 XVECTOR (string)->contents + from_char);
1237 return res;
1240 /* Extract a substring of STRING, giving start and end positions
1241 both in characters and in bytes. */
1243 Lisp_Object
1244 substring_both (string, from, from_byte, to, to_byte)
1245 Lisp_Object string;
1246 int from, from_byte, to, to_byte;
1248 Lisp_Object res;
1249 int size;
1250 int size_byte;
1252 if (! (STRINGP (string) || VECTORP (string)))
1253 wrong_type_argument (Qarrayp, string);
1255 if (STRINGP (string))
1257 size = XSTRING (string)->size;
1258 size_byte = STRING_BYTES (XSTRING (string));
1260 else
1261 size = XVECTOR (string)->size;
1263 if (!(0 <= from && from <= to && to <= size))
1264 args_out_of_range_3 (string, make_number (from), make_number (to));
1266 if (STRINGP (string))
1268 res = make_specified_string (XSTRING (string)->data + from_byte,
1269 to - from, to_byte - from_byte,
1270 STRING_MULTIBYTE (string));
1271 copy_text_properties (make_number (from), make_number (to),
1272 string, make_number (0), res, Qnil);
1274 else
1275 res = Fvector (to - from,
1276 XVECTOR (string)->contents + from);
1278 return res;
1281 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1282 "Take cdr N times on LIST, returns the result.")
1283 (n, list)
1284 Lisp_Object n;
1285 register Lisp_Object list;
1287 register int i, num;
1288 CHECK_NUMBER (n, 0);
1289 num = XINT (n);
1290 for (i = 0; i < num && !NILP (list); i++)
1292 QUIT;
1293 if (! CONSP (list))
1294 wrong_type_argument (Qlistp, list);
1295 list = XCDR (list);
1297 return list;
1300 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1301 "Return the Nth element of LIST.\n\
1302 N counts from zero. If LIST is not that long, nil is returned.")
1303 (n, list)
1304 Lisp_Object n, list;
1306 return Fcar (Fnthcdr (n, list));
1309 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1310 "Return element of SEQUENCE at index N.")
1311 (sequence, n)
1312 register Lisp_Object sequence, n;
1314 CHECK_NUMBER (n, 0);
1315 while (1)
1317 if (CONSP (sequence) || NILP (sequence))
1318 return Fcar (Fnthcdr (n, sequence));
1319 else if (STRINGP (sequence) || VECTORP (sequence)
1320 || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
1321 return Faref (sequence, n);
1322 else
1323 sequence = wrong_type_argument (Qsequencep, sequence);
1327 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1328 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1329 The value is actually the tail of LIST whose car is ELT.")
1330 (elt, list)
1331 register Lisp_Object elt;
1332 Lisp_Object list;
1334 register Lisp_Object tail;
1335 for (tail = list; !NILP (tail); tail = XCDR (tail))
1337 register Lisp_Object tem;
1338 if (! CONSP (tail))
1339 wrong_type_argument (Qlistp, list);
1340 tem = XCAR (tail);
1341 if (! NILP (Fequal (elt, tem)))
1342 return tail;
1343 QUIT;
1345 return Qnil;
1348 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1349 "Return non-nil if ELT is an element of LIST.\n\
1350 Comparison done with EQ. The value is actually the tail of LIST\n\
1351 whose car is ELT.")
1352 (elt, list)
1353 Lisp_Object elt, list;
1355 while (1)
1357 if (!CONSP (list) || EQ (XCAR (list), elt))
1358 break;
1360 list = XCDR (list);
1361 if (!CONSP (list) || EQ (XCAR (list), elt))
1362 break;
1364 list = XCDR (list);
1365 if (!CONSP (list) || EQ (XCAR (list), elt))
1366 break;
1368 list = XCDR (list);
1369 QUIT;
1372 if (!CONSP (list) && !NILP (list))
1373 list = wrong_type_argument (Qlistp, list);
1375 return list;
1378 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1379 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1380 The value is actually the element of LIST whose car is KEY.\n\
1381 Elements of LIST that are not conses are ignored.")
1382 (key, list)
1383 Lisp_Object key, list;
1385 Lisp_Object result;
1387 while (1)
1389 if (!CONSP (list)
1390 || (CONSP (XCAR (list))
1391 && EQ (XCAR (XCAR (list)), key)))
1392 break;
1394 list = XCDR (list);
1395 if (!CONSP (list)
1396 || (CONSP (XCAR (list))
1397 && EQ (XCAR (XCAR (list)), key)))
1398 break;
1400 list = XCDR (list);
1401 if (!CONSP (list)
1402 || (CONSP (XCAR (list))
1403 && EQ (XCAR (XCAR (list)), key)))
1404 break;
1406 list = XCDR (list);
1407 QUIT;
1410 if (CONSP (list))
1411 result = XCAR (list);
1412 else if (NILP (list))
1413 result = Qnil;
1414 else
1415 result = wrong_type_argument (Qlistp, list);
1417 return result;
1420 /* Like Fassq but never report an error and do not allow quits.
1421 Use only on lists known never to be circular. */
1423 Lisp_Object
1424 assq_no_quit (key, list)
1425 Lisp_Object key, list;
1427 while (CONSP (list)
1428 && (!CONSP (XCAR (list))
1429 || !EQ (XCAR (XCAR (list)), key)))
1430 list = XCDR (list);
1432 return CONSP (list) ? XCAR (list) : Qnil;
1435 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1436 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1437 The value is actually the element of LIST whose car equals KEY.")
1438 (key, list)
1439 Lisp_Object key, list;
1441 Lisp_Object result, car;
1443 while (1)
1445 if (!CONSP (list)
1446 || (CONSP (XCAR (list))
1447 && (car = XCAR (XCAR (list)),
1448 EQ (car, key) || !NILP (Fequal (car, key)))))
1449 break;
1451 list = XCDR (list);
1452 if (!CONSP (list)
1453 || (CONSP (XCAR (list))
1454 && (car = XCAR (XCAR (list)),
1455 EQ (car, key) || !NILP (Fequal (car, key)))))
1456 break;
1458 list = XCDR (list);
1459 if (!CONSP (list)
1460 || (CONSP (XCAR (list))
1461 && (car = XCAR (XCAR (list)),
1462 EQ (car, key) || !NILP (Fequal (car, key)))))
1463 break;
1465 list = XCDR (list);
1466 QUIT;
1469 if (CONSP (list))
1470 result = XCAR (list);
1471 else if (NILP (list))
1472 result = Qnil;
1473 else
1474 result = wrong_type_argument (Qlistp, list);
1476 return result;
1479 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1480 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1481 The value is actually the element of LIST whose cdr is KEY.")
1482 (key, list)
1483 register Lisp_Object key;
1484 Lisp_Object list;
1486 Lisp_Object result;
1488 while (1)
1490 if (!CONSP (list)
1491 || (CONSP (XCAR (list))
1492 && EQ (XCDR (XCAR (list)), key)))
1493 break;
1495 list = XCDR (list);
1496 if (!CONSP (list)
1497 || (CONSP (XCAR (list))
1498 && EQ (XCDR (XCAR (list)), key)))
1499 break;
1501 list = XCDR (list);
1502 if (!CONSP (list)
1503 || (CONSP (XCAR (list))
1504 && EQ (XCDR (XCAR (list)), key)))
1505 break;
1507 list = XCDR (list);
1508 QUIT;
1511 if (NILP (list))
1512 result = Qnil;
1513 else if (CONSP (list))
1514 result = XCAR (list);
1515 else
1516 result = wrong_type_argument (Qlistp, list);
1518 return result;
1521 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1522 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1523 The value is actually the element of LIST whose cdr equals KEY.")
1524 (key, list)
1525 Lisp_Object key, list;
1527 Lisp_Object result, cdr;
1529 while (1)
1531 if (!CONSP (list)
1532 || (CONSP (XCAR (list))
1533 && (cdr = XCDR (XCAR (list)),
1534 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1535 break;
1537 list = XCDR (list);
1538 if (!CONSP (list)
1539 || (CONSP (XCAR (list))
1540 && (cdr = XCDR (XCAR (list)),
1541 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1542 break;
1544 list = XCDR (list);
1545 if (!CONSP (list)
1546 || (CONSP (XCAR (list))
1547 && (cdr = XCDR (XCAR (list)),
1548 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1549 break;
1551 list = XCDR (list);
1552 QUIT;
1555 if (CONSP (list))
1556 result = XCAR (list);
1557 else if (NILP (list))
1558 result = Qnil;
1559 else
1560 result = wrong_type_argument (Qlistp, list);
1562 return result;
1565 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1566 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1567 The modified LIST is returned. Comparison is done with `eq'.\n\
1568 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1569 therefore, write `(setq foo (delq element foo))'\n\
1570 to be sure of changing the value of `foo'.")
1571 (elt, list)
1572 register Lisp_Object elt;
1573 Lisp_Object list;
1575 register Lisp_Object tail, prev;
1576 register Lisp_Object tem;
1578 tail = list;
1579 prev = Qnil;
1580 while (!NILP (tail))
1582 if (! CONSP (tail))
1583 wrong_type_argument (Qlistp, list);
1584 tem = XCAR (tail);
1585 if (EQ (elt, tem))
1587 if (NILP (prev))
1588 list = XCDR (tail);
1589 else
1590 Fsetcdr (prev, XCDR (tail));
1592 else
1593 prev = tail;
1594 tail = XCDR (tail);
1595 QUIT;
1597 return list;
1600 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1601 "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
1602 SEQ must be a list, a vector, or a string.\n\
1603 The modified SEQ is returned. Comparison is done with `equal'.\n\
1604 If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
1605 is not a side effect; it is simply using a different sequence.\n\
1606 Therefore, write `(setq foo (delete element foo))'\n\
1607 to be sure of changing the value of `foo'.")
1608 (elt, seq)
1609 Lisp_Object elt, seq;
1611 if (VECTORP (seq))
1613 EMACS_INT i, n;
1615 for (i = n = 0; i < ASIZE (seq); ++i)
1616 if (NILP (Fequal (AREF (seq, i), elt)))
1617 ++n;
1619 if (n != ASIZE (seq))
1621 struct Lisp_Vector *p = allocate_vectorlike (n);
1623 for (i = n = 0; i < ASIZE (seq); ++i)
1624 if (NILP (Fequal (AREF (seq, i), elt)))
1625 p->contents[n++] = AREF (seq, i);
1627 p->size = n;
1628 XSETVECTOR (seq, p);
1631 else if (STRINGP (seq))
1633 EMACS_INT i, ibyte, nchars, nbytes, cbytes;
1634 int c;
1636 for (i = nchars = nbytes = ibyte = 0;
1637 i < XSTRING (seq)->size;
1638 ++i, ibyte += cbytes)
1640 if (STRING_MULTIBYTE (seq))
1642 c = STRING_CHAR (&XSTRING (seq)->data[ibyte],
1643 STRING_BYTES (XSTRING (seq)) - ibyte);
1644 cbytes = CHAR_BYTES (c);
1646 else
1648 c = XSTRING (seq)->data[i];
1649 cbytes = 1;
1652 if (!INTEGERP (elt) || c != XINT (elt))
1654 ++nchars;
1655 nbytes += cbytes;
1659 if (nchars != XSTRING (seq)->size)
1661 Lisp_Object tem;
1663 tem = make_uninit_multibyte_string (nchars, nbytes);
1664 if (!STRING_MULTIBYTE (seq))
1665 SET_STRING_BYTES (XSTRING (tem), -1);
1667 for (i = nchars = nbytes = ibyte = 0;
1668 i < XSTRING (seq)->size;
1669 ++i, ibyte += cbytes)
1671 if (STRING_MULTIBYTE (seq))
1673 c = STRING_CHAR (&XSTRING (seq)->data[ibyte],
1674 STRING_BYTES (XSTRING (seq)) - ibyte);
1675 cbytes = CHAR_BYTES (c);
1677 else
1679 c = XSTRING (seq)->data[i];
1680 cbytes = 1;
1683 if (!INTEGERP (elt) || c != XINT (elt))
1685 unsigned char *from = &XSTRING (seq)->data[ibyte];
1686 unsigned char *to = &XSTRING (tem)->data[nbytes];
1687 EMACS_INT n;
1689 ++nchars;
1690 nbytes += cbytes;
1692 for (n = cbytes; n--; )
1693 *to++ = *from++;
1697 seq = tem;
1700 else
1702 Lisp_Object tail, prev;
1704 for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
1706 if (!CONSP (tail))
1707 wrong_type_argument (Qlistp, seq);
1709 if (!NILP (Fequal (elt, XCAR (tail))))
1711 if (NILP (prev))
1712 seq = XCDR (tail);
1713 else
1714 Fsetcdr (prev, XCDR (tail));
1716 else
1717 prev = tail;
1718 QUIT;
1722 return seq;
1725 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1726 "Reverse LIST by modifying cdr pointers.\n\
1727 Returns the beginning of the reversed list.")
1728 (list)
1729 Lisp_Object list;
1731 register Lisp_Object prev, tail, next;
1733 if (NILP (list)) return list;
1734 prev = Qnil;
1735 tail = list;
1736 while (!NILP (tail))
1738 QUIT;
1739 if (! CONSP (tail))
1740 wrong_type_argument (Qlistp, list);
1741 next = XCDR (tail);
1742 Fsetcdr (tail, prev);
1743 prev = tail;
1744 tail = next;
1746 return prev;
1749 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1750 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1751 See also the function `nreverse', which is used more often.")
1752 (list)
1753 Lisp_Object list;
1755 Lisp_Object new;
1757 for (new = Qnil; CONSP (list); list = XCDR (list))
1758 new = Fcons (XCAR (list), new);
1759 if (!NILP (list))
1760 wrong_type_argument (Qconsp, list);
1761 return new;
1764 Lisp_Object merge ();
1766 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1767 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1768 Returns the sorted list. LIST is modified by side effects.\n\
1769 PREDICATE is called with two elements of LIST, and should return T\n\
1770 if the first element is \"less\" than the second.")
1771 (list, predicate)
1772 Lisp_Object list, predicate;
1774 Lisp_Object front, back;
1775 register Lisp_Object len, tem;
1776 struct gcpro gcpro1, gcpro2;
1777 register int length;
1779 front = list;
1780 len = Flength (list);
1781 length = XINT (len);
1782 if (length < 2)
1783 return list;
1785 XSETINT (len, (length / 2) - 1);
1786 tem = Fnthcdr (len, list);
1787 back = Fcdr (tem);
1788 Fsetcdr (tem, Qnil);
1790 GCPRO2 (front, back);
1791 front = Fsort (front, predicate);
1792 back = Fsort (back, predicate);
1793 UNGCPRO;
1794 return merge (front, back, predicate);
1797 Lisp_Object
1798 merge (org_l1, org_l2, pred)
1799 Lisp_Object org_l1, org_l2;
1800 Lisp_Object pred;
1802 Lisp_Object value;
1803 register Lisp_Object tail;
1804 Lisp_Object tem;
1805 register Lisp_Object l1, l2;
1806 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1808 l1 = org_l1;
1809 l2 = org_l2;
1810 tail = Qnil;
1811 value = Qnil;
1813 /* It is sufficient to protect org_l1 and org_l2.
1814 When l1 and l2 are updated, we copy the new values
1815 back into the org_ vars. */
1816 GCPRO4 (org_l1, org_l2, pred, value);
1818 while (1)
1820 if (NILP (l1))
1822 UNGCPRO;
1823 if (NILP (tail))
1824 return l2;
1825 Fsetcdr (tail, l2);
1826 return value;
1828 if (NILP (l2))
1830 UNGCPRO;
1831 if (NILP (tail))
1832 return l1;
1833 Fsetcdr (tail, l1);
1834 return value;
1836 tem = call2 (pred, Fcar (l2), Fcar (l1));
1837 if (NILP (tem))
1839 tem = l1;
1840 l1 = Fcdr (l1);
1841 org_l1 = l1;
1843 else
1845 tem = l2;
1846 l2 = Fcdr (l2);
1847 org_l2 = l2;
1849 if (NILP (tail))
1850 value = tem;
1851 else
1852 Fsetcdr (tail, tem);
1853 tail = tem;
1858 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1859 "Extract a value from a property list.\n\
1860 PLIST is a property list, which is a list of the form\n\
1861 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1862 corresponding to the given PROP, or nil if PROP is not\n\
1863 one of the properties on the list.")
1864 (plist, prop)
1865 Lisp_Object plist;
1866 register Lisp_Object prop;
1868 register Lisp_Object tail;
1869 for (tail = plist; !NILP (tail); tail = Fcdr (XCDR (tail)))
1871 register Lisp_Object tem;
1872 tem = Fcar (tail);
1873 if (EQ (prop, tem))
1874 return Fcar (XCDR (tail));
1876 return Qnil;
1879 DEFUN ("get", Fget, Sget, 2, 2, 0,
1880 "Return the value of SYMBOL's PROPNAME property.\n\
1881 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1882 (symbol, propname)
1883 Lisp_Object symbol, propname;
1885 CHECK_SYMBOL (symbol, 0);
1886 return Fplist_get (XSYMBOL (symbol)->plist, propname);
1889 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1890 "Change value in PLIST of PROP to VAL.\n\
1891 PLIST is a property list, which is a list of the form\n\
1892 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1893 If PROP is already a property on the list, its value is set to VAL,\n\
1894 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1895 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1896 The PLIST is modified by side effects.")
1897 (plist, prop, val)
1898 Lisp_Object plist;
1899 register Lisp_Object prop;
1900 Lisp_Object val;
1902 register Lisp_Object tail, prev;
1903 Lisp_Object newcell;
1904 prev = Qnil;
1905 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1906 tail = XCDR (XCDR (tail)))
1908 if (EQ (prop, XCAR (tail)))
1910 Fsetcar (XCDR (tail), val);
1911 return plist;
1913 prev = tail;
1915 newcell = Fcons (prop, Fcons (val, Qnil));
1916 if (NILP (prev))
1917 return newcell;
1918 else
1919 Fsetcdr (XCDR (prev), newcell);
1920 return plist;
1923 DEFUN ("put", Fput, Sput, 3, 3, 0,
1924 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1925 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1926 (symbol, propname, value)
1927 Lisp_Object symbol, propname, value;
1929 CHECK_SYMBOL (symbol, 0);
1930 XSYMBOL (symbol)->plist
1931 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
1932 return value;
1935 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
1936 "Return t if two Lisp objects have similar structure and contents.\n\
1937 They must have the same data type.\n\
1938 Conses are compared by comparing the cars and the cdrs.\n\
1939 Vectors and strings are compared element by element.\n\
1940 Numbers are compared by value, but integers cannot equal floats.\n\
1941 (Use `=' if you want integers and floats to be able to be equal.)\n\
1942 Symbols must match exactly.")
1943 (o1, o2)
1944 register Lisp_Object o1, o2;
1946 return internal_equal (o1, o2, 0) ? Qt : Qnil;
1949 static int
1950 internal_equal (o1, o2, depth)
1951 register Lisp_Object o1, o2;
1952 int depth;
1954 if (depth > 200)
1955 error ("Stack overflow in equal");
1957 tail_recurse:
1958 QUIT;
1959 if (EQ (o1, o2))
1960 return 1;
1961 if (XTYPE (o1) != XTYPE (o2))
1962 return 0;
1964 switch (XTYPE (o1))
1966 case Lisp_Float:
1967 return (extract_float (o1) == extract_float (o2));
1969 case Lisp_Cons:
1970 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
1971 return 0;
1972 o1 = XCDR (o1);
1973 o2 = XCDR (o2);
1974 goto tail_recurse;
1976 case Lisp_Misc:
1977 if (XMISCTYPE (o1) != XMISCTYPE (o2))
1978 return 0;
1979 if (OVERLAYP (o1))
1981 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
1982 depth + 1)
1983 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
1984 depth + 1))
1985 return 0;
1986 o1 = XOVERLAY (o1)->plist;
1987 o2 = XOVERLAY (o2)->plist;
1988 goto tail_recurse;
1990 if (MARKERP (o1))
1992 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
1993 && (XMARKER (o1)->buffer == 0
1994 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
1996 break;
1998 case Lisp_Vectorlike:
2000 register int i, size;
2001 size = XVECTOR (o1)->size;
2002 /* Pseudovectors have the type encoded in the size field, so this test
2003 actually checks that the objects have the same type as well as the
2004 same size. */
2005 if (XVECTOR (o2)->size != size)
2006 return 0;
2007 /* Boolvectors are compared much like strings. */
2008 if (BOOL_VECTOR_P (o1))
2010 int size_in_chars
2011 = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
2013 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
2014 return 0;
2015 if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
2016 size_in_chars))
2017 return 0;
2018 return 1;
2020 if (WINDOW_CONFIGURATIONP (o1))
2021 return compare_window_configurations (o1, o2, 0);
2023 /* Aside from them, only true vectors, char-tables, and compiled
2024 functions are sensible to compare, so eliminate the others now. */
2025 if (size & PSEUDOVECTOR_FLAG)
2027 if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
2028 return 0;
2029 size &= PSEUDOVECTOR_SIZE_MASK;
2031 for (i = 0; i < size; i++)
2033 Lisp_Object v1, v2;
2034 v1 = XVECTOR (o1)->contents [i];
2035 v2 = XVECTOR (o2)->contents [i];
2036 if (!internal_equal (v1, v2, depth + 1))
2037 return 0;
2039 return 1;
2041 break;
2043 case Lisp_String:
2044 if (XSTRING (o1)->size != XSTRING (o2)->size)
2045 return 0;
2046 if (STRING_BYTES (XSTRING (o1)) != STRING_BYTES (XSTRING (o2)))
2047 return 0;
2048 if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
2049 STRING_BYTES (XSTRING (o1))))
2050 return 0;
2051 return 1;
2053 case Lisp_Int:
2054 case Lisp_Symbol:
2055 case Lisp_Type_Limit:
2056 break;
2059 return 0;
2062 extern Lisp_Object Fmake_char_internal ();
2064 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2065 "Store each element of ARRAY with ITEM.\n\
2066 ARRAY is a vector, string, char-table, or bool-vector.")
2067 (array, item)
2068 Lisp_Object array, item;
2070 register int size, index, charval;
2071 retry:
2072 if (VECTORP (array))
2074 register Lisp_Object *p = XVECTOR (array)->contents;
2075 size = XVECTOR (array)->size;
2076 for (index = 0; index < size; index++)
2077 p[index] = item;
2079 else if (CHAR_TABLE_P (array))
2081 register Lisp_Object *p = XCHAR_TABLE (array)->contents;
2082 size = CHAR_TABLE_ORDINARY_SLOTS;
2083 for (index = 0; index < size; index++)
2084 p[index] = item;
2085 XCHAR_TABLE (array)->defalt = Qnil;
2087 else if (STRINGP (array))
2089 register unsigned char *p = XSTRING (array)->data;
2090 CHECK_NUMBER (item, 1);
2091 charval = XINT (item);
2092 size = XSTRING (array)->size;
2093 if (STRING_MULTIBYTE (array))
2095 unsigned char str[MAX_MULTIBYTE_LENGTH];
2096 int len = CHAR_STRING (charval, str);
2097 int size_byte = STRING_BYTES (XSTRING (array));
2098 unsigned char *p1 = p, *endp = p + size_byte;
2099 int i;
2101 if (size != size_byte)
2102 while (p1 < endp)
2104 int this_len = MULTIBYTE_FORM_LENGTH (p1, endp - p1);
2105 if (len != this_len)
2106 error ("Attempt to change byte length of a string");
2107 p1 += this_len;
2109 for (i = 0; i < size_byte; i++)
2110 *p++ = str[i % len];
2112 else
2113 for (index = 0; index < size; index++)
2114 p[index] = charval;
2116 else if (BOOL_VECTOR_P (array))
2118 register unsigned char *p = XBOOL_VECTOR (array)->data;
2119 int size_in_chars
2120 = (XBOOL_VECTOR (array)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
2122 charval = (! NILP (item) ? -1 : 0);
2123 for (index = 0; index < size_in_chars; index++)
2124 p[index] = charval;
2126 else
2128 array = wrong_type_argument (Qarrayp, array);
2129 goto retry;
2131 return array;
2134 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
2135 1, 1, 0,
2136 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2137 (char_table)
2138 Lisp_Object char_table;
2140 CHECK_CHAR_TABLE (char_table, 0);
2142 return XCHAR_TABLE (char_table)->purpose;
2145 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
2146 1, 1, 0,
2147 "Return the parent char-table of CHAR-TABLE.\n\
2148 The value is either nil or another char-table.\n\
2149 If CHAR-TABLE holds nil for a given character,\n\
2150 then the actual applicable value is inherited from the parent char-table\n\
2151 \(or from its parents, if necessary).")
2152 (char_table)
2153 Lisp_Object char_table;
2155 CHECK_CHAR_TABLE (char_table, 0);
2157 return XCHAR_TABLE (char_table)->parent;
2160 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
2161 2, 2, 0,
2162 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2163 PARENT must be either nil or another char-table.")
2164 (char_table, parent)
2165 Lisp_Object char_table, parent;
2167 Lisp_Object temp;
2169 CHECK_CHAR_TABLE (char_table, 0);
2171 if (!NILP (parent))
2173 CHECK_CHAR_TABLE (parent, 0);
2175 for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
2176 if (EQ (temp, char_table))
2177 error ("Attempt to make a chartable be its own parent");
2180 XCHAR_TABLE (char_table)->parent = parent;
2182 return parent;
2185 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
2186 2, 2, 0,
2187 "Return the value of CHAR-TABLE's extra-slot number N.")
2188 (char_table, n)
2189 Lisp_Object char_table, n;
2191 CHECK_CHAR_TABLE (char_table, 1);
2192 CHECK_NUMBER (n, 2);
2193 if (XINT (n) < 0
2194 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
2195 args_out_of_range (char_table, n);
2197 return XCHAR_TABLE (char_table)->extras[XINT (n)];
2200 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
2201 Sset_char_table_extra_slot,
2202 3, 3, 0,
2203 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2204 (char_table, n, value)
2205 Lisp_Object char_table, n, value;
2207 CHECK_CHAR_TABLE (char_table, 1);
2208 CHECK_NUMBER (n, 2);
2209 if (XINT (n) < 0
2210 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
2211 args_out_of_range (char_table, n);
2213 return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
2216 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
2217 2, 2, 0,
2218 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2219 RANGE should be nil (for the default value)\n\
2220 a vector which identifies a character set or a row of a character set,\n\
2221 a character set name, or a character code.")
2222 (char_table, range)
2223 Lisp_Object char_table, range;
2225 CHECK_CHAR_TABLE (char_table, 0);
2227 if (EQ (range, Qnil))
2228 return XCHAR_TABLE (char_table)->defalt;
2229 else if (INTEGERP (range))
2230 return Faref (char_table, range);
2231 else if (SYMBOLP (range))
2233 Lisp_Object charset_info;
2235 charset_info = Fget (range, Qcharset);
2236 CHECK_VECTOR (charset_info, 0);
2238 return Faref (char_table,
2239 make_number (XINT (XVECTOR (charset_info)->contents[0])
2240 + 128));
2242 else if (VECTORP (range))
2244 if (XVECTOR (range)->size == 1)
2245 return Faref (char_table,
2246 make_number (XINT (XVECTOR (range)->contents[0]) + 128));
2247 else
2249 int size = XVECTOR (range)->size;
2250 Lisp_Object *val = XVECTOR (range)->contents;
2251 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
2252 size <= 1 ? Qnil : val[1],
2253 size <= 2 ? Qnil : val[2]);
2254 return Faref (char_table, ch);
2257 else
2258 error ("Invalid RANGE argument to `char-table-range'");
2259 return Qt;
2262 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
2263 3, 3, 0,
2264 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2265 RANGE should be t (for all characters), nil (for the default value)\n\
2266 a vector which identifies a character set or a row of a character set,\n\
2267 a coding system, or a character code.")
2268 (char_table, range, value)
2269 Lisp_Object char_table, range, value;
2271 int i;
2273 CHECK_CHAR_TABLE (char_table, 0);
2275 if (EQ (range, Qt))
2276 for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
2277 XCHAR_TABLE (char_table)->contents[i] = value;
2278 else if (EQ (range, Qnil))
2279 XCHAR_TABLE (char_table)->defalt = value;
2280 else if (SYMBOLP (range))
2282 Lisp_Object charset_info;
2284 charset_info = Fget (range, Qcharset);
2285 CHECK_VECTOR (charset_info, 0);
2287 return Faset (char_table,
2288 make_number (XINT (XVECTOR (charset_info)->contents[0])
2289 + 128),
2290 value);
2292 else if (INTEGERP (range))
2293 Faset (char_table, range, value);
2294 else if (VECTORP (range))
2296 if (XVECTOR (range)->size == 1)
2297 return Faset (char_table,
2298 make_number (XINT (XVECTOR (range)->contents[0]) + 128),
2299 value);
2300 else
2302 int size = XVECTOR (range)->size;
2303 Lisp_Object *val = XVECTOR (range)->contents;
2304 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
2305 size <= 1 ? Qnil : val[1],
2306 size <= 2 ? Qnil : val[2]);
2307 return Faset (char_table, ch, value);
2310 else
2311 error ("Invalid RANGE argument to `set-char-table-range'");
2313 return value;
2316 DEFUN ("set-char-table-default", Fset_char_table_default,
2317 Sset_char_table_default, 3, 3, 0,
2318 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2319 The generic character specifies the group of characters.\n\
2320 See also the documentation of make-char.")
2321 (char_table, ch, value)
2322 Lisp_Object char_table, ch, value;
2324 int c, charset, code1, code2;
2325 Lisp_Object temp;
2327 CHECK_CHAR_TABLE (char_table, 0);
2328 CHECK_NUMBER (ch, 1);
2330 c = XINT (ch);
2331 SPLIT_CHAR (c, charset, code1, code2);
2333 /* Since we may want to set the default value for a character set
2334 not yet defined, we check only if the character set is in the
2335 valid range or not, instead of it is already defined or not. */
2336 if (! CHARSET_VALID_P (charset))
2337 invalid_character (c);
2339 if (charset == CHARSET_ASCII)
2340 return (XCHAR_TABLE (char_table)->defalt = value);
2342 /* Even if C is not a generic char, we had better behave as if a
2343 generic char is specified. */
2344 if (CHARSET_DIMENSION (charset) == 1)
2345 code1 = 0;
2346 temp = XCHAR_TABLE (char_table)->contents[charset + 128];
2347 if (!code1)
2349 if (SUB_CHAR_TABLE_P (temp))
2350 XCHAR_TABLE (temp)->defalt = value;
2351 else
2352 XCHAR_TABLE (char_table)->contents[charset + 128] = value;
2353 return value;
2355 if (SUB_CHAR_TABLE_P (temp))
2356 char_table = temp;
2357 else
2358 char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
2359 = make_sub_char_table (temp));
2360 temp = XCHAR_TABLE (char_table)->contents[code1];
2361 if (SUB_CHAR_TABLE_P (temp))
2362 XCHAR_TABLE (temp)->defalt = value;
2363 else
2364 XCHAR_TABLE (char_table)->contents[code1] = value;
2365 return value;
2368 /* Look up the element in TABLE at index CH,
2369 and return it as an integer.
2370 If the element is nil, return CH itself.
2371 (Actually we do that for any non-integer.) */
2374 char_table_translate (table, ch)
2375 Lisp_Object table;
2376 int ch;
2378 Lisp_Object value;
2379 value = Faref (table, make_number (ch));
2380 if (! INTEGERP (value))
2381 return ch;
2382 return XINT (value);
2385 static void
2386 optimize_sub_char_table (table, chars)
2387 Lisp_Object *table;
2388 int chars;
2390 Lisp_Object elt;
2391 int from, to;
2393 if (chars == 94)
2394 from = 33, to = 127;
2395 else
2396 from = 32, to = 128;
2398 if (!SUB_CHAR_TABLE_P (*table))
2399 return;
2400 elt = XCHAR_TABLE (*table)->contents[from++];
2401 for (; from < to; from++)
2402 if (NILP (Fequal (elt, XCHAR_TABLE (*table)->contents[from])))
2403 return;
2404 *table = elt;
2407 DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
2408 1, 1, 0,
2409 "Optimize char table TABLE.")
2410 (table)
2411 Lisp_Object table;
2413 Lisp_Object elt;
2414 int dim;
2415 int i, j;
2417 CHECK_CHAR_TABLE (table, 0);
2419 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
2421 elt = XCHAR_TABLE (table)->contents[i];
2422 if (!SUB_CHAR_TABLE_P (elt))
2423 continue;
2424 dim = CHARSET_DIMENSION (i - 128);
2425 if (dim == 2)
2426 for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++)
2427 optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, dim);
2428 optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, dim);
2430 return Qnil;
2434 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2435 character or group of characters that share a value.
2436 DEPTH is the current depth in the originally specified
2437 chartable, and INDICES contains the vector indices
2438 for the levels our callers have descended.
2440 ARG is passed to C_FUNCTION when that is called. */
2442 void
2443 map_char_table (c_function, function, subtable, arg, depth, indices)
2444 void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
2445 Lisp_Object function, subtable, arg, *indices;
2446 int depth;
2448 int i, to;
2450 if (depth == 0)
2452 /* At first, handle ASCII and 8-bit European characters. */
2453 for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
2455 Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
2456 if (c_function)
2457 (*c_function) (arg, make_number (i), elt);
2458 else
2459 call2 (function, make_number (i), elt);
2461 #if 0 /* If the char table has entries for higher characters,
2462 we should report them. */
2463 if (NILP (current_buffer->enable_multibyte_characters))
2464 return;
2465 #endif
2466 to = CHAR_TABLE_ORDINARY_SLOTS;
2468 else
2470 int charset = XFASTINT (indices[0]) - 128;
2472 i = 32;
2473 to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
2474 if (CHARSET_CHARS (charset) == 94)
2475 i++, to--;
2478 for (; i < to; i++)
2480 Lisp_Object elt;
2481 int charset;
2483 elt = XCHAR_TABLE (subtable)->contents[i];
2484 XSETFASTINT (indices[depth], i);
2485 charset = XFASTINT (indices[0]) - 128;
2486 if (depth == 0
2487 && (!CHARSET_DEFINED_P (charset)
2488 || charset == CHARSET_8_BIT_CONTROL
2489 || charset == CHARSET_8_BIT_GRAPHIC))
2490 continue;
2492 if (SUB_CHAR_TABLE_P (elt))
2494 if (depth >= 3)
2495 error ("Too deep char table");
2496 map_char_table (c_function, function, elt, arg, depth + 1, indices);
2498 else
2500 int c1, c2, c;
2502 if (NILP (elt))
2503 elt = XCHAR_TABLE (subtable)->defalt;
2504 c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
2505 c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
2506 c = MAKE_CHAR (charset, c1, c2);
2507 if (c_function)
2508 (*c_function) (arg, make_number (c), elt);
2509 else
2510 call2 (function, make_number (c), elt);
2515 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
2516 2, 2, 0,
2517 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2518 FUNCTION is called with two arguments--a key and a value.\n\
2519 The key is always a possible IDX argument to `aref'.")
2520 (function, char_table)
2521 Lisp_Object function, char_table;
2523 /* The depth of char table is at most 3. */
2524 Lisp_Object indices[3];
2526 CHECK_CHAR_TABLE (char_table, 1);
2528 map_char_table (NULL, function, char_table, char_table, 0, indices);
2529 return Qnil;
2532 /* Return a value for character C in char-table TABLE. Store the
2533 actual index for that value in *IDX. Ignore the default value of
2534 TABLE. */
2536 Lisp_Object
2537 char_table_ref_and_index (table, c, idx)
2538 Lisp_Object table;
2539 int c, *idx;
2541 int charset, c1, c2;
2542 Lisp_Object elt;
2544 if (SINGLE_BYTE_CHAR_P (c))
2546 *idx = c;
2547 return XCHAR_TABLE (table)->contents[c];
2549 SPLIT_CHAR (c, charset, c1, c2);
2550 elt = XCHAR_TABLE (table)->contents[charset + 128];
2551 *idx = MAKE_CHAR (charset, 0, 0);
2552 if (!SUB_CHAR_TABLE_P (elt))
2553 return elt;
2554 if (c1 < 32 || NILP (XCHAR_TABLE (elt)->contents[c1]))
2555 return XCHAR_TABLE (elt)->defalt;
2556 elt = XCHAR_TABLE (elt)->contents[c1];
2557 *idx = MAKE_CHAR (charset, c1, 0);
2558 if (!SUB_CHAR_TABLE_P (elt))
2559 return elt;
2560 if (c2 < 32 || NILP (XCHAR_TABLE (elt)->contents[c2]))
2561 return XCHAR_TABLE (elt)->defalt;
2562 *idx = c;
2563 return XCHAR_TABLE (elt)->contents[c2];
2567 /* ARGSUSED */
2568 Lisp_Object
2569 nconc2 (s1, s2)
2570 Lisp_Object s1, s2;
2572 #ifdef NO_ARG_ARRAY
2573 Lisp_Object args[2];
2574 args[0] = s1;
2575 args[1] = s2;
2576 return Fnconc (2, args);
2577 #else
2578 return Fnconc (2, &s1);
2579 #endif /* NO_ARG_ARRAY */
2582 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2583 "Concatenate any number of lists by altering them.\n\
2584 Only the last argument is not altered, and need not be a list.")
2585 (nargs, args)
2586 int nargs;
2587 Lisp_Object *args;
2589 register int argnum;
2590 register Lisp_Object tail, tem, val;
2592 val = tail = Qnil;
2594 for (argnum = 0; argnum < nargs; argnum++)
2596 tem = args[argnum];
2597 if (NILP (tem)) continue;
2599 if (NILP (val))
2600 val = tem;
2602 if (argnum + 1 == nargs) break;
2604 if (!CONSP (tem))
2605 tem = wrong_type_argument (Qlistp, tem);
2607 while (CONSP (tem))
2609 tail = tem;
2610 tem = Fcdr (tail);
2611 QUIT;
2614 tem = args[argnum + 1];
2615 Fsetcdr (tail, tem);
2616 if (NILP (tem))
2617 args[argnum + 1] = tail;
2620 return val;
2623 /* This is the guts of all mapping functions.
2624 Apply FN to each element of SEQ, one by one,
2625 storing the results into elements of VALS, a C vector of Lisp_Objects.
2626 LENI is the length of VALS, which should also be the length of SEQ. */
2628 static void
2629 mapcar1 (leni, vals, fn, seq)
2630 int leni;
2631 Lisp_Object *vals;
2632 Lisp_Object fn, seq;
2634 register Lisp_Object tail;
2635 Lisp_Object dummy;
2636 register int i;
2637 struct gcpro gcpro1, gcpro2, gcpro3;
2639 if (vals)
2641 /* Don't let vals contain any garbage when GC happens. */
2642 for (i = 0; i < leni; i++)
2643 vals[i] = Qnil;
2645 GCPRO3 (dummy, fn, seq);
2646 gcpro1.var = vals;
2647 gcpro1.nvars = leni;
2649 else
2650 GCPRO2 (fn, seq);
2651 /* We need not explicitly protect `tail' because it is used only on lists, and
2652 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2654 if (VECTORP (seq))
2656 for (i = 0; i < leni; i++)
2658 dummy = XVECTOR (seq)->contents[i];
2659 dummy = call1 (fn, dummy);
2660 if (vals)
2661 vals[i] = dummy;
2664 else if (BOOL_VECTOR_P (seq))
2666 for (i = 0; i < leni; i++)
2668 int byte;
2669 byte = XBOOL_VECTOR (seq)->data[i / BITS_PER_CHAR];
2670 if (byte & (1 << (i % BITS_PER_CHAR)))
2671 dummy = Qt;
2672 else
2673 dummy = Qnil;
2675 dummy = call1 (fn, dummy);
2676 if (vals)
2677 vals[i] = dummy;
2680 else if (STRINGP (seq))
2682 int i_byte;
2684 for (i = 0, i_byte = 0; i < leni;)
2686 int c;
2687 int i_before = i;
2689 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2690 XSETFASTINT (dummy, c);
2691 dummy = call1 (fn, dummy);
2692 if (vals)
2693 vals[i_before] = dummy;
2696 else /* Must be a list, since Flength did not get an error */
2698 tail = seq;
2699 for (i = 0; i < leni; i++)
2701 dummy = call1 (fn, Fcar (tail));
2702 if (vals)
2703 vals[i] = dummy;
2704 tail = XCDR (tail);
2708 UNGCPRO;
2711 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2712 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2713 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2714 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2715 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2716 (function, sequence, separator)
2717 Lisp_Object function, sequence, separator;
2719 Lisp_Object len;
2720 register int leni;
2721 int nargs;
2722 register Lisp_Object *args;
2723 register int i;
2724 struct gcpro gcpro1;
2726 len = Flength (sequence);
2727 leni = XINT (len);
2728 nargs = leni + leni - 1;
2729 if (nargs < 0) return build_string ("");
2731 args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
2733 GCPRO1 (separator);
2734 mapcar1 (leni, args, function, sequence);
2735 UNGCPRO;
2737 for (i = leni - 1; i >= 0; i--)
2738 args[i + i] = args[i];
2740 for (i = 1; i < nargs; i += 2)
2741 args[i] = separator;
2743 return Fconcat (nargs, args);
2746 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2747 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2748 The result is a list just as long as SEQUENCE.\n\
2749 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2750 (function, sequence)
2751 Lisp_Object function, sequence;
2753 register Lisp_Object len;
2754 register int leni;
2755 register Lisp_Object *args;
2757 len = Flength (sequence);
2758 leni = XFASTINT (len);
2759 args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
2761 mapcar1 (leni, args, function, sequence);
2763 return Flist (leni, args);
2766 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2767 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2768 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2769 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2770 (function, sequence)
2771 Lisp_Object function, sequence;
2773 register int leni;
2775 leni = XFASTINT (Flength (sequence));
2776 mapcar1 (leni, 0, function, sequence);
2778 return sequence;
2781 /* Anything that calls this function must protect from GC! */
2783 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
2784 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2785 Takes one argument, which is the string to display to ask the question.\n\
2786 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2787 No confirmation of the answer is requested; a single character is enough.\n\
2788 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2789 the bindings in `query-replace-map'; see the documentation of that variable\n\
2790 for more information. In this case, the useful bindings are `act', `skip',\n\
2791 `recenter', and `quit'.\)\n\
2793 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2794 is nil and `use-dialog-box' is non-nil.")
2795 (prompt)
2796 Lisp_Object prompt;
2798 register Lisp_Object obj, key, def, map;
2799 register int answer;
2800 Lisp_Object xprompt;
2801 Lisp_Object args[2];
2802 struct gcpro gcpro1, gcpro2;
2803 int count = specpdl_ptr - specpdl;
2805 specbind (Qcursor_in_echo_area, Qt);
2807 map = Fsymbol_value (intern ("query-replace-map"));
2809 CHECK_STRING (prompt, 0);
2810 xprompt = prompt;
2811 GCPRO2 (prompt, xprompt);
2813 #ifdef HAVE_X_WINDOWS
2814 if (display_busy_cursor_p)
2815 cancel_busy_cursor ();
2816 #endif
2818 while (1)
2821 #ifdef HAVE_MENUS
2822 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2823 && use_dialog_box
2824 && have_menus_p ())
2826 Lisp_Object pane, menu;
2827 redisplay_preserve_echo_area (3);
2828 pane = Fcons (Fcons (build_string ("Yes"), Qt),
2829 Fcons (Fcons (build_string ("No"), Qnil),
2830 Qnil));
2831 menu = Fcons (prompt, pane);
2832 obj = Fx_popup_dialog (Qt, menu);
2833 answer = !NILP (obj);
2834 break;
2836 #endif /* HAVE_MENUS */
2837 cursor_in_echo_area = 1;
2838 choose_minibuf_frame ();
2839 message_with_string ("%s(y or n) ", xprompt, 0);
2841 if (minibuffer_auto_raise)
2843 Lisp_Object mini_frame;
2845 mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
2847 Fraise_frame (mini_frame);
2850 obj = read_filtered_event (1, 0, 0, 0);
2851 cursor_in_echo_area = 0;
2852 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2853 QUIT;
2855 key = Fmake_vector (make_number (1), obj);
2856 def = Flookup_key (map, key, Qt);
2858 if (EQ (def, intern ("skip")))
2860 answer = 0;
2861 break;
2863 else if (EQ (def, intern ("act")))
2865 answer = 1;
2866 break;
2868 else if (EQ (def, intern ("recenter")))
2870 Frecenter (Qnil);
2871 xprompt = prompt;
2872 continue;
2874 else if (EQ (def, intern ("quit")))
2875 Vquit_flag = Qt;
2876 /* We want to exit this command for exit-prefix,
2877 and this is the only way to do it. */
2878 else if (EQ (def, intern ("exit-prefix")))
2879 Vquit_flag = Qt;
2881 QUIT;
2883 /* If we don't clear this, then the next call to read_char will
2884 return quit_char again, and we'll enter an infinite loop. */
2885 Vquit_flag = Qnil;
2887 Fding (Qnil);
2888 Fdiscard_input ();
2889 if (EQ (xprompt, prompt))
2891 args[0] = build_string ("Please answer y or n. ");
2892 args[1] = prompt;
2893 xprompt = Fconcat (2, args);
2896 UNGCPRO;
2898 if (! noninteractive)
2900 cursor_in_echo_area = -1;
2901 message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n",
2902 xprompt, 0);
2905 unbind_to (count, Qnil);
2906 return answer ? Qt : Qnil;
2909 /* This is how C code calls `yes-or-no-p' and allows the user
2910 to redefined it.
2912 Anything that calls this function must protect from GC! */
2914 Lisp_Object
2915 do_yes_or_no_p (prompt)
2916 Lisp_Object prompt;
2918 return call1 (intern ("yes-or-no-p"), prompt);
2921 /* Anything that calls this function must protect from GC! */
2923 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2924 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2925 Takes one argument, which is the string to display to ask the question.\n\
2926 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2927 The user must confirm the answer with RET,\n\
2928 and can edit it until it has been confirmed.\n\
2930 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2931 is nil, and `use-dialog-box' is non-nil.")
2932 (prompt)
2933 Lisp_Object prompt;
2935 register Lisp_Object ans;
2936 Lisp_Object args[2];
2937 struct gcpro gcpro1;
2939 CHECK_STRING (prompt, 0);
2941 #ifdef HAVE_MENUS
2942 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2943 && use_dialog_box
2944 && have_menus_p ())
2946 Lisp_Object pane, menu, obj;
2947 redisplay_preserve_echo_area (4);
2948 pane = Fcons (Fcons (build_string ("Yes"), Qt),
2949 Fcons (Fcons (build_string ("No"), Qnil),
2950 Qnil));
2951 GCPRO1 (pane);
2952 menu = Fcons (prompt, pane);
2953 obj = Fx_popup_dialog (Qt, menu);
2954 UNGCPRO;
2955 return obj;
2957 #endif /* HAVE_MENUS */
2959 args[0] = prompt;
2960 args[1] = build_string ("(yes or no) ");
2961 prompt = Fconcat (2, args);
2963 GCPRO1 (prompt);
2965 while (1)
2967 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2968 Qyes_or_no_p_history, Qnil,
2969 Qnil));
2970 if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
2972 UNGCPRO;
2973 return Qt;
2975 if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
2977 UNGCPRO;
2978 return Qnil;
2981 Fding (Qnil);
2982 Fdiscard_input ();
2983 message ("Please answer yes or no.");
2984 Fsleep_for (make_number (2), Qnil);
2988 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2989 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2990 Each of the three load averages is multiplied by 100,\n\
2991 then converted to integer.\n\
2992 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2993 These floats are not multiplied by 100.\n\n\
2994 If the 5-minute or 15-minute load averages are not available, return a\n\
2995 shortened list, containing only those averages which are available.")
2996 (use_floats)
2997 Lisp_Object use_floats;
2999 double load_ave[3];
3000 int loads = getloadavg (load_ave, 3);
3001 Lisp_Object ret = Qnil;
3003 if (loads < 0)
3004 error ("load-average not implemented for this operating system");
3006 while (loads-- > 0)
3008 Lisp_Object load = (NILP (use_floats) ?
3009 make_number ((int) (100.0 * load_ave[loads]))
3010 : make_float (load_ave[loads]));
3011 ret = Fcons (load, ret);
3014 return ret;
3017 Lisp_Object Vfeatures;
3019 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
3020 "Returns t if FEATURE is present in this Emacs.\n\
3021 Use this to conditionalize execution of lisp code based on the presence or\n\
3022 absence of emacs or environment extensions.\n\
3023 Use `provide' to declare that a feature is available.\n\
3024 This function looks at the value of the variable `features'.")
3025 (feature)
3026 Lisp_Object feature;
3028 register Lisp_Object tem;
3029 CHECK_SYMBOL (feature, 0);
3030 tem = Fmemq (feature, Vfeatures);
3031 return (NILP (tem)) ? Qnil : Qt;
3034 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
3035 "Announce that FEATURE is a feature of the current Emacs.")
3036 (feature)
3037 Lisp_Object feature;
3039 register Lisp_Object tem;
3040 CHECK_SYMBOL (feature, 0);
3041 if (!NILP (Vautoload_queue))
3042 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3043 tem = Fmemq (feature, Vfeatures);
3044 if (NILP (tem))
3045 Vfeatures = Fcons (feature, Vfeatures);
3046 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3047 return feature;
3050 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
3051 "If feature FEATURE is not loaded, load it from FILENAME.\n\
3052 If FEATURE is not a member of the list `features', then the feature\n\
3053 is not loaded; so load the file FILENAME.\n\
3054 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
3055 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
3056 If the optional third argument NOERROR is non-nil,\n\
3057 then return nil if the file is not found.\n\
3058 Normally the return value is FEATURE.\n\
3059 This normal messages at start and end of loading FILENAME are suppressed.")
3060 (feature, file_name, noerror)
3061 Lisp_Object feature, file_name, noerror;
3063 register Lisp_Object tem;
3064 CHECK_SYMBOL (feature, 0);
3065 tem = Fmemq (feature, Vfeatures);
3067 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3069 if (NILP (tem))
3071 int count = specpdl_ptr - specpdl;
3073 /* Value saved here is to be restored into Vautoload_queue */
3074 record_unwind_protect (un_autoload, Vautoload_queue);
3075 Vautoload_queue = Qt;
3077 tem = Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
3078 noerror, Qt, Qnil, (NILP (file_name) ? Qt : Qnil));
3079 /* If load failed entirely, return nil. */
3080 if (NILP (tem))
3081 return unbind_to (count, Qnil);
3083 tem = Fmemq (feature, Vfeatures);
3084 if (NILP (tem))
3085 error ("Required feature %s was not provided",
3086 XSYMBOL (feature)->name->data);
3088 /* Once loading finishes, don't undo it. */
3089 Vautoload_queue = Qt;
3090 feature = unbind_to (count, feature);
3092 return feature;
3095 /* Primitives for work of the "widget" library.
3096 In an ideal world, this section would not have been necessary.
3097 However, lisp function calls being as slow as they are, it turns
3098 out that some functions in the widget library (wid-edit.el) are the
3099 bottleneck of Widget operation. Here is their translation to C,
3100 for the sole reason of efficiency. */
3102 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
3103 "Return non-nil if PLIST has the property PROP.\n\
3104 PLIST is a property list, which is a list of the form\n\
3105 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
3106 Unlike `plist-get', this allows you to distinguish between a missing\n\
3107 property and a property with the value nil.\n\
3108 The value is actually the tail of PLIST whose car is PROP.")
3109 (plist, prop)
3110 Lisp_Object plist, prop;
3112 while (CONSP (plist) && !EQ (XCAR (plist), prop))
3114 QUIT;
3115 plist = XCDR (plist);
3116 plist = CDR (plist);
3118 return plist;
3121 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
3122 "In WIDGET, set PROPERTY to VALUE.\n\
3123 The value can later be retrieved with `widget-get'.")
3124 (widget, property, value)
3125 Lisp_Object widget, property, value;
3127 CHECK_CONS (widget, 1);
3128 XCDR (widget) = Fplist_put (XCDR (widget), property, value);
3129 return value;
3132 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
3133 "In WIDGET, get the value of PROPERTY.\n\
3134 The value could either be specified when the widget was created, or\n\
3135 later with `widget-put'.")
3136 (widget, property)
3137 Lisp_Object widget, property;
3139 Lisp_Object tmp;
3141 while (1)
3143 if (NILP (widget))
3144 return Qnil;
3145 CHECK_CONS (widget, 1);
3146 tmp = Fplist_member (XCDR (widget), property);
3147 if (CONSP (tmp))
3149 tmp = XCDR (tmp);
3150 return CAR (tmp);
3152 tmp = XCAR (widget);
3153 if (NILP (tmp))
3154 return Qnil;
3155 widget = Fget (tmp, Qwidget_type);
3159 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
3160 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3161 ARGS are passed as extra arguments to the function.")
3162 (nargs, args)
3163 int nargs;
3164 Lisp_Object *args;
3166 /* This function can GC. */
3167 Lisp_Object newargs[3];
3168 struct gcpro gcpro1, gcpro2;
3169 Lisp_Object result;
3171 newargs[0] = Fwidget_get (args[0], args[1]);
3172 newargs[1] = args[0];
3173 newargs[2] = Flist (nargs - 2, args + 2);
3174 GCPRO2 (newargs[0], newargs[2]);
3175 result = Fapply (3, newargs);
3176 UNGCPRO;
3177 return result;
3180 /* base64 encode/decode functions (RFC 2045).
3181 Based on code from GNU recode. */
3183 #define MIME_LINE_LENGTH 76
3185 #define IS_ASCII(Character) \
3186 ((Character) < 128)
3187 #define IS_BASE64(Character) \
3188 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3189 #define IS_BASE64_IGNORABLE(Character) \
3190 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3191 || (Character) == '\f' || (Character) == '\r')
3193 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3194 character or return retval if there are no characters left to
3195 process. */
3196 #define READ_QUADRUPLET_BYTE(retval) \
3197 do \
3199 if (i == length) \
3201 if (nchars_return) \
3202 *nchars_return = nchars; \
3203 return (retval); \
3205 c = from[i++]; \
3207 while (IS_BASE64_IGNORABLE (c))
3209 /* Don't use alloca for regions larger than this, lest we overflow
3210 their stack. */
3211 #define MAX_ALLOCA 16*1024
3213 /* Table of characters coding the 64 values. */
3214 static char base64_value_to_char[64] =
3216 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3217 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3218 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3219 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3220 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3221 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3222 '8', '9', '+', '/' /* 60-63 */
3225 /* Table of base64 values for first 128 characters. */
3226 static short base64_char_to_value[128] =
3228 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3229 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3230 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3231 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3232 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3233 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3234 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3235 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3236 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3237 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3238 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3239 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3240 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3243 /* The following diagram shows the logical steps by which three octets
3244 get transformed into four base64 characters.
3246 .--------. .--------. .--------.
3247 |aaaaaabb| |bbbbcccc| |ccdddddd|
3248 `--------' `--------' `--------'
3249 6 2 4 4 2 6
3250 .--------+--------+--------+--------.
3251 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3252 `--------+--------+--------+--------'
3254 .--------+--------+--------+--------.
3255 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3256 `--------+--------+--------+--------'
3258 The octets are divided into 6 bit chunks, which are then encoded into
3259 base64 characters. */
3262 static int base64_encode_1 P_ ((const char *, char *, int, int, int));
3263 static int base64_decode_1 P_ ((const char *, char *, int, int, int *));
3265 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3266 2, 3, "r",
3267 "Base64-encode the region between BEG and END.\n\
3268 Return the length of the encoded text.\n\
3269 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3270 into shorter lines.")
3271 (beg, end, no_line_break)
3272 Lisp_Object beg, end, no_line_break;
3274 char *encoded;
3275 int allength, length;
3276 int ibeg, iend, encoded_length;
3277 int old_pos = PT;
3279 validate_region (&beg, &end);
3281 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3282 iend = CHAR_TO_BYTE (XFASTINT (end));
3283 move_gap_both (XFASTINT (beg), ibeg);
3285 /* We need to allocate enough room for encoding the text.
3286 We need 33 1/3% more space, plus a newline every 76
3287 characters, and then we round up. */
3288 length = iend - ibeg;
3289 allength = length + length/3 + 1;
3290 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3292 if (allength <= MAX_ALLOCA)
3293 encoded = (char *) alloca (allength);
3294 else
3295 encoded = (char *) xmalloc (allength);
3296 encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
3297 NILP (no_line_break),
3298 !NILP (current_buffer->enable_multibyte_characters));
3299 if (encoded_length > allength)
3300 abort ();
3302 if (encoded_length < 0)
3304 /* The encoding wasn't possible. */
3305 if (length > MAX_ALLOCA)
3306 xfree (encoded);
3307 error ("Multibyte character in data for base64 encoding");
3310 /* Now we have encoded the region, so we insert the new contents
3311 and delete the old. (Insert first in order to preserve markers.) */
3312 SET_PT_BOTH (XFASTINT (beg), ibeg);
3313 insert (encoded, encoded_length);
3314 if (allength > MAX_ALLOCA)
3315 xfree (encoded);
3316 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3318 /* If point was outside of the region, restore it exactly; else just
3319 move to the beginning of the region. */
3320 if (old_pos >= XFASTINT (end))
3321 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3322 else if (old_pos > XFASTINT (beg))
3323 old_pos = XFASTINT (beg);
3324 SET_PT (old_pos);
3326 /* We return the length of the encoded text. */
3327 return make_number (encoded_length);
3330 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3331 1, 2, 0,
3332 "Base64-encode STRING and return the result.\n\
3333 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3334 into shorter lines.")
3335 (string, no_line_break)
3336 Lisp_Object string, no_line_break;
3338 int allength, length, encoded_length;
3339 char *encoded;
3340 Lisp_Object encoded_string;
3342 CHECK_STRING (string, 1);
3344 /* We need to allocate enough room for encoding the text.
3345 We need 33 1/3% more space, plus a newline every 76
3346 characters, and then we round up. */
3347 length = STRING_BYTES (XSTRING (string));
3348 allength = length + length/3 + 1;
3349 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3351 /* We need to allocate enough room for decoding the text. */
3352 if (allength <= MAX_ALLOCA)
3353 encoded = (char *) alloca (allength);
3354 else
3355 encoded = (char *) xmalloc (allength);
3357 encoded_length = base64_encode_1 (XSTRING (string)->data,
3358 encoded, length, NILP (no_line_break),
3359 STRING_MULTIBYTE (string));
3360 if (encoded_length > allength)
3361 abort ();
3363 if (encoded_length < 0)
3365 /* The encoding wasn't possible. */
3366 if (length > MAX_ALLOCA)
3367 xfree (encoded);
3368 error ("Multibyte character in data for base64 encoding");
3371 encoded_string = make_unibyte_string (encoded, encoded_length);
3372 if (allength > MAX_ALLOCA)
3373 xfree (encoded);
3375 return encoded_string;
3378 static int
3379 base64_encode_1 (from, to, length, line_break, multibyte)
3380 const char *from;
3381 char *to;
3382 int length;
3383 int line_break;
3384 int multibyte;
3386 int counter = 0, i = 0;
3387 char *e = to;
3388 int c;
3389 unsigned int value;
3390 int bytes;
3392 while (i < length)
3394 if (multibyte)
3396 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3397 if (c >= 256)
3398 return -1;
3399 i += bytes;
3401 else
3402 c = from[i++];
3404 /* Wrap line every 76 characters. */
3406 if (line_break)
3408 if (counter < MIME_LINE_LENGTH / 4)
3409 counter++;
3410 else
3412 *e++ = '\n';
3413 counter = 1;
3417 /* Process first byte of a triplet. */
3419 *e++ = base64_value_to_char[0x3f & c >> 2];
3420 value = (0x03 & c) << 4;
3422 /* Process second byte of a triplet. */
3424 if (i == length)
3426 *e++ = base64_value_to_char[value];
3427 *e++ = '=';
3428 *e++ = '=';
3429 break;
3432 if (multibyte)
3434 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3435 if (c >= 256)
3436 return -1;
3437 i += bytes;
3439 else
3440 c = from[i++];
3442 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3443 value = (0x0f & c) << 2;
3445 /* Process third byte of a triplet. */
3447 if (i == length)
3449 *e++ = base64_value_to_char[value];
3450 *e++ = '=';
3451 break;
3454 if (multibyte)
3456 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3457 if (c >= 256)
3458 return -1;
3459 i += bytes;
3461 else
3462 c = from[i++];
3464 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3465 *e++ = base64_value_to_char[0x3f & c];
3468 return e - to;
3472 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3473 2, 2, "r",
3474 "Base64-decode the region between BEG and END.\n\
3475 Return the length of the decoded text.\n\
3476 If the region can't be decoded, signal an error and don't modify the buffer.")
3477 (beg, end)
3478 Lisp_Object beg, end;
3480 int ibeg, iend, length, allength;
3481 char *decoded;
3482 int old_pos = PT;
3483 int decoded_length;
3484 int inserted_chars;
3485 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
3487 validate_region (&beg, &end);
3489 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3490 iend = CHAR_TO_BYTE (XFASTINT (end));
3492 length = iend - ibeg;
3494 /* We need to allocate enough room for decoding the text. If we are
3495 working on a multibyte buffer, each decoded code may occupy at
3496 most two bytes. */
3497 allength = multibyte ? length * 2 : length;
3498 if (allength <= MAX_ALLOCA)
3499 decoded = (char *) alloca (allength);
3500 else
3501 decoded = (char *) xmalloc (allength);
3503 move_gap_both (XFASTINT (beg), ibeg);
3504 decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
3505 multibyte, &inserted_chars);
3506 if (decoded_length > allength)
3507 abort ();
3509 if (decoded_length < 0)
3511 /* The decoding wasn't possible. */
3512 if (allength > MAX_ALLOCA)
3513 xfree (decoded);
3514 error ("Invalid base64 data");
3517 /* Now we have decoded the region, so we insert the new contents
3518 and delete the old. (Insert first in order to preserve markers.) */
3519 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3520 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3521 if (allength > MAX_ALLOCA)
3522 xfree (decoded);
3523 /* Delete the original text. */
3524 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3525 iend + decoded_length, 1);
3527 /* If point was outside of the region, restore it exactly; else just
3528 move to the beginning of the region. */
3529 if (old_pos >= XFASTINT (end))
3530 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3531 else if (old_pos > XFASTINT (beg))
3532 old_pos = XFASTINT (beg);
3533 SET_PT (old_pos > ZV ? ZV : old_pos);
3535 return make_number (inserted_chars);
3538 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3539 1, 1, 0,
3540 "Base64-decode STRING and return the result.")
3541 (string)
3542 Lisp_Object string;
3544 char *decoded;
3545 int length, decoded_length;
3546 Lisp_Object decoded_string;
3548 CHECK_STRING (string, 1);
3550 length = STRING_BYTES (XSTRING (string));
3551 /* We need to allocate enough room for decoding the text. */
3552 if (length <= MAX_ALLOCA)
3553 decoded = (char *) alloca (length);
3554 else
3555 decoded = (char *) xmalloc (length);
3557 /* The decoded result should be unibyte. */
3558 decoded_length = base64_decode_1 (XSTRING (string)->data, decoded, length,
3559 0, NULL);
3560 if (decoded_length > length)
3561 abort ();
3562 else if (decoded_length >= 0)
3563 decoded_string = make_unibyte_string (decoded, decoded_length);
3564 else
3565 decoded_string = Qnil;
3567 if (length > MAX_ALLOCA)
3568 xfree (decoded);
3569 if (!STRINGP (decoded_string))
3570 error ("Invalid base64 data");
3572 return decoded_string;
3575 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3576 MULTIBYTE is nonzero, the decoded result should be in multibyte
3577 form. If NCHARS_RETRUN is not NULL, store the number of produced
3578 characters in *NCHARS_RETURN. */
3580 static int
3581 base64_decode_1 (from, to, length, multibyte, nchars_return)
3582 const char *from;
3583 char *to;
3584 int length;
3585 int multibyte;
3586 int *nchars_return;
3588 int i = 0;
3589 char *e = to;
3590 unsigned char c;
3591 unsigned long value;
3592 int nchars = 0;
3594 while (1)
3596 /* Process first byte of a quadruplet. */
3598 READ_QUADRUPLET_BYTE (e-to);
3600 if (!IS_BASE64 (c))
3601 return -1;
3602 value = base64_char_to_value[c] << 18;
3604 /* Process second byte of a quadruplet. */
3606 READ_QUADRUPLET_BYTE (-1);
3608 if (!IS_BASE64 (c))
3609 return -1;
3610 value |= base64_char_to_value[c] << 12;
3612 c = (unsigned char) (value >> 16);
3613 if (multibyte)
3614 e += CHAR_STRING (c, e);
3615 else
3616 *e++ = c;
3617 nchars++;
3619 /* Process third byte of a quadruplet. */
3621 READ_QUADRUPLET_BYTE (-1);
3623 if (c == '=')
3625 READ_QUADRUPLET_BYTE (-1);
3627 if (c != '=')
3628 return -1;
3629 continue;
3632 if (!IS_BASE64 (c))
3633 return -1;
3634 value |= base64_char_to_value[c] << 6;
3636 c = (unsigned char) (0xff & value >> 8);
3637 if (multibyte)
3638 e += CHAR_STRING (c, e);
3639 else
3640 *e++ = c;
3641 nchars++;
3643 /* Process fourth byte of a quadruplet. */
3645 READ_QUADRUPLET_BYTE (-1);
3647 if (c == '=')
3648 continue;
3650 if (!IS_BASE64 (c))
3651 return -1;
3652 value |= base64_char_to_value[c];
3654 c = (unsigned char) (0xff & value);
3655 if (multibyte)
3656 e += CHAR_STRING (c, e);
3657 else
3658 *e++ = c;
3659 nchars++;
3665 /***********************************************************************
3666 ***** *****
3667 ***** Hash Tables *****
3668 ***** *****
3669 ***********************************************************************/
3671 /* Implemented by gerd@gnu.org. This hash table implementation was
3672 inspired by CMUCL hash tables. */
3674 /* Ideas:
3676 1. For small tables, association lists are probably faster than
3677 hash tables because they have lower overhead.
3679 For uses of hash tables where the O(1) behavior of table
3680 operations is not a requirement, it might therefore be a good idea
3681 not to hash. Instead, we could just do a linear search in the
3682 key_and_value vector of the hash table. This could be done
3683 if a `:linear-search t' argument is given to make-hash-table. */
3686 /* Value is the key part of entry IDX in hash table H. */
3688 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3690 /* Value is the value part of entry IDX in hash table H. */
3692 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3694 /* Value is the index of the next entry following the one at IDX
3695 in hash table H. */
3697 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3699 /* Value is the hash code computed for entry IDX in hash table H. */
3701 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3703 /* Value is the index of the element in hash table H that is the
3704 start of the collision list at index IDX in the index vector of H. */
3706 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3708 /* Value is the size of hash table H. */
3710 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3712 /* The list of all weak hash tables. Don't staticpro this one. */
3714 Lisp_Object Vweak_hash_tables;
3716 /* Various symbols. */
3718 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
3719 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
3720 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
3722 /* Function prototypes. */
3724 static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object));
3725 static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *));
3726 static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *));
3727 static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3728 Lisp_Object, unsigned));
3729 static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3730 Lisp_Object, unsigned));
3731 static int cmpfn_user_defined P_ ((struct Lisp_Hash_Table *, Lisp_Object,
3732 unsigned, Lisp_Object, unsigned));
3733 static unsigned hashfn_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3734 static unsigned hashfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3735 static unsigned hashfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3736 static unsigned hashfn_user_defined P_ ((struct Lisp_Hash_Table *,
3737 Lisp_Object));
3738 static unsigned sxhash_string P_ ((unsigned char *, int));
3739 static unsigned sxhash_list P_ ((Lisp_Object, int));
3740 static unsigned sxhash_vector P_ ((Lisp_Object, int));
3741 static unsigned sxhash_bool_vector P_ ((Lisp_Object));
3742 static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int));
3746 /***********************************************************************
3747 Utilities
3748 ***********************************************************************/
3750 /* If OBJ is a Lisp hash table, return a pointer to its struct
3751 Lisp_Hash_Table. Otherwise, signal an error. */
3753 static struct Lisp_Hash_Table *
3754 check_hash_table (obj)
3755 Lisp_Object obj;
3757 CHECK_HASH_TABLE (obj, 0);
3758 return XHASH_TABLE (obj);
3762 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3763 number. */
3766 next_almost_prime (n)
3767 int n;
3769 if (n % 2 == 0)
3770 n += 1;
3771 if (n % 3 == 0)
3772 n += 2;
3773 if (n % 7 == 0)
3774 n += 4;
3775 return n;
3779 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3780 which USED[I] is non-zero. If found at index I in ARGS, set
3781 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3782 -1. This function is used to extract a keyword/argument pair from
3783 a DEFUN parameter list. */
3785 static int
3786 get_key_arg (key, nargs, args, used)
3787 Lisp_Object key;
3788 int nargs;
3789 Lisp_Object *args;
3790 char *used;
3792 int i;
3794 for (i = 0; i < nargs - 1; ++i)
3795 if (!used[i] && EQ (args[i], key))
3796 break;
3798 if (i >= nargs - 1)
3799 i = -1;
3800 else
3802 used[i++] = 1;
3803 used[i] = 1;
3806 return i;
3810 /* Return a Lisp vector which has the same contents as VEC but has
3811 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3812 vector that are not copied from VEC are set to INIT. */
3814 Lisp_Object
3815 larger_vector (vec, new_size, init)
3816 Lisp_Object vec;
3817 int new_size;
3818 Lisp_Object init;
3820 struct Lisp_Vector *v;
3821 int i, old_size;
3823 xassert (VECTORP (vec));
3824 old_size = XVECTOR (vec)->size;
3825 xassert (new_size >= old_size);
3827 v = allocate_vectorlike (new_size);
3828 v->size = new_size;
3829 bcopy (XVECTOR (vec)->contents, v->contents,
3830 old_size * sizeof *v->contents);
3831 for (i = old_size; i < new_size; ++i)
3832 v->contents[i] = init;
3833 XSETVECTOR (vec, v);
3834 return vec;
3838 /***********************************************************************
3839 Low-level Functions
3840 ***********************************************************************/
3842 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3843 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3844 KEY2 are the same. */
3846 static int
3847 cmpfn_eql (h, key1, hash1, key2, hash2)
3848 struct Lisp_Hash_Table *h;
3849 Lisp_Object key1, key2;
3850 unsigned hash1, hash2;
3852 return (FLOATP (key1)
3853 && FLOATP (key2)
3854 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3858 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3859 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3860 KEY2 are the same. */
3862 static int
3863 cmpfn_equal (h, key1, hash1, key2, hash2)
3864 struct Lisp_Hash_Table *h;
3865 Lisp_Object key1, key2;
3866 unsigned hash1, hash2;
3868 return hash1 == hash2 && !NILP (Fequal (key1, key2));
3872 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3873 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3874 if KEY1 and KEY2 are the same. */
3876 static int
3877 cmpfn_user_defined (h, key1, hash1, key2, hash2)
3878 struct Lisp_Hash_Table *h;
3879 Lisp_Object key1, key2;
3880 unsigned hash1, hash2;
3882 if (hash1 == hash2)
3884 Lisp_Object args[3];
3886 args[0] = h->user_cmp_function;
3887 args[1] = key1;
3888 args[2] = key2;
3889 return !NILP (Ffuncall (3, args));
3891 else
3892 return 0;
3896 /* Value is a hash code for KEY for use in hash table H which uses
3897 `eq' to compare keys. The hash code returned is guaranteed to fit
3898 in a Lisp integer. */
3900 static unsigned
3901 hashfn_eq (h, key)
3902 struct Lisp_Hash_Table *h;
3903 Lisp_Object key;
3905 unsigned hash = XUINT (key) ^ XGCTYPE (key);
3906 xassert ((hash & ~VALMASK) == 0);
3907 return hash;
3911 /* Value is a hash code for KEY for use in hash table H which uses
3912 `eql' to compare keys. The hash code returned is guaranteed to fit
3913 in a Lisp integer. */
3915 static unsigned
3916 hashfn_eql (h, key)
3917 struct Lisp_Hash_Table *h;
3918 Lisp_Object key;
3920 unsigned hash;
3921 if (FLOATP (key))
3922 hash = sxhash (key, 0);
3923 else
3924 hash = XUINT (key) ^ XGCTYPE (key);
3925 xassert ((hash & ~VALMASK) == 0);
3926 return hash;
3930 /* Value is a hash code for KEY for use in hash table H which uses
3931 `equal' to compare keys. The hash code returned is guaranteed to fit
3932 in a Lisp integer. */
3934 static unsigned
3935 hashfn_equal (h, key)
3936 struct Lisp_Hash_Table *h;
3937 Lisp_Object key;
3939 unsigned hash = sxhash (key, 0);
3940 xassert ((hash & ~VALMASK) == 0);
3941 return hash;
3945 /* Value is a hash code for KEY for use in hash table H which uses as
3946 user-defined function to compare keys. The hash code returned is
3947 guaranteed to fit in a Lisp integer. */
3949 static unsigned
3950 hashfn_user_defined (h, key)
3951 struct Lisp_Hash_Table *h;
3952 Lisp_Object key;
3954 Lisp_Object args[2], hash;
3956 args[0] = h->user_hash_function;
3957 args[1] = key;
3958 hash = Ffuncall (2, args);
3959 if (!INTEGERP (hash))
3960 Fsignal (Qerror,
3961 list2 (build_string ("Invalid hash code returned from \
3962 user-supplied hash function"),
3963 hash));
3964 return XUINT (hash);
3968 /* Create and initialize a new hash table.
3970 TEST specifies the test the hash table will use to compare keys.
3971 It must be either one of the predefined tests `eq', `eql' or
3972 `equal' or a symbol denoting a user-defined test named TEST with
3973 test and hash functions USER_TEST and USER_HASH.
3975 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3977 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3978 new size when it becomes full is computed by adding REHASH_SIZE to
3979 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3980 table's new size is computed by multiplying its old size with
3981 REHASH_SIZE.
3983 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3984 be resized when the ratio of (number of entries in the table) /
3985 (table size) is >= REHASH_THRESHOLD.
3987 WEAK specifies the weakness of the table. If non-nil, it must be
3988 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3990 Lisp_Object
3991 make_hash_table (test, size, rehash_size, rehash_threshold, weak,
3992 user_test, user_hash)
3993 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
3994 Lisp_Object user_test, user_hash;
3996 struct Lisp_Hash_Table *h;
3997 struct Lisp_Vector *v;
3998 Lisp_Object table;
3999 int index_size, i, len, sz;
4001 /* Preconditions. */
4002 xassert (SYMBOLP (test));
4003 xassert (INTEGERP (size) && XINT (size) >= 0);
4004 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
4005 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
4006 xassert (FLOATP (rehash_threshold)
4007 && XFLOATINT (rehash_threshold) > 0
4008 && XFLOATINT (rehash_threshold) <= 1.0);
4010 if (XFASTINT (size) == 0)
4011 size = make_number (1);
4013 /* Allocate a vector, and initialize it. */
4014 len = VECSIZE (struct Lisp_Hash_Table);
4015 v = allocate_vectorlike (len);
4016 v->size = len;
4017 for (i = 0; i < len; ++i)
4018 v->contents[i] = Qnil;
4020 /* Initialize hash table slots. */
4021 sz = XFASTINT (size);
4022 h = (struct Lisp_Hash_Table *) v;
4024 h->test = test;
4025 if (EQ (test, Qeql))
4027 h->cmpfn = cmpfn_eql;
4028 h->hashfn = hashfn_eql;
4030 else if (EQ (test, Qeq))
4032 h->cmpfn = NULL;
4033 h->hashfn = hashfn_eq;
4035 else if (EQ (test, Qequal))
4037 h->cmpfn = cmpfn_equal;
4038 h->hashfn = hashfn_equal;
4040 else
4042 h->user_cmp_function = user_test;
4043 h->user_hash_function = user_hash;
4044 h->cmpfn = cmpfn_user_defined;
4045 h->hashfn = hashfn_user_defined;
4048 h->weak = weak;
4049 h->rehash_threshold = rehash_threshold;
4050 h->rehash_size = rehash_size;
4051 h->count = make_number (0);
4052 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
4053 h->hash = Fmake_vector (size, Qnil);
4054 h->next = Fmake_vector (size, Qnil);
4055 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4056 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
4057 h->index = Fmake_vector (make_number (index_size), Qnil);
4059 /* Set up the free list. */
4060 for (i = 0; i < sz - 1; ++i)
4061 HASH_NEXT (h, i) = make_number (i + 1);
4062 h->next_free = make_number (0);
4064 XSET_HASH_TABLE (table, h);
4065 xassert (HASH_TABLE_P (table));
4066 xassert (XHASH_TABLE (table) == h);
4068 /* Maybe add this hash table to the list of all weak hash tables. */
4069 if (NILP (h->weak))
4070 h->next_weak = Qnil;
4071 else
4073 h->next_weak = Vweak_hash_tables;
4074 Vweak_hash_tables = table;
4077 return table;
4081 /* Return a copy of hash table H1. Keys and values are not copied,
4082 only the table itself is. */
4084 Lisp_Object
4085 copy_hash_table (h1)
4086 struct Lisp_Hash_Table *h1;
4088 Lisp_Object table;
4089 struct Lisp_Hash_Table *h2;
4090 struct Lisp_Vector *v, *next;
4091 int len;
4093 len = VECSIZE (struct Lisp_Hash_Table);
4094 v = allocate_vectorlike (len);
4095 h2 = (struct Lisp_Hash_Table *) v;
4096 next = h2->vec_next;
4097 bcopy (h1, h2, sizeof *h2);
4098 h2->vec_next = next;
4099 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
4100 h2->hash = Fcopy_sequence (h1->hash);
4101 h2->next = Fcopy_sequence (h1->next);
4102 h2->index = Fcopy_sequence (h1->index);
4103 XSET_HASH_TABLE (table, h2);
4105 /* Maybe add this hash table to the list of all weak hash tables. */
4106 if (!NILP (h2->weak))
4108 h2->next_weak = Vweak_hash_tables;
4109 Vweak_hash_tables = table;
4112 return table;
4116 /* Resize hash table H if it's too full. If H cannot be resized
4117 because it's already too large, throw an error. */
4119 static INLINE void
4120 maybe_resize_hash_table (h)
4121 struct Lisp_Hash_Table *h;
4123 if (NILP (h->next_free))
4125 int old_size = HASH_TABLE_SIZE (h);
4126 int i, new_size, index_size;
4128 if (INTEGERP (h->rehash_size))
4129 new_size = old_size + XFASTINT (h->rehash_size);
4130 else
4131 new_size = old_size * XFLOATINT (h->rehash_size);
4132 new_size = max (old_size + 1, new_size);
4133 index_size = next_almost_prime ((int)
4134 (new_size
4135 / XFLOATINT (h->rehash_threshold)));
4136 if (max (index_size, 2 * new_size) & ~VALMASK)
4137 error ("Hash table too large to resize");
4139 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
4140 h->next = larger_vector (h->next, new_size, Qnil);
4141 h->hash = larger_vector (h->hash, new_size, Qnil);
4142 h->index = Fmake_vector (make_number (index_size), Qnil);
4144 /* Update the free list. Do it so that new entries are added at
4145 the end of the free list. This makes some operations like
4146 maphash faster. */
4147 for (i = old_size; i < new_size - 1; ++i)
4148 HASH_NEXT (h, i) = make_number (i + 1);
4150 if (!NILP (h->next_free))
4152 Lisp_Object last, next;
4154 last = h->next_free;
4155 while (next = HASH_NEXT (h, XFASTINT (last)),
4156 !NILP (next))
4157 last = next;
4159 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
4161 else
4162 XSETFASTINT (h->next_free, old_size);
4164 /* Rehash. */
4165 for (i = 0; i < old_size; ++i)
4166 if (!NILP (HASH_HASH (h, i)))
4168 unsigned hash_code = XUINT (HASH_HASH (h, i));
4169 int start_of_bucket = hash_code % XVECTOR (h->index)->size;
4170 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4171 HASH_INDEX (h, start_of_bucket) = make_number (i);
4177 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4178 the hash code of KEY. Value is the index of the entry in H
4179 matching KEY, or -1 if not found. */
4182 hash_lookup (h, key, hash)
4183 struct Lisp_Hash_Table *h;
4184 Lisp_Object key;
4185 unsigned *hash;
4187 unsigned hash_code;
4188 int start_of_bucket;
4189 Lisp_Object idx;
4191 hash_code = h->hashfn (h, key);
4192 if (hash)
4193 *hash = hash_code;
4195 start_of_bucket = hash_code % XVECTOR (h->index)->size;
4196 idx = HASH_INDEX (h, start_of_bucket);
4198 /* We need not gcpro idx since it's either an integer or nil. */
4199 while (!NILP (idx))
4201 int i = XFASTINT (idx);
4202 if (EQ (key, HASH_KEY (h, i))
4203 || (h->cmpfn
4204 && h->cmpfn (h, key, hash_code,
4205 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4206 break;
4207 idx = HASH_NEXT (h, i);
4210 return NILP (idx) ? -1 : XFASTINT (idx);
4214 /* Put an entry into hash table H that associates KEY with VALUE.
4215 HASH is a previously computed hash code of KEY.
4216 Value is the index of the entry in H matching KEY. */
4219 hash_put (h, key, value, hash)
4220 struct Lisp_Hash_Table *h;
4221 Lisp_Object key, value;
4222 unsigned hash;
4224 int start_of_bucket, i;
4226 xassert ((hash & ~VALMASK) == 0);
4228 /* Increment count after resizing because resizing may fail. */
4229 maybe_resize_hash_table (h);
4230 h->count = make_number (XFASTINT (h->count) + 1);
4232 /* Store key/value in the key_and_value vector. */
4233 i = XFASTINT (h->next_free);
4234 h->next_free = HASH_NEXT (h, i);
4235 HASH_KEY (h, i) = key;
4236 HASH_VALUE (h, i) = value;
4238 /* Remember its hash code. */
4239 HASH_HASH (h, i) = make_number (hash);
4241 /* Add new entry to its collision chain. */
4242 start_of_bucket = hash % XVECTOR (h->index)->size;
4243 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4244 HASH_INDEX (h, start_of_bucket) = make_number (i);
4245 return i;
4249 /* Remove the entry matching KEY from hash table H, if there is one. */
4251 void
4252 hash_remove (h, key)
4253 struct Lisp_Hash_Table *h;
4254 Lisp_Object key;
4256 unsigned hash_code;
4257 int start_of_bucket;
4258 Lisp_Object idx, prev;
4260 hash_code = h->hashfn (h, key);
4261 start_of_bucket = hash_code % XVECTOR (h->index)->size;
4262 idx = HASH_INDEX (h, start_of_bucket);
4263 prev = Qnil;
4265 /* We need not gcpro idx, prev since they're either integers or nil. */
4266 while (!NILP (idx))
4268 int i = XFASTINT (idx);
4270 if (EQ (key, HASH_KEY (h, i))
4271 || (h->cmpfn
4272 && h->cmpfn (h, key, hash_code,
4273 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4275 /* Take entry out of collision chain. */
4276 if (NILP (prev))
4277 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
4278 else
4279 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
4281 /* Clear slots in key_and_value and add the slots to
4282 the free list. */
4283 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
4284 HASH_NEXT (h, i) = h->next_free;
4285 h->next_free = make_number (i);
4286 h->count = make_number (XFASTINT (h->count) - 1);
4287 xassert (XINT (h->count) >= 0);
4288 break;
4290 else
4292 prev = idx;
4293 idx = HASH_NEXT (h, i);
4299 /* Clear hash table H. */
4301 void
4302 hash_clear (h)
4303 struct Lisp_Hash_Table *h;
4305 if (XFASTINT (h->count) > 0)
4307 int i, size = HASH_TABLE_SIZE (h);
4309 for (i = 0; i < size; ++i)
4311 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
4312 HASH_KEY (h, i) = Qnil;
4313 HASH_VALUE (h, i) = Qnil;
4314 HASH_HASH (h, i) = Qnil;
4317 for (i = 0; i < XVECTOR (h->index)->size; ++i)
4318 XVECTOR (h->index)->contents[i] = Qnil;
4320 h->next_free = make_number (0);
4321 h->count = make_number (0);
4327 /************************************************************************
4328 Weak Hash Tables
4329 ************************************************************************/
4331 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4332 entries from the table that don't survive the current GC.
4333 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4334 non-zero if anything was marked. */
4336 static int
4337 sweep_weak_table (h, remove_entries_p)
4338 struct Lisp_Hash_Table *h;
4339 int remove_entries_p;
4341 int bucket, n, marked;
4343 n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
4344 marked = 0;
4346 for (bucket = 0; bucket < n; ++bucket)
4348 Lisp_Object idx, next, prev;
4350 /* Follow collision chain, removing entries that
4351 don't survive this garbage collection. */
4352 prev = Qnil;
4353 for (idx = HASH_INDEX (h, bucket); !GC_NILP (idx); idx = next)
4355 int i = XFASTINT (idx);
4356 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4357 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4358 int remove_p;
4360 if (EQ (h->weak, Qkey))
4361 remove_p = !key_known_to_survive_p;
4362 else if (EQ (h->weak, Qvalue))
4363 remove_p = !value_known_to_survive_p;
4364 else if (EQ (h->weak, Qkey_or_value))
4365 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4366 else if (EQ (h->weak, Qkey_and_value))
4367 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4368 else
4369 abort ();
4371 next = HASH_NEXT (h, i);
4373 if (remove_entries_p)
4375 if (remove_p)
4377 /* Take out of collision chain. */
4378 if (GC_NILP (prev))
4379 HASH_INDEX (h, bucket) = next;
4380 else
4381 HASH_NEXT (h, XFASTINT (prev)) = next;
4383 /* Add to free list. */
4384 HASH_NEXT (h, i) = h->next_free;
4385 h->next_free = idx;
4387 /* Clear key, value, and hash. */
4388 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
4389 HASH_HASH (h, i) = Qnil;
4391 h->count = make_number (XFASTINT (h->count) - 1);
4394 else
4396 if (!remove_p)
4398 /* Make sure key and value survive. */
4399 if (!key_known_to_survive_p)
4401 mark_object (&HASH_KEY (h, i));
4402 marked = 1;
4405 if (!value_known_to_survive_p)
4407 mark_object (&HASH_VALUE (h, i));
4408 marked = 1;
4415 return marked;
4418 /* Remove elements from weak hash tables that don't survive the
4419 current garbage collection. Remove weak tables that don't survive
4420 from Vweak_hash_tables. Called from gc_sweep. */
4422 void
4423 sweep_weak_hash_tables ()
4425 Lisp_Object table, used, next;
4426 struct Lisp_Hash_Table *h;
4427 int marked;
4429 /* Mark all keys and values that are in use. Keep on marking until
4430 there is no more change. This is necessary for cases like
4431 value-weak table A containing an entry X -> Y, where Y is used in a
4432 key-weak table B, Z -> Y. If B comes after A in the list of weak
4433 tables, X -> Y might be removed from A, although when looking at B
4434 one finds that it shouldn't. */
4437 marked = 0;
4438 for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak)
4440 h = XHASH_TABLE (table);
4441 if (h->size & ARRAY_MARK_FLAG)
4442 marked |= sweep_weak_table (h, 0);
4445 while (marked);
4447 /* Remove tables and entries that aren't used. */
4448 for (table = Vweak_hash_tables, used = Qnil; !GC_NILP (table); table = next)
4450 h = XHASH_TABLE (table);
4451 next = h->next_weak;
4453 if (h->size & ARRAY_MARK_FLAG)
4455 /* TABLE is marked as used. Sweep its contents. */
4456 if (XFASTINT (h->count) > 0)
4457 sweep_weak_table (h, 1);
4459 /* Add table to the list of used weak hash tables. */
4460 h->next_weak = used;
4461 used = table;
4465 Vweak_hash_tables = used;
4470 /***********************************************************************
4471 Hash Code Computation
4472 ***********************************************************************/
4474 /* Maximum depth up to which to dive into Lisp structures. */
4476 #define SXHASH_MAX_DEPTH 3
4478 /* Maximum length up to which to take list and vector elements into
4479 account. */
4481 #define SXHASH_MAX_LEN 7
4483 /* Combine two integers X and Y for hashing. */
4485 #define SXHASH_COMBINE(X, Y) \
4486 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4487 + (unsigned)(Y))
4490 /* Return a hash for string PTR which has length LEN. The hash
4491 code returned is guaranteed to fit in a Lisp integer. */
4493 static unsigned
4494 sxhash_string (ptr, len)
4495 unsigned char *ptr;
4496 int len;
4498 unsigned char *p = ptr;
4499 unsigned char *end = p + len;
4500 unsigned char c;
4501 unsigned hash = 0;
4503 while (p != end)
4505 c = *p++;
4506 if (c >= 0140)
4507 c -= 40;
4508 hash = ((hash << 3) + (hash >> 28) + c);
4511 return hash & VALMASK;
4515 /* Return a hash for list LIST. DEPTH is the current depth in the
4516 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4518 static unsigned
4519 sxhash_list (list, depth)
4520 Lisp_Object list;
4521 int depth;
4523 unsigned hash = 0;
4524 int i;
4526 if (depth < SXHASH_MAX_DEPTH)
4527 for (i = 0;
4528 CONSP (list) && i < SXHASH_MAX_LEN;
4529 list = XCDR (list), ++i)
4531 unsigned hash2 = sxhash (XCAR (list), depth + 1);
4532 hash = SXHASH_COMBINE (hash, hash2);
4535 return hash;
4539 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4540 the Lisp structure. */
4542 static unsigned
4543 sxhash_vector (vec, depth)
4544 Lisp_Object vec;
4545 int depth;
4547 unsigned hash = XVECTOR (vec)->size;
4548 int i, n;
4550 n = min (SXHASH_MAX_LEN, XVECTOR (vec)->size);
4551 for (i = 0; i < n; ++i)
4553 unsigned hash2 = sxhash (XVECTOR (vec)->contents[i], depth + 1);
4554 hash = SXHASH_COMBINE (hash, hash2);
4557 return hash;
4561 /* Return a hash for bool-vector VECTOR. */
4563 static unsigned
4564 sxhash_bool_vector (vec)
4565 Lisp_Object vec;
4567 unsigned hash = XBOOL_VECTOR (vec)->size;
4568 int i, n;
4570 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
4571 for (i = 0; i < n; ++i)
4572 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
4574 return hash;
4578 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4579 structure. Value is an unsigned integer clipped to VALMASK. */
4581 unsigned
4582 sxhash (obj, depth)
4583 Lisp_Object obj;
4584 int depth;
4586 unsigned hash;
4588 if (depth > SXHASH_MAX_DEPTH)
4589 return 0;
4591 switch (XTYPE (obj))
4593 case Lisp_Int:
4594 hash = XUINT (obj);
4595 break;
4597 case Lisp_Symbol:
4598 hash = sxhash_string (XSYMBOL (obj)->name->data,
4599 XSYMBOL (obj)->name->size);
4600 break;
4602 case Lisp_Misc:
4603 hash = XUINT (obj);
4604 break;
4606 case Lisp_String:
4607 hash = sxhash_string (XSTRING (obj)->data, XSTRING (obj)->size);
4608 break;
4610 /* This can be everything from a vector to an overlay. */
4611 case Lisp_Vectorlike:
4612 if (VECTORP (obj))
4613 /* According to the CL HyperSpec, two arrays are equal only if
4614 they are `eq', except for strings and bit-vectors. In
4615 Emacs, this works differently. We have to compare element
4616 by element. */
4617 hash = sxhash_vector (obj, depth);
4618 else if (BOOL_VECTOR_P (obj))
4619 hash = sxhash_bool_vector (obj);
4620 else
4621 /* Others are `equal' if they are `eq', so let's take their
4622 address as hash. */
4623 hash = XUINT (obj);
4624 break;
4626 case Lisp_Cons:
4627 hash = sxhash_list (obj, depth);
4628 break;
4630 case Lisp_Float:
4632 unsigned char *p = (unsigned char *) &XFLOAT_DATA (obj);
4633 unsigned char *e = p + sizeof XFLOAT_DATA (obj);
4634 for (hash = 0; p < e; ++p)
4635 hash = SXHASH_COMBINE (hash, *p);
4636 break;
4639 default:
4640 abort ();
4643 return hash & VALMASK;
4648 /***********************************************************************
4649 Lisp Interface
4650 ***********************************************************************/
4653 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
4654 "Compute a hash code for OBJ and return it as integer.")
4655 (obj)
4656 Lisp_Object obj;
4658 unsigned hash = sxhash (obj, 0);;
4659 return make_number (hash);
4663 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4664 "Create and return a new hash table.\n\
4665 Arguments are specified as keyword/argument pairs. The following\n\
4666 arguments are defined:\n\
4668 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4669 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4670 User-supplied test and hash functions can be specified via\n\
4671 `define-hash-table-test'.\n\
4673 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4674 Default is 65.\n\
4676 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4677 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4678 If it is a float, it must be > 1.0, and the new size is computed by\n\
4679 multiplying the old size with that factor. Default is 1.5.\n\
4681 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4682 Resize the hash table when ratio of the number of entries in the table.\n\
4683 Default is 0.8.\n\
4685 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4686 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4687 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4688 there are no non-weak references pointing to their key, value, one of key\n\
4689 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4690 to `key-and-value'. Default value of WEAK is nil.")
4691 (nargs, args)
4692 int nargs;
4693 Lisp_Object *args;
4695 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4696 Lisp_Object user_test, user_hash;
4697 char *used;
4698 int i;
4700 /* The vector `used' is used to keep track of arguments that
4701 have been consumed. */
4702 used = (char *) alloca (nargs * sizeof *used);
4703 bzero (used, nargs * sizeof *used);
4705 /* See if there's a `:test TEST' among the arguments. */
4706 i = get_key_arg (QCtest, nargs, args, used);
4707 test = i < 0 ? Qeql : args[i];
4708 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
4710 /* See if it is a user-defined test. */
4711 Lisp_Object prop;
4713 prop = Fget (test, Qhash_table_test);
4714 if (!CONSP (prop) || XFASTINT (Flength (prop)) < 2)
4715 Fsignal (Qerror, list2 (build_string ("Invalid hash table test"),
4716 test));
4717 user_test = Fnth (make_number (0), prop);
4718 user_hash = Fnth (make_number (1), prop);
4720 else
4721 user_test = user_hash = Qnil;
4723 /* See if there's a `:size SIZE' argument. */
4724 i = get_key_arg (QCsize, nargs, args, used);
4725 size = i < 0 ? make_number (DEFAULT_HASH_SIZE) : args[i];
4726 if (!INTEGERP (size) || XINT (size) < 0)
4727 Fsignal (Qerror,
4728 list2 (build_string ("Invalid hash table size"),
4729 size));
4731 /* Look for `:rehash-size SIZE'. */
4732 i = get_key_arg (QCrehash_size, nargs, args, used);
4733 rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i];
4734 if (!NUMBERP (rehash_size)
4735 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
4736 || XFLOATINT (rehash_size) <= 1.0)
4737 Fsignal (Qerror,
4738 list2 (build_string ("Invalid hash table rehash size"),
4739 rehash_size));
4741 /* Look for `:rehash-threshold THRESHOLD'. */
4742 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4743 rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
4744 if (!FLOATP (rehash_threshold)
4745 || XFLOATINT (rehash_threshold) <= 0.0
4746 || XFLOATINT (rehash_threshold) > 1.0)
4747 Fsignal (Qerror,
4748 list2 (build_string ("Invalid hash table rehash threshold"),
4749 rehash_threshold));
4751 /* Look for `:weakness WEAK'. */
4752 i = get_key_arg (QCweakness, nargs, args, used);
4753 weak = i < 0 ? Qnil : args[i];
4754 if (EQ (weak, Qt))
4755 weak = Qkey_and_value;
4756 if (!NILP (weak)
4757 && !EQ (weak, Qkey)
4758 && !EQ (weak, Qvalue)
4759 && !EQ (weak, Qkey_or_value)
4760 && !EQ (weak, Qkey_and_value))
4761 Fsignal (Qerror, list2 (build_string ("Invalid hash table weakness"),
4762 weak));
4764 /* Now, all args should have been used up, or there's a problem. */
4765 for (i = 0; i < nargs; ++i)
4766 if (!used[i])
4767 Fsignal (Qerror,
4768 list2 (build_string ("Invalid argument list"), args[i]));
4770 return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
4771 user_test, user_hash);
4775 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4776 "Return a copy of hash table TABLE.")
4777 (table)
4778 Lisp_Object table;
4780 return copy_hash_table (check_hash_table (table));
4784 DEFUN ("makehash", Fmakehash, Smakehash, 0, 1, 0,
4785 "Create a new hash table.\n\
4786 Optional first argument TEST specifies how to compare keys in\n\
4787 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4788 is `eql'. New tests can be defined with `define-hash-table-test'.")
4789 (test)
4790 Lisp_Object test;
4792 Lisp_Object args[2];
4793 args[0] = QCtest;
4794 args[1] = NILP (test) ? Qeql : test;
4795 return Fmake_hash_table (2, args);
4799 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4800 "Return the number of elements in TABLE.")
4801 (table)
4802 Lisp_Object table;
4804 return check_hash_table (table)->count;
4808 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4809 Shash_table_rehash_size, 1, 1, 0,
4810 "Return the current rehash size of TABLE.")
4811 (table)
4812 Lisp_Object table;
4814 return check_hash_table (table)->rehash_size;
4818 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4819 Shash_table_rehash_threshold, 1, 1, 0,
4820 "Return the current rehash threshold of TABLE.")
4821 (table)
4822 Lisp_Object table;
4824 return check_hash_table (table)->rehash_threshold;
4828 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4829 "Return the size of TABLE.\n\
4830 The size can be used as an argument to `make-hash-table' to create\n\
4831 a hash table than can hold as many elements of TABLE holds\n\
4832 without need for resizing.")
4833 (table)
4834 Lisp_Object table;
4836 struct Lisp_Hash_Table *h = check_hash_table (table);
4837 return make_number (HASH_TABLE_SIZE (h));
4841 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4842 "Return the test TABLE uses.")
4843 (table)
4844 Lisp_Object table;
4846 return check_hash_table (table)->test;
4850 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4851 1, 1, 0,
4852 "Return the weakness of TABLE.")
4853 (table)
4854 Lisp_Object table;
4856 return check_hash_table (table)->weak;
4860 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4861 "Return t if OBJ is a Lisp hash table object.")
4862 (obj)
4863 Lisp_Object obj;
4865 return HASH_TABLE_P (obj) ? Qt : Qnil;
4869 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4870 "Clear hash table TABLE.")
4871 (table)
4872 Lisp_Object table;
4874 hash_clear (check_hash_table (table));
4875 return Qnil;
4879 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4880 "Look up KEY in TABLE and return its associated value.\n\
4881 If KEY is not found, return DFLT which defaults to nil.")
4882 (key, table, dflt)
4883 Lisp_Object key, table, dflt;
4885 struct Lisp_Hash_Table *h = check_hash_table (table);
4886 int i = hash_lookup (h, key, NULL);
4887 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4891 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4892 "Associate KEY with VALUE in hash table TABLE.\n\
4893 If KEY is already present in table, replace its current value with\n\
4894 VALUE.")
4895 (key, value, table)
4896 Lisp_Object key, value, table;
4898 struct Lisp_Hash_Table *h = check_hash_table (table);
4899 int i;
4900 unsigned hash;
4902 i = hash_lookup (h, key, &hash);
4903 if (i >= 0)
4904 HASH_VALUE (h, i) = value;
4905 else
4906 hash_put (h, key, value, hash);
4908 return value;
4912 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4913 "Remove KEY from TABLE.")
4914 (key, table)
4915 Lisp_Object key, table;
4917 struct Lisp_Hash_Table *h = check_hash_table (table);
4918 hash_remove (h, key);
4919 return Qnil;
4923 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4924 "Call FUNCTION for all entries in hash table TABLE.\n\
4925 FUNCTION is called with 2 arguments KEY and VALUE.")
4926 (function, table)
4927 Lisp_Object function, table;
4929 struct Lisp_Hash_Table *h = check_hash_table (table);
4930 Lisp_Object args[3];
4931 int i;
4933 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
4934 if (!NILP (HASH_HASH (h, i)))
4936 args[0] = function;
4937 args[1] = HASH_KEY (h, i);
4938 args[2] = HASH_VALUE (h, i);
4939 Ffuncall (3, args);
4942 return Qnil;
4946 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4947 Sdefine_hash_table_test, 3, 3, 0,
4948 "Define a new hash table test with name NAME, a symbol.\n\
4949 In hash tables create with NAME specified as test, use TEST to compare\n\
4950 keys, and HASH for computing hash codes of keys.\n\
4952 TEST must be a function taking two arguments and returning non-nil\n\
4953 if both arguments are the same. HASH must be a function taking\n\
4954 one argument and return an integer that is the hash code of the\n\
4955 argument. Hash code computation should use the whole value range of\n\
4956 integers, including negative integers.")
4957 (name, test, hash)
4958 Lisp_Object name, test, hash;
4960 return Fput (name, Qhash_table_test, list2 (test, hash));
4965 /************************************************************************
4967 ************************************************************************/
4969 #include "md5.h"
4970 #include "coding.h"
4972 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4973 "Return MD5 message digest of OBJECT, a buffer or string.\n\
4974 A message digest is a cryptographic checksum of a document,\n\
4975 and the algorithm to calculate it is defined in RFC 1321.\n\
4977 The two optional arguments START and END are character positions\n\
4978 specifying for which part of OBJECT the message digest should be computed.\n\
4979 If nil or omitted, the digest is computed for the whole OBJECT.\n\
4981 The MD5 message digest is computed from the result of encoding the\n\
4982 text in a coding system, not directly from the internal Emacs form\n\
4983 of the text. The optional fourth argument CODING-SYSTEM specifies\n\
4984 which coding system to encode the text with. It should be the same\n\
4985 coding system that you used or will use when actually writing the text\n\
4986 into a file.\n\
4988 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.\n\
4989 If OBJECT is a buffer, the default for CODING-SYSTEM is whatever\n\
4990 coding system would be chosen by default for writing this text\n\
4991 into a file.\n\
4993 If OBJECT is a string, the most preferred coding system (see the\n\
4994 command `prefer-coding-system') is used.\n\
4996 The optional fifth argument NOERROR exists for compatibility with\n\
4997 other Emacs versions, and is ignored.")
4998 (object, start, end, coding_system, noerror)
4999 Lisp_Object object, start, end, coding_system, noerror;
5001 unsigned char digest[16];
5002 unsigned char value[33];
5003 int i;
5004 int size;
5005 int size_byte = 0;
5006 int start_char = 0, end_char = 0;
5007 int start_byte = 0, end_byte = 0;
5008 register int b, e;
5009 register struct buffer *bp;
5010 int temp;
5012 if (STRINGP (object))
5014 if (NILP (coding_system))
5016 /* Decide the coding-system to encode the data with. */
5018 if (STRING_MULTIBYTE (object))
5019 /* use default, we can't guess correct value */
5020 coding_system = XSYMBOL (XCAR (Vcoding_category_list))->value;
5021 else
5022 coding_system = Qraw_text;
5025 if (NILP (Fcoding_system_p (coding_system)))
5027 /* Invalid coding system. */
5029 if (!NILP (noerror))
5030 coding_system = Qraw_text;
5031 else
5032 while (1)
5033 Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
5036 if (STRING_MULTIBYTE (object))
5037 object = code_convert_string1 (object, coding_system, Qnil, 1);
5039 size = XSTRING (object)->size;
5040 size_byte = STRING_BYTES (XSTRING (object));
5042 if (!NILP (start))
5044 CHECK_NUMBER (start, 1);
5046 start_char = XINT (start);
5048 if (start_char < 0)
5049 start_char += size;
5051 start_byte = string_char_to_byte (object, start_char);
5054 if (NILP (end))
5056 end_char = size;
5057 end_byte = size_byte;
5059 else
5061 CHECK_NUMBER (end, 2);
5063 end_char = XINT (end);
5065 if (end_char < 0)
5066 end_char += size;
5068 end_byte = string_char_to_byte (object, end_char);
5071 if (!(0 <= start_char && start_char <= end_char && end_char <= size))
5072 args_out_of_range_3 (object, make_number (start_char),
5073 make_number (end_char));
5075 else
5077 CHECK_BUFFER (object, 0);
5079 bp = XBUFFER (object);
5081 if (NILP (start))
5082 b = BUF_BEGV (bp);
5083 else
5085 CHECK_NUMBER_COERCE_MARKER (start, 0);
5086 b = XINT (start);
5089 if (NILP (end))
5090 e = BUF_ZV (bp);
5091 else
5093 CHECK_NUMBER_COERCE_MARKER (end, 1);
5094 e = XINT (end);
5097 if (b > e)
5098 temp = b, b = e, e = temp;
5100 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
5101 args_out_of_range (start, end);
5103 if (NILP (coding_system))
5105 /* Decide the coding-system to encode the data with.
5106 See fileio.c:Fwrite-region */
5108 if (!NILP (Vcoding_system_for_write))
5109 coding_system = Vcoding_system_for_write;
5110 else
5112 int force_raw_text = 0;
5114 coding_system = XBUFFER (object)->buffer_file_coding_system;
5115 if (NILP (coding_system)
5116 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
5118 coding_system = Qnil;
5119 if (NILP (current_buffer->enable_multibyte_characters))
5120 force_raw_text = 1;
5123 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
5125 /* Check file-coding-system-alist. */
5126 Lisp_Object args[4], val;
5128 args[0] = Qwrite_region; args[1] = start; args[2] = end;
5129 args[3] = Fbuffer_file_name(object);
5130 val = Ffind_operation_coding_system (4, args);
5131 if (CONSP (val) && !NILP (XCDR (val)))
5132 coding_system = XCDR (val);
5135 if (NILP (coding_system)
5136 && !NILP (XBUFFER (object)->buffer_file_coding_system))
5138 /* If we still have not decided a coding system, use the
5139 default value of buffer-file-coding-system. */
5140 coding_system = XBUFFER (object)->buffer_file_coding_system;
5143 if (!force_raw_text
5144 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
5145 /* Confirm that VAL can surely encode the current region. */
5146 coding_system = call3 (Vselect_safe_coding_system_function,
5147 make_number (b), make_number (e),
5148 coding_system);
5150 if (force_raw_text)
5151 coding_system = Qraw_text;
5154 if (NILP (Fcoding_system_p (coding_system)))
5156 /* Invalid coding system. */
5158 if (!NILP (noerror))
5159 coding_system = Qraw_text;
5160 else
5161 while (1)
5162 Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
5166 object = make_buffer_string (b, e, 0);
5168 if (STRING_MULTIBYTE (object))
5169 object = code_convert_string1 (object, coding_system, Qnil, 1);
5172 md5_buffer (XSTRING (object)->data + start_byte,
5173 STRING_BYTES(XSTRING (object)) - (size_byte - end_byte),
5174 digest);
5176 for (i = 0; i < 16; i++)
5177 sprintf (&value[2 * i], "%02x", digest[i]);
5178 value[32] = '\0';
5180 return make_string (value, 32);
5184 void
5185 syms_of_fns ()
5187 /* Hash table stuff. */
5188 Qhash_table_p = intern ("hash-table-p");
5189 staticpro (&Qhash_table_p);
5190 Qeq = intern ("eq");
5191 staticpro (&Qeq);
5192 Qeql = intern ("eql");
5193 staticpro (&Qeql);
5194 Qequal = intern ("equal");
5195 staticpro (&Qequal);
5196 QCtest = intern (":test");
5197 staticpro (&QCtest);
5198 QCsize = intern (":size");
5199 staticpro (&QCsize);
5200 QCrehash_size = intern (":rehash-size");
5201 staticpro (&QCrehash_size);
5202 QCrehash_threshold = intern (":rehash-threshold");
5203 staticpro (&QCrehash_threshold);
5204 QCweakness = intern (":weakness");
5205 staticpro (&QCweakness);
5206 Qkey = intern ("key");
5207 staticpro (&Qkey);
5208 Qvalue = intern ("value");
5209 staticpro (&Qvalue);
5210 Qhash_table_test = intern ("hash-table-test");
5211 staticpro (&Qhash_table_test);
5212 Qkey_or_value = intern ("key-or-value");
5213 staticpro (&Qkey_or_value);
5214 Qkey_and_value = intern ("key-and-value");
5215 staticpro (&Qkey_and_value);
5217 defsubr (&Ssxhash);
5218 defsubr (&Smake_hash_table);
5219 defsubr (&Scopy_hash_table);
5220 defsubr (&Smakehash);
5221 defsubr (&Shash_table_count);
5222 defsubr (&Shash_table_rehash_size);
5223 defsubr (&Shash_table_rehash_threshold);
5224 defsubr (&Shash_table_size);
5225 defsubr (&Shash_table_test);
5226 defsubr (&Shash_table_weakness);
5227 defsubr (&Shash_table_p);
5228 defsubr (&Sclrhash);
5229 defsubr (&Sgethash);
5230 defsubr (&Sputhash);
5231 defsubr (&Sremhash);
5232 defsubr (&Smaphash);
5233 defsubr (&Sdefine_hash_table_test);
5235 Qstring_lessp = intern ("string-lessp");
5236 staticpro (&Qstring_lessp);
5237 Qprovide = intern ("provide");
5238 staticpro (&Qprovide);
5239 Qrequire = intern ("require");
5240 staticpro (&Qrequire);
5241 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
5242 staticpro (&Qyes_or_no_p_history);
5243 Qcursor_in_echo_area = intern ("cursor-in-echo-area");
5244 staticpro (&Qcursor_in_echo_area);
5245 Qwidget_type = intern ("widget-type");
5246 staticpro (&Qwidget_type);
5248 staticpro (&string_char_byte_cache_string);
5249 string_char_byte_cache_string = Qnil;
5251 Fset (Qyes_or_no_p_history, Qnil);
5253 DEFVAR_LISP ("features", &Vfeatures,
5254 "A list of symbols which are the features of the executing emacs.\n\
5255 Used by `featurep' and `require', and altered by `provide'.");
5256 Vfeatures = Qnil;
5258 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
5259 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5260 This applies to y-or-n and yes-or-no questions asked by commands\n\
5261 invoked by mouse clicks and mouse menu items.");
5262 use_dialog_box = 1;
5264 defsubr (&Sidentity);
5265 defsubr (&Srandom);
5266 defsubr (&Slength);
5267 defsubr (&Ssafe_length);
5268 defsubr (&Sstring_bytes);
5269 defsubr (&Sstring_equal);
5270 defsubr (&Scompare_strings);
5271 defsubr (&Sstring_lessp);
5272 defsubr (&Sappend);
5273 defsubr (&Sconcat);
5274 defsubr (&Svconcat);
5275 defsubr (&Scopy_sequence);
5276 defsubr (&Sstring_make_multibyte);
5277 defsubr (&Sstring_make_unibyte);
5278 defsubr (&Sstring_as_multibyte);
5279 defsubr (&Sstring_as_unibyte);
5280 defsubr (&Scopy_alist);
5281 defsubr (&Ssubstring);
5282 defsubr (&Snthcdr);
5283 defsubr (&Snth);
5284 defsubr (&Selt);
5285 defsubr (&Smember);
5286 defsubr (&Smemq);
5287 defsubr (&Sassq);
5288 defsubr (&Sassoc);
5289 defsubr (&Srassq);
5290 defsubr (&Srassoc);
5291 defsubr (&Sdelq);
5292 defsubr (&Sdelete);
5293 defsubr (&Snreverse);
5294 defsubr (&Sreverse);
5295 defsubr (&Ssort);
5296 defsubr (&Splist_get);
5297 defsubr (&Sget);
5298 defsubr (&Splist_put);
5299 defsubr (&Sput);
5300 defsubr (&Sequal);
5301 defsubr (&Sfillarray);
5302 defsubr (&Schar_table_subtype);
5303 defsubr (&Schar_table_parent);
5304 defsubr (&Sset_char_table_parent);
5305 defsubr (&Schar_table_extra_slot);
5306 defsubr (&Sset_char_table_extra_slot);
5307 defsubr (&Schar_table_range);
5308 defsubr (&Sset_char_table_range);
5309 defsubr (&Sset_char_table_default);
5310 defsubr (&Soptimize_char_table);
5311 defsubr (&Smap_char_table);
5312 defsubr (&Snconc);
5313 defsubr (&Smapcar);
5314 defsubr (&Smapc);
5315 defsubr (&Smapconcat);
5316 defsubr (&Sy_or_n_p);
5317 defsubr (&Syes_or_no_p);
5318 defsubr (&Sload_average);
5319 defsubr (&Sfeaturep);
5320 defsubr (&Srequire);
5321 defsubr (&Sprovide);
5322 defsubr (&Splist_member);
5323 defsubr (&Swidget_put);
5324 defsubr (&Swidget_get);
5325 defsubr (&Swidget_apply);
5326 defsubr (&Sbase64_encode_region);
5327 defsubr (&Sbase64_decode_region);
5328 defsubr (&Sbase64_encode_string);
5329 defsubr (&Sbase64_decode_string);
5330 defsubr (&Smd5);
5334 void
5335 init_fns ()
5337 Vweak_hash_tables = Qnil;