* keyboard.c (parse_modifiers_uncached, parse_modifiers):
[emacs.git] / src / fns.c
blob95e8badbaa5d37f1eedc279abb3faa16a7c33fc8
1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
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 3 of the License, or
10 (at your option) 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. If not, see <http://www.gnu.org/licenses/>. */
20 #include <config.h>
22 #include <unistd.h>
23 #include <time.h>
24 #include <setjmp.h>
26 /* Note on some machines this defines `vector' as a typedef,
27 so make sure we don't use that name in this file. */
28 #undef vector
29 #define vector *****
31 #include "lisp.h"
32 #include "commands.h"
33 #include "character.h"
34 #include "coding.h"
35 #include "buffer.h"
36 #include "keyboard.h"
37 #include "keymap.h"
38 #include "intervals.h"
39 #include "frame.h"
40 #include "window.h"
41 #include "blockinput.h"
42 #ifdef HAVE_MENUS
43 #if defined (HAVE_X_WINDOWS)
44 #include "xterm.h"
45 #endif
46 #endif /* HAVE_MENUS */
48 #ifndef NULL
49 #define NULL ((POINTER_TYPE *)0)
50 #endif
52 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
53 Lisp_Object Qyes_or_no_p_history;
54 Lisp_Object Qcursor_in_echo_area;
55 Lisp_Object Qwidget_type;
56 Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
58 static int internal_equal (Lisp_Object , Lisp_Object, int, int);
60 #ifndef HAVE_UNISTD_H
61 extern long time ();
62 #endif
64 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
65 doc: /* Return the argument unchanged. */)
66 (Lisp_Object arg)
68 return arg;
71 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
72 doc: /* Return a pseudo-random number.
73 All integers representable in Lisp are equally likely.
74 On most systems, this is 29 bits' worth.
75 With positive integer LIMIT, return random number in interval [0,LIMIT).
76 With argument t, set the random number seed from the current time and pid.
77 Other values of LIMIT are ignored. */)
78 (Lisp_Object limit)
80 EMACS_INT val;
81 Lisp_Object lispy_val;
82 unsigned long denominator;
84 if (EQ (limit, Qt))
85 seed_random (getpid () + time (NULL));
86 if (NATNUMP (limit) && XFASTINT (limit) != 0)
88 /* Try to take our random number from the higher bits of VAL,
89 not the lower, since (says Gentzel) the low bits of `random'
90 are less random than the higher ones. We do this by using the
91 quotient rather than the remainder. At the high end of the RNG
92 it's possible to get a quotient larger than n; discarding
93 these values eliminates the bias that would otherwise appear
94 when using a large n. */
95 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
97 val = get_random () / denominator;
98 while (val >= XFASTINT (limit));
100 else
101 val = get_random ();
102 XSETINT (lispy_val, val);
103 return lispy_val;
106 /* Random data-structure functions */
108 DEFUN ("length", Flength, Slength, 1, 1, 0,
109 doc: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence)
116 register Lisp_Object val;
117 register int i;
119 if (STRINGP (sequence))
120 XSETFASTINT (val, SCHARS (sequence));
121 else if (VECTORP (sequence))
122 XSETFASTINT (val, ASIZE (sequence));
123 else if (CHAR_TABLE_P (sequence))
124 XSETFASTINT (val, MAX_CHAR);
125 else if (BOOL_VECTOR_P (sequence))
126 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
127 else if (COMPILEDP (sequence))
128 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
129 else if (CONSP (sequence))
131 i = 0;
132 while (CONSP (sequence))
134 sequence = XCDR (sequence);
135 ++i;
137 if (!CONSP (sequence))
138 break;
140 sequence = XCDR (sequence);
141 ++i;
142 QUIT;
145 CHECK_LIST_END (sequence, sequence);
147 val = make_number (i);
149 else if (NILP (sequence))
150 XSETFASTINT (val, 0);
151 else
152 wrong_type_argument (Qsequencep, sequence);
154 return val;
157 /* This does not check for quits. That is safe since it must terminate. */
159 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
160 doc: /* Return the length of a list, but avoid error or infinite loop.
161 This function never gets an error. If LIST is not really a list,
162 it returns 0. If LIST is circular, it returns a finite value
163 which is at least the number of distinct elements. */)
164 (Lisp_Object list)
166 Lisp_Object tail, halftail, length;
167 int len = 0;
169 /* halftail is used to detect circular lists. */
170 halftail = list;
171 for (tail = list; CONSP (tail); tail = XCDR (tail))
173 if (EQ (tail, halftail) && len != 0)
174 break;
175 len++;
176 if ((len & 1) == 0)
177 halftail = XCDR (halftail);
180 XSETINT (length, len);
181 return length;
184 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
185 doc: /* Return the number of bytes in STRING.
186 If STRING is multibyte, this may be greater than the length of STRING. */)
187 (Lisp_Object string)
189 CHECK_STRING (string);
190 return make_number (SBYTES (string));
193 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
194 doc: /* Return t if two strings have identical contents.
195 Case is significant, but text properties are ignored.
196 Symbols are also allowed; their print names are used instead. */)
197 (register Lisp_Object s1, Lisp_Object s2)
199 if (SYMBOLP (s1))
200 s1 = SYMBOL_NAME (s1);
201 if (SYMBOLP (s2))
202 s2 = SYMBOL_NAME (s2);
203 CHECK_STRING (s1);
204 CHECK_STRING (s2);
206 if (SCHARS (s1) != SCHARS (s2)
207 || SBYTES (s1) != SBYTES (s2)
208 || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
209 return Qnil;
210 return Qt;
213 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
214 doc: /* Compare the contents of two strings, converting to multibyte if needed.
215 In string STR1, skip the first START1 characters and stop at END1.
216 In string STR2, skip the first START2 characters and stop at END2.
217 END1 and END2 default to the full lengths of the respective strings.
219 Case is significant in this comparison if IGNORE-CASE is nil.
220 Unibyte strings are converted to multibyte for comparison.
222 The value is t if the strings (or specified portions) match.
223 If string STR1 is less, the value is a negative number N;
224 - 1 - N is the number of characters that match at the beginning.
225 If string STR1 is greater, the value is a positive number N;
226 N - 1 is the number of characters that match at the beginning. */)
227 (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
229 register EMACS_INT end1_char, end2_char;
230 register EMACS_INT i1, i1_byte, i2, i2_byte;
232 CHECK_STRING (str1);
233 CHECK_STRING (str2);
234 if (NILP (start1))
235 start1 = make_number (0);
236 if (NILP (start2))
237 start2 = make_number (0);
238 CHECK_NATNUM (start1);
239 CHECK_NATNUM (start2);
240 if (! NILP (end1))
241 CHECK_NATNUM (end1);
242 if (! NILP (end2))
243 CHECK_NATNUM (end2);
245 i1 = XINT (start1);
246 i2 = XINT (start2);
248 i1_byte = string_char_to_byte (str1, i1);
249 i2_byte = string_char_to_byte (str2, i2);
251 end1_char = SCHARS (str1);
252 if (! NILP (end1) && end1_char > XINT (end1))
253 end1_char = XINT (end1);
255 end2_char = SCHARS (str2);
256 if (! NILP (end2) && end2_char > XINT (end2))
257 end2_char = XINT (end2);
259 while (i1 < end1_char && i2 < end2_char)
261 /* When we find a mismatch, we must compare the
262 characters, not just the bytes. */
263 int c1, c2;
265 if (STRING_MULTIBYTE (str1))
266 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
267 else
269 c1 = SREF (str1, i1++);
270 MAKE_CHAR_MULTIBYTE (c1);
273 if (STRING_MULTIBYTE (str2))
274 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
275 else
277 c2 = SREF (str2, i2++);
278 MAKE_CHAR_MULTIBYTE (c2);
281 if (c1 == c2)
282 continue;
284 if (! NILP (ignore_case))
286 Lisp_Object tem;
288 tem = Fupcase (make_number (c1));
289 c1 = XINT (tem);
290 tem = Fupcase (make_number (c2));
291 c2 = XINT (tem);
294 if (c1 == c2)
295 continue;
297 /* Note that I1 has already been incremented
298 past the character that we are comparing;
299 hence we don't add or subtract 1 here. */
300 if (c1 < c2)
301 return make_number (- i1 + XINT (start1));
302 else
303 return make_number (i1 - XINT (start1));
306 if (i1 < end1_char)
307 return make_number (i1 - XINT (start1) + 1);
308 if (i2 < end2_char)
309 return make_number (- i1 + XINT (start1) - 1);
311 return Qt;
314 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
315 doc: /* Return t if first arg string is less than second in lexicographic order.
316 Case is significant.
317 Symbols are also allowed; their print names are used instead. */)
318 (register Lisp_Object s1, Lisp_Object s2)
320 register EMACS_INT end;
321 register EMACS_INT i1, i1_byte, i2, i2_byte;
323 if (SYMBOLP (s1))
324 s1 = SYMBOL_NAME (s1);
325 if (SYMBOLP (s2))
326 s2 = SYMBOL_NAME (s2);
327 CHECK_STRING (s1);
328 CHECK_STRING (s2);
330 i1 = i1_byte = i2 = i2_byte = 0;
332 end = SCHARS (s1);
333 if (end > SCHARS (s2))
334 end = SCHARS (s2);
336 while (i1 < end)
338 /* When we find a mismatch, we must compare the
339 characters, not just the bytes. */
340 int c1, c2;
342 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
343 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
345 if (c1 != c2)
346 return c1 < c2 ? Qt : Qnil;
348 return i1 < SCHARS (s2) ? Qt : Qnil;
351 static Lisp_Object concat (size_t nargs, Lisp_Object *args,
352 enum Lisp_Type target_type, int last_special);
354 /* ARGSUSED */
355 Lisp_Object
356 concat2 (Lisp_Object s1, Lisp_Object s2)
358 Lisp_Object args[2];
359 args[0] = s1;
360 args[1] = s2;
361 return concat (2, args, Lisp_String, 0);
364 /* ARGSUSED */
365 Lisp_Object
366 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
368 Lisp_Object args[3];
369 args[0] = s1;
370 args[1] = s2;
371 args[2] = s3;
372 return concat (3, args, Lisp_String, 0);
375 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
376 doc: /* Concatenate all the arguments and make the result a list.
377 The result is a list whose elements are the elements of all the arguments.
378 Each argument may be a list, vector or string.
379 The last argument is not copied, just used as the tail of the new list.
380 usage: (append &rest SEQUENCES) */)
381 (size_t nargs, Lisp_Object *args)
383 return concat (nargs, args, Lisp_Cons, 1);
386 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
387 doc: /* Concatenate all the arguments and make the result a string.
388 The result is a string whose elements are the elements of all the arguments.
389 Each argument may be a string or a list or vector of characters (integers).
390 usage: (concat &rest SEQUENCES) */)
391 (size_t nargs, Lisp_Object *args)
393 return concat (nargs, args, Lisp_String, 0);
396 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
397 doc: /* Concatenate all the arguments and make the result a vector.
398 The result is a vector whose elements are the elements of all the arguments.
399 Each argument may be a list, vector or string.
400 usage: (vconcat &rest SEQUENCES) */)
401 (size_t nargs, Lisp_Object *args)
403 return concat (nargs, args, Lisp_Vectorlike, 0);
407 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
408 doc: /* Return a copy of a list, vector, string or char-table.
409 The elements of a list or vector are not copied; they are shared
410 with the original. */)
411 (Lisp_Object arg)
413 if (NILP (arg)) return arg;
415 if (CHAR_TABLE_P (arg))
417 return copy_char_table (arg);
420 if (BOOL_VECTOR_P (arg))
422 Lisp_Object val;
423 int size_in_chars
424 = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
425 / BOOL_VECTOR_BITS_PER_CHAR);
427 val = Fmake_bool_vector (Flength (arg), Qnil);
428 memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
429 size_in_chars);
430 return val;
433 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
434 wrong_type_argument (Qsequencep, arg);
436 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
439 /* This structure holds information of an argument of `concat' that is
440 a string and has text properties to be copied. */
441 struct textprop_rec
443 int argnum; /* refer to ARGS (arguments of `concat') */
444 EMACS_INT from; /* refer to ARGS[argnum] (argument string) */
445 EMACS_INT to; /* refer to VAL (the target string) */
448 static Lisp_Object
449 concat (size_t nargs, Lisp_Object *args,
450 enum Lisp_Type target_type, int last_special)
452 Lisp_Object val;
453 register Lisp_Object tail;
454 register Lisp_Object this;
455 EMACS_INT toindex;
456 EMACS_INT toindex_byte = 0;
457 register EMACS_INT result_len;
458 register EMACS_INT result_len_byte;
459 register size_t argnum;
460 Lisp_Object last_tail;
461 Lisp_Object prev;
462 int some_multibyte;
463 /* When we make a multibyte string, we can't copy text properties
464 while concatinating each string because the length of resulting
465 string can't be decided until we finish the whole concatination.
466 So, we record strings that have text properties to be copied
467 here, and copy the text properties after the concatination. */
468 struct textprop_rec *textprops = NULL;
469 /* Number of elements in textprops. */
470 int num_textprops = 0;
471 USE_SAFE_ALLOCA;
473 tail = Qnil;
475 /* In append, the last arg isn't treated like the others */
476 if (last_special && nargs > 0)
478 nargs--;
479 last_tail = args[nargs];
481 else
482 last_tail = Qnil;
484 /* Check each argument. */
485 for (argnum = 0; argnum < nargs; argnum++)
487 this = args[argnum];
488 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
489 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
490 wrong_type_argument (Qsequencep, this);
493 /* Compute total length in chars of arguments in RESULT_LEN.
494 If desired output is a string, also compute length in bytes
495 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
496 whether the result should be a multibyte string. */
497 result_len_byte = 0;
498 result_len = 0;
499 some_multibyte = 0;
500 for (argnum = 0; argnum < nargs; argnum++)
502 EMACS_INT len;
503 this = args[argnum];
504 len = XFASTINT (Flength (this));
505 if (target_type == Lisp_String)
507 /* We must count the number of bytes needed in the string
508 as well as the number of characters. */
509 EMACS_INT i;
510 Lisp_Object ch;
511 EMACS_INT this_len_byte;
513 if (VECTORP (this))
514 for (i = 0; i < len; i++)
516 ch = AREF (this, i);
517 CHECK_CHARACTER (ch);
518 this_len_byte = CHAR_BYTES (XINT (ch));
519 result_len_byte += this_len_byte;
520 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
521 some_multibyte = 1;
523 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
524 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
525 else if (CONSP (this))
526 for (; CONSP (this); this = XCDR (this))
528 ch = XCAR (this);
529 CHECK_CHARACTER (ch);
530 this_len_byte = CHAR_BYTES (XINT (ch));
531 result_len_byte += this_len_byte;
532 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
533 some_multibyte = 1;
535 else if (STRINGP (this))
537 if (STRING_MULTIBYTE (this))
539 some_multibyte = 1;
540 result_len_byte += SBYTES (this);
542 else
543 result_len_byte += count_size_as_multibyte (SDATA (this),
544 SCHARS (this));
548 result_len += len;
549 if (result_len < 0)
550 error ("String overflow");
553 if (! some_multibyte)
554 result_len_byte = result_len;
556 /* Create the output object. */
557 if (target_type == Lisp_Cons)
558 val = Fmake_list (make_number (result_len), Qnil);
559 else if (target_type == Lisp_Vectorlike)
560 val = Fmake_vector (make_number (result_len), Qnil);
561 else if (some_multibyte)
562 val = make_uninit_multibyte_string (result_len, result_len_byte);
563 else
564 val = make_uninit_string (result_len);
566 /* In `append', if all but last arg are nil, return last arg. */
567 if (target_type == Lisp_Cons && EQ (val, Qnil))
568 return last_tail;
570 /* Copy the contents of the args into the result. */
571 if (CONSP (val))
572 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
573 else
574 toindex = 0, toindex_byte = 0;
576 prev = Qnil;
577 if (STRINGP (val))
578 SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
580 for (argnum = 0; argnum < nargs; argnum++)
582 Lisp_Object thislen;
583 EMACS_INT thisleni = 0;
584 register EMACS_INT thisindex = 0;
585 register EMACS_INT thisindex_byte = 0;
587 this = args[argnum];
588 if (!CONSP (this))
589 thislen = Flength (this), thisleni = XINT (thislen);
591 /* Between strings of the same kind, copy fast. */
592 if (STRINGP (this) && STRINGP (val)
593 && STRING_MULTIBYTE (this) == some_multibyte)
595 EMACS_INT thislen_byte = SBYTES (this);
597 memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
598 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
600 textprops[num_textprops].argnum = argnum;
601 textprops[num_textprops].from = 0;
602 textprops[num_textprops++].to = toindex;
604 toindex_byte += thislen_byte;
605 toindex += thisleni;
607 /* Copy a single-byte string to a multibyte string. */
608 else if (STRINGP (this) && STRINGP (val))
610 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
612 textprops[num_textprops].argnum = argnum;
613 textprops[num_textprops].from = 0;
614 textprops[num_textprops++].to = toindex;
616 toindex_byte += copy_text (SDATA (this),
617 SDATA (val) + toindex_byte,
618 SCHARS (this), 0, 1);
619 toindex += thisleni;
621 else
622 /* Copy element by element. */
623 while (1)
625 register Lisp_Object elt;
627 /* Fetch next element of `this' arg into `elt', or break if
628 `this' is exhausted. */
629 if (NILP (this)) break;
630 if (CONSP (this))
631 elt = XCAR (this), this = XCDR (this);
632 else if (thisindex >= thisleni)
633 break;
634 else if (STRINGP (this))
636 int c;
637 if (STRING_MULTIBYTE (this))
639 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
640 thisindex,
641 thisindex_byte);
642 XSETFASTINT (elt, c);
644 else
646 XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
647 if (some_multibyte
648 && !ASCII_CHAR_P (XINT (elt))
649 && XINT (elt) < 0400)
651 c = BYTE8_TO_CHAR (XINT (elt));
652 XSETINT (elt, c);
656 else if (BOOL_VECTOR_P (this))
658 int byte;
659 byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
660 if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
661 elt = Qt;
662 else
663 elt = Qnil;
664 thisindex++;
666 else
668 elt = AREF (this, thisindex);
669 thisindex++;
672 /* Store this element into the result. */
673 if (toindex < 0)
675 XSETCAR (tail, elt);
676 prev = tail;
677 tail = XCDR (tail);
679 else if (VECTORP (val))
681 ASET (val, toindex, elt);
682 toindex++;
684 else
686 CHECK_NUMBER (elt);
687 if (some_multibyte)
688 toindex_byte += CHAR_STRING (XINT (elt),
689 SDATA (val) + toindex_byte);
690 else
691 SSET (val, toindex_byte++, XINT (elt));
692 toindex++;
696 if (!NILP (prev))
697 XSETCDR (prev, last_tail);
699 if (num_textprops > 0)
701 Lisp_Object props;
702 EMACS_INT last_to_end = -1;
704 for (argnum = 0; argnum < num_textprops; argnum++)
706 this = args[textprops[argnum].argnum];
707 props = text_property_list (this,
708 make_number (0),
709 make_number (SCHARS (this)),
710 Qnil);
711 /* If successive arguments have properites, be sure that the
712 value of `composition' property be the copy. */
713 if (last_to_end == textprops[argnum].to)
714 make_composition_value_copy (props);
715 add_text_properties_from_list (val, props,
716 make_number (textprops[argnum].to));
717 last_to_end = textprops[argnum].to + SCHARS (this);
721 SAFE_FREE ();
722 return val;
725 static Lisp_Object string_char_byte_cache_string;
726 static EMACS_INT string_char_byte_cache_charpos;
727 static EMACS_INT string_char_byte_cache_bytepos;
729 void
730 clear_string_char_byte_cache (void)
732 string_char_byte_cache_string = Qnil;
735 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
737 EMACS_INT
738 string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
740 EMACS_INT i_byte;
741 EMACS_INT best_below, best_below_byte;
742 EMACS_INT best_above, best_above_byte;
744 best_below = best_below_byte = 0;
745 best_above = SCHARS (string);
746 best_above_byte = SBYTES (string);
747 if (best_above == best_above_byte)
748 return char_index;
750 if (EQ (string, string_char_byte_cache_string))
752 if (string_char_byte_cache_charpos < char_index)
754 best_below = string_char_byte_cache_charpos;
755 best_below_byte = string_char_byte_cache_bytepos;
757 else
759 best_above = string_char_byte_cache_charpos;
760 best_above_byte = string_char_byte_cache_bytepos;
764 if (char_index - best_below < best_above - char_index)
766 unsigned char *p = SDATA (string) + best_below_byte;
768 while (best_below < char_index)
770 p += BYTES_BY_CHAR_HEAD (*p);
771 best_below++;
773 i_byte = p - SDATA (string);
775 else
777 unsigned char *p = SDATA (string) + best_above_byte;
779 while (best_above > char_index)
781 p--;
782 while (!CHAR_HEAD_P (*p)) p--;
783 best_above--;
785 i_byte = p - SDATA (string);
788 string_char_byte_cache_bytepos = i_byte;
789 string_char_byte_cache_charpos = char_index;
790 string_char_byte_cache_string = string;
792 return i_byte;
795 /* Return the character index corresponding to BYTE_INDEX in STRING. */
797 EMACS_INT
798 string_byte_to_char (Lisp_Object string, EMACS_INT byte_index)
800 EMACS_INT i, i_byte;
801 EMACS_INT best_below, best_below_byte;
802 EMACS_INT best_above, best_above_byte;
804 best_below = best_below_byte = 0;
805 best_above = SCHARS (string);
806 best_above_byte = SBYTES (string);
807 if (best_above == best_above_byte)
808 return byte_index;
810 if (EQ (string, string_char_byte_cache_string))
812 if (string_char_byte_cache_bytepos < byte_index)
814 best_below = string_char_byte_cache_charpos;
815 best_below_byte = string_char_byte_cache_bytepos;
817 else
819 best_above = string_char_byte_cache_charpos;
820 best_above_byte = string_char_byte_cache_bytepos;
824 if (byte_index - best_below_byte < best_above_byte - byte_index)
826 unsigned char *p = SDATA (string) + best_below_byte;
827 unsigned char *pend = SDATA (string) + byte_index;
829 while (p < pend)
831 p += BYTES_BY_CHAR_HEAD (*p);
832 best_below++;
834 i = best_below;
835 i_byte = p - SDATA (string);
837 else
839 unsigned char *p = SDATA (string) + best_above_byte;
840 unsigned char *pbeg = SDATA (string) + byte_index;
842 while (p > pbeg)
844 p--;
845 while (!CHAR_HEAD_P (*p)) p--;
846 best_above--;
848 i = best_above;
849 i_byte = p - SDATA (string);
852 string_char_byte_cache_bytepos = i_byte;
853 string_char_byte_cache_charpos = i;
854 string_char_byte_cache_string = string;
856 return i;
859 /* Convert STRING to a multibyte string. */
861 static Lisp_Object
862 string_make_multibyte (Lisp_Object string)
864 unsigned char *buf;
865 EMACS_INT nbytes;
866 Lisp_Object ret;
867 USE_SAFE_ALLOCA;
869 if (STRING_MULTIBYTE (string))
870 return string;
872 nbytes = count_size_as_multibyte (SDATA (string),
873 SCHARS (string));
874 /* If all the chars are ASCII, they won't need any more bytes
875 once converted. In that case, we can return STRING itself. */
876 if (nbytes == SBYTES (string))
877 return string;
879 SAFE_ALLOCA (buf, unsigned char *, nbytes);
880 copy_text (SDATA (string), buf, SBYTES (string),
881 0, 1);
883 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
884 SAFE_FREE ();
886 return ret;
890 /* Convert STRING (if unibyte) to a multibyte string without changing
891 the number of characters. Characters 0200 trough 0237 are
892 converted to eight-bit characters. */
894 Lisp_Object
895 string_to_multibyte (Lisp_Object string)
897 unsigned char *buf;
898 EMACS_INT nbytes;
899 Lisp_Object ret;
900 USE_SAFE_ALLOCA;
902 if (STRING_MULTIBYTE (string))
903 return string;
905 nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
906 /* If all the chars are ASCII, they won't need any more bytes once
907 converted. */
908 if (nbytes == SBYTES (string))
909 return make_multibyte_string (SSDATA (string), nbytes, nbytes);
911 SAFE_ALLOCA (buf, unsigned char *, nbytes);
912 memcpy (buf, SDATA (string), SBYTES (string));
913 str_to_multibyte (buf, nbytes, SBYTES (string));
915 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
916 SAFE_FREE ();
918 return ret;
922 /* Convert STRING to a single-byte string. */
924 Lisp_Object
925 string_make_unibyte (Lisp_Object string)
927 EMACS_INT nchars;
928 unsigned char *buf;
929 Lisp_Object ret;
930 USE_SAFE_ALLOCA;
932 if (! STRING_MULTIBYTE (string))
933 return string;
935 nchars = SCHARS (string);
937 SAFE_ALLOCA (buf, unsigned char *, nchars);
938 copy_text (SDATA (string), buf, SBYTES (string),
939 1, 0);
941 ret = make_unibyte_string ((char *) buf, nchars);
942 SAFE_FREE ();
944 return ret;
947 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
948 1, 1, 0,
949 doc: /* Return the multibyte equivalent of STRING.
950 If STRING is unibyte and contains non-ASCII characters, the function
951 `unibyte-char-to-multibyte' is used to convert each unibyte character
952 to a multibyte character. In this case, the returned string is a
953 newly created string with no text properties. If STRING is multibyte
954 or entirely ASCII, it is returned unchanged. In particular, when
955 STRING is unibyte and entirely ASCII, the returned string is unibyte.
956 \(When the characters are all ASCII, Emacs primitives will treat the
957 string the same way whether it is unibyte or multibyte.) */)
958 (Lisp_Object string)
960 CHECK_STRING (string);
962 return string_make_multibyte (string);
965 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
966 1, 1, 0,
967 doc: /* Return the unibyte equivalent of STRING.
968 Multibyte character codes are converted to unibyte according to
969 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
970 If the lookup in the translation table fails, this function takes just
971 the low 8 bits of each character. */)
972 (Lisp_Object string)
974 CHECK_STRING (string);
976 return string_make_unibyte (string);
979 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
980 1, 1, 0,
981 doc: /* Return a unibyte string with the same individual bytes as STRING.
982 If STRING is unibyte, the result is STRING itself.
983 Otherwise it is a newly created string, with no text properties.
984 If STRING is multibyte and contains a character of charset
985 `eight-bit', it is converted to the corresponding single byte. */)
986 (Lisp_Object string)
988 CHECK_STRING (string);
990 if (STRING_MULTIBYTE (string))
992 EMACS_INT bytes = SBYTES (string);
993 unsigned char *str = (unsigned char *) xmalloc (bytes);
995 memcpy (str, SDATA (string), bytes);
996 bytes = str_as_unibyte (str, bytes);
997 string = make_unibyte_string ((char *) str, bytes);
998 xfree (str);
1000 return string;
1003 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1004 1, 1, 0,
1005 doc: /* Return a multibyte string with the same individual bytes as STRING.
1006 If STRING is multibyte, the result is STRING itself.
1007 Otherwise it is a newly created string, with no text properties.
1009 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1010 part of a correct utf-8 sequence), it is converted to the corresponding
1011 multibyte character of charset `eight-bit'.
1012 See also `string-to-multibyte'.
1014 Beware, this often doesn't really do what you think it does.
1015 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1016 If you're not sure, whether to use `string-as-multibyte' or
1017 `string-to-multibyte', use `string-to-multibyte'. */)
1018 (Lisp_Object string)
1020 CHECK_STRING (string);
1022 if (! STRING_MULTIBYTE (string))
1024 Lisp_Object new_string;
1025 EMACS_INT nchars, nbytes;
1027 parse_str_as_multibyte (SDATA (string),
1028 SBYTES (string),
1029 &nchars, &nbytes);
1030 new_string = make_uninit_multibyte_string (nchars, nbytes);
1031 memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
1032 if (nbytes != SBYTES (string))
1033 str_as_multibyte (SDATA (new_string), nbytes,
1034 SBYTES (string), NULL);
1035 string = new_string;
1036 STRING_SET_INTERVALS (string, NULL_INTERVAL);
1038 return string;
1041 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1042 1, 1, 0,
1043 doc: /* Return a multibyte string with the same individual chars as STRING.
1044 If STRING is multibyte, the result is STRING itself.
1045 Otherwise it is a newly created string, with no text properties.
1047 If STRING is unibyte and contains an 8-bit byte, it is converted to
1048 the corresponding multibyte character of charset `eight-bit'.
1050 This differs from `string-as-multibyte' by converting each byte of a correct
1051 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1052 correct sequence. */)
1053 (Lisp_Object string)
1055 CHECK_STRING (string);
1057 return string_to_multibyte (string);
1060 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1061 1, 1, 0,
1062 doc: /* Return a unibyte string with the same individual chars as STRING.
1063 If STRING is unibyte, the result is STRING itself.
1064 Otherwise it is a newly created string, with no text properties,
1065 where each `eight-bit' character is converted to the corresponding byte.
1066 If STRING contains a non-ASCII, non-`eight-bit' character,
1067 an error is signaled. */)
1068 (Lisp_Object string)
1070 CHECK_STRING (string);
1072 if (STRING_MULTIBYTE (string))
1074 EMACS_INT chars = SCHARS (string);
1075 unsigned char *str = (unsigned char *) xmalloc (chars);
1076 EMACS_INT converted = str_to_unibyte (SDATA (string), str, chars, 0);
1078 if (converted < chars)
1079 error ("Can't convert the %dth character to unibyte", converted);
1080 string = make_unibyte_string ((char *) str, chars);
1081 xfree (str);
1083 return string;
1087 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1088 doc: /* Return a copy of ALIST.
1089 This is an alist which represents the same mapping from objects to objects,
1090 but does not share the alist structure with ALIST.
1091 The objects mapped (cars and cdrs of elements of the alist)
1092 are shared, however.
1093 Elements of ALIST that are not conses are also shared. */)
1094 (Lisp_Object alist)
1096 register Lisp_Object tem;
1098 CHECK_LIST (alist);
1099 if (NILP (alist))
1100 return alist;
1101 alist = concat (1, &alist, Lisp_Cons, 0);
1102 for (tem = alist; CONSP (tem); tem = XCDR (tem))
1104 register Lisp_Object car;
1105 car = XCAR (tem);
1107 if (CONSP (car))
1108 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1110 return alist;
1113 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
1114 doc: /* Return a new string whose contents are a substring of STRING.
1115 The returned string consists of the characters between index FROM
1116 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1117 zero-indexed: 0 means the first character of STRING. Negative values
1118 are counted from the end of STRING. If TO is nil, the substring runs
1119 to the end of STRING.
1121 The STRING argument may also be a vector. In that case, the return
1122 value is a new vector that contains the elements between index FROM
1123 \(inclusive) and index TO (exclusive) of that vector argument. */)
1124 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1126 Lisp_Object res;
1127 EMACS_INT size;
1128 EMACS_INT size_byte = 0;
1129 EMACS_INT from_char, to_char;
1130 EMACS_INT from_byte = 0, to_byte = 0;
1132 CHECK_VECTOR_OR_STRING (string);
1133 CHECK_NUMBER (from);
1135 if (STRINGP (string))
1137 size = SCHARS (string);
1138 size_byte = SBYTES (string);
1140 else
1141 size = ASIZE (string);
1143 if (NILP (to))
1145 to_char = size;
1146 to_byte = size_byte;
1148 else
1150 CHECK_NUMBER (to);
1152 to_char = XINT (to);
1153 if (to_char < 0)
1154 to_char += size;
1156 if (STRINGP (string))
1157 to_byte = string_char_to_byte (string, to_char);
1160 from_char = XINT (from);
1161 if (from_char < 0)
1162 from_char += size;
1163 if (STRINGP (string))
1164 from_byte = string_char_to_byte (string, from_char);
1166 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1167 args_out_of_range_3 (string, make_number (from_char),
1168 make_number (to_char));
1170 if (STRINGP (string))
1172 res = make_specified_string (SSDATA (string) + from_byte,
1173 to_char - from_char, to_byte - from_byte,
1174 STRING_MULTIBYTE (string));
1175 copy_text_properties (make_number (from_char), make_number (to_char),
1176 string, make_number (0), res, Qnil);
1178 else
1179 res = Fvector (to_char - from_char, &AREF (string, from_char));
1181 return res;
1185 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1186 doc: /* Return a substring of STRING, without text properties.
1187 It starts at index FROM and ends before TO.
1188 TO may be nil or omitted; then the substring runs to the end of STRING.
1189 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1190 If FROM or TO is negative, it counts from the end.
1192 With one argument, just copy STRING without its properties. */)
1193 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1195 EMACS_INT size, size_byte;
1196 EMACS_INT from_char, to_char;
1197 EMACS_INT from_byte, to_byte;
1199 CHECK_STRING (string);
1201 size = SCHARS (string);
1202 size_byte = SBYTES (string);
1204 if (NILP (from))
1205 from_char = from_byte = 0;
1206 else
1208 CHECK_NUMBER (from);
1209 from_char = XINT (from);
1210 if (from_char < 0)
1211 from_char += size;
1213 from_byte = string_char_to_byte (string, from_char);
1216 if (NILP (to))
1218 to_char = size;
1219 to_byte = size_byte;
1221 else
1223 CHECK_NUMBER (to);
1225 to_char = XINT (to);
1226 if (to_char < 0)
1227 to_char += size;
1229 to_byte = string_char_to_byte (string, to_char);
1232 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1233 args_out_of_range_3 (string, make_number (from_char),
1234 make_number (to_char));
1236 return make_specified_string (SSDATA (string) + from_byte,
1237 to_char - from_char, to_byte - from_byte,
1238 STRING_MULTIBYTE (string));
1241 /* Extract a substring of STRING, giving start and end positions
1242 both in characters and in bytes. */
1244 Lisp_Object
1245 substring_both (Lisp_Object string, EMACS_INT from, EMACS_INT from_byte,
1246 EMACS_INT to, EMACS_INT to_byte)
1248 Lisp_Object res;
1249 EMACS_INT size;
1250 EMACS_INT size_byte;
1252 CHECK_VECTOR_OR_STRING (string);
1254 if (STRINGP (string))
1256 size = SCHARS (string);
1257 size_byte = SBYTES (string);
1259 else
1260 size = ASIZE (string);
1262 if (!(0 <= from && from <= to && to <= size))
1263 args_out_of_range_3 (string, make_number (from), make_number (to));
1265 if (STRINGP (string))
1267 res = make_specified_string (SSDATA (string) + from_byte,
1268 to - from, to_byte - from_byte,
1269 STRING_MULTIBYTE (string));
1270 copy_text_properties (make_number (from), make_number (to),
1271 string, make_number (0), res, Qnil);
1273 else
1274 res = Fvector (to - from, &AREF (string, from));
1276 return res;
1279 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1280 doc: /* Take cdr N times on LIST, return the result. */)
1281 (Lisp_Object n, Lisp_Object list)
1283 register int i, num;
1284 CHECK_NUMBER (n);
1285 num = XINT (n);
1286 for (i = 0; i < num && !NILP (list); i++)
1288 QUIT;
1289 CHECK_LIST_CONS (list, list);
1290 list = XCDR (list);
1292 return list;
1295 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1296 doc: /* Return the Nth element of LIST.
1297 N counts from zero. If LIST is not that long, nil is returned. */)
1298 (Lisp_Object n, Lisp_Object list)
1300 return Fcar (Fnthcdr (n, list));
1303 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1304 doc: /* Return element of SEQUENCE at index N. */)
1305 (register Lisp_Object sequence, Lisp_Object n)
1307 CHECK_NUMBER (n);
1308 if (CONSP (sequence) || NILP (sequence))
1309 return Fcar (Fnthcdr (n, sequence));
1311 /* Faref signals a "not array" error, so check here. */
1312 CHECK_ARRAY (sequence, Qsequencep);
1313 return Faref (sequence, n);
1316 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1317 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1318 The value is actually the tail of LIST whose car is ELT. */)
1319 (register Lisp_Object elt, Lisp_Object list)
1321 register Lisp_Object tail;
1322 for (tail = list; CONSP (tail); tail = XCDR (tail))
1324 register Lisp_Object tem;
1325 CHECK_LIST_CONS (tail, list);
1326 tem = XCAR (tail);
1327 if (! NILP (Fequal (elt, tem)))
1328 return tail;
1329 QUIT;
1331 return Qnil;
1334 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1335 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1336 The value is actually the tail of LIST whose car is ELT. */)
1337 (register Lisp_Object elt, Lisp_Object list)
1339 while (1)
1341 if (!CONSP (list) || EQ (XCAR (list), elt))
1342 break;
1344 list = XCDR (list);
1345 if (!CONSP (list) || EQ (XCAR (list), elt))
1346 break;
1348 list = XCDR (list);
1349 if (!CONSP (list) || EQ (XCAR (list), elt))
1350 break;
1352 list = XCDR (list);
1353 QUIT;
1356 CHECK_LIST (list);
1357 return list;
1360 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1361 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1362 The value is actually the tail of LIST whose car is ELT. */)
1363 (register Lisp_Object elt, Lisp_Object list)
1365 register Lisp_Object tail;
1367 if (!FLOATP (elt))
1368 return Fmemq (elt, list);
1370 for (tail = list; CONSP (tail); tail = XCDR (tail))
1372 register Lisp_Object tem;
1373 CHECK_LIST_CONS (tail, list);
1374 tem = XCAR (tail);
1375 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
1376 return tail;
1377 QUIT;
1379 return Qnil;
1382 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1383 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1384 The value is actually the first element of LIST whose car is KEY.
1385 Elements of LIST that are not conses are ignored. */)
1386 (Lisp_Object key, Lisp_Object list)
1388 while (1)
1390 if (!CONSP (list)
1391 || (CONSP (XCAR (list))
1392 && EQ (XCAR (XCAR (list)), key)))
1393 break;
1395 list = XCDR (list);
1396 if (!CONSP (list)
1397 || (CONSP (XCAR (list))
1398 && EQ (XCAR (XCAR (list)), key)))
1399 break;
1401 list = XCDR (list);
1402 if (!CONSP (list)
1403 || (CONSP (XCAR (list))
1404 && EQ (XCAR (XCAR (list)), key)))
1405 break;
1407 list = XCDR (list);
1408 QUIT;
1411 return CAR (list);
1414 /* Like Fassq but never report an error and do not allow quits.
1415 Use only on lists known never to be circular. */
1417 Lisp_Object
1418 assq_no_quit (Lisp_Object key, Lisp_Object list)
1420 while (CONSP (list)
1421 && (!CONSP (XCAR (list))
1422 || !EQ (XCAR (XCAR (list)), key)))
1423 list = XCDR (list);
1425 return CAR_SAFE (list);
1428 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1429 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1430 The value is actually the first element of LIST whose car equals KEY. */)
1431 (Lisp_Object key, Lisp_Object list)
1433 Lisp_Object car;
1435 while (1)
1437 if (!CONSP (list)
1438 || (CONSP (XCAR (list))
1439 && (car = XCAR (XCAR (list)),
1440 EQ (car, key) || !NILP (Fequal (car, key)))))
1441 break;
1443 list = XCDR (list);
1444 if (!CONSP (list)
1445 || (CONSP (XCAR (list))
1446 && (car = XCAR (XCAR (list)),
1447 EQ (car, key) || !NILP (Fequal (car, key)))))
1448 break;
1450 list = XCDR (list);
1451 if (!CONSP (list)
1452 || (CONSP (XCAR (list))
1453 && (car = XCAR (XCAR (list)),
1454 EQ (car, key) || !NILP (Fequal (car, key)))))
1455 break;
1457 list = XCDR (list);
1458 QUIT;
1461 return CAR (list);
1464 /* Like Fassoc but never report an error and do not allow quits.
1465 Use only on lists known never to be circular. */
1467 Lisp_Object
1468 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1470 while (CONSP (list)
1471 && (!CONSP (XCAR (list))
1472 || (!EQ (XCAR (XCAR (list)), key)
1473 && NILP (Fequal (XCAR (XCAR (list)), key)))))
1474 list = XCDR (list);
1476 return CONSP (list) ? XCAR (list) : Qnil;
1479 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1480 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1481 The value is actually the first element of LIST whose cdr is KEY. */)
1482 (register Lisp_Object key, Lisp_Object list)
1484 while (1)
1486 if (!CONSP (list)
1487 || (CONSP (XCAR (list))
1488 && EQ (XCDR (XCAR (list)), key)))
1489 break;
1491 list = XCDR (list);
1492 if (!CONSP (list)
1493 || (CONSP (XCAR (list))
1494 && EQ (XCDR (XCAR (list)), key)))
1495 break;
1497 list = XCDR (list);
1498 if (!CONSP (list)
1499 || (CONSP (XCAR (list))
1500 && EQ (XCDR (XCAR (list)), key)))
1501 break;
1503 list = XCDR (list);
1504 QUIT;
1507 return CAR (list);
1510 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1511 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1512 The value is actually the first element of LIST whose cdr equals KEY. */)
1513 (Lisp_Object key, Lisp_Object list)
1515 Lisp_Object cdr;
1517 while (1)
1519 if (!CONSP (list)
1520 || (CONSP (XCAR (list))
1521 && (cdr = XCDR (XCAR (list)),
1522 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1523 break;
1525 list = XCDR (list);
1526 if (!CONSP (list)
1527 || (CONSP (XCAR (list))
1528 && (cdr = XCDR (XCAR (list)),
1529 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1530 break;
1532 list = XCDR (list);
1533 if (!CONSP (list)
1534 || (CONSP (XCAR (list))
1535 && (cdr = XCDR (XCAR (list)),
1536 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1537 break;
1539 list = XCDR (list);
1540 QUIT;
1543 return CAR (list);
1546 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1547 doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
1548 The modified LIST is returned. Comparison is done with `eq'.
1549 If the first member of LIST is ELT, there is no way to remove it by side effect;
1550 therefore, write `(setq foo (delq element foo))'
1551 to be sure of changing the value of `foo'. */)
1552 (register Lisp_Object elt, Lisp_Object list)
1554 register Lisp_Object tail, prev;
1555 register Lisp_Object tem;
1557 tail = list;
1558 prev = Qnil;
1559 while (!NILP (tail))
1561 CHECK_LIST_CONS (tail, list);
1562 tem = XCAR (tail);
1563 if (EQ (elt, tem))
1565 if (NILP (prev))
1566 list = XCDR (tail);
1567 else
1568 Fsetcdr (prev, XCDR (tail));
1570 else
1571 prev = tail;
1572 tail = XCDR (tail);
1573 QUIT;
1575 return list;
1578 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1579 doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1580 SEQ must be a list, a vector, or a string.
1581 The modified SEQ is returned. Comparison is done with `equal'.
1582 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1583 is not a side effect; it is simply using a different sequence.
1584 Therefore, write `(setq foo (delete element foo))'
1585 to be sure of changing the value of `foo'. */)
1586 (Lisp_Object elt, Lisp_Object seq)
1588 if (VECTORP (seq))
1590 EMACS_INT i, n;
1592 for (i = n = 0; i < ASIZE (seq); ++i)
1593 if (NILP (Fequal (AREF (seq, i), elt)))
1594 ++n;
1596 if (n != ASIZE (seq))
1598 struct Lisp_Vector *p = allocate_vector (n);
1600 for (i = n = 0; i < ASIZE (seq); ++i)
1601 if (NILP (Fequal (AREF (seq, i), elt)))
1602 p->contents[n++] = AREF (seq, i);
1604 XSETVECTOR (seq, p);
1607 else if (STRINGP (seq))
1609 EMACS_INT i, ibyte, nchars, nbytes, cbytes;
1610 int c;
1612 for (i = nchars = nbytes = ibyte = 0;
1613 i < SCHARS (seq);
1614 ++i, ibyte += cbytes)
1616 if (STRING_MULTIBYTE (seq))
1618 c = STRING_CHAR (SDATA (seq) + ibyte);
1619 cbytes = CHAR_BYTES (c);
1621 else
1623 c = SREF (seq, i);
1624 cbytes = 1;
1627 if (!INTEGERP (elt) || c != XINT (elt))
1629 ++nchars;
1630 nbytes += cbytes;
1634 if (nchars != SCHARS (seq))
1636 Lisp_Object tem;
1638 tem = make_uninit_multibyte_string (nchars, nbytes);
1639 if (!STRING_MULTIBYTE (seq))
1640 STRING_SET_UNIBYTE (tem);
1642 for (i = nchars = nbytes = ibyte = 0;
1643 i < SCHARS (seq);
1644 ++i, ibyte += cbytes)
1646 if (STRING_MULTIBYTE (seq))
1648 c = STRING_CHAR (SDATA (seq) + ibyte);
1649 cbytes = CHAR_BYTES (c);
1651 else
1653 c = SREF (seq, i);
1654 cbytes = 1;
1657 if (!INTEGERP (elt) || c != XINT (elt))
1659 unsigned char *from = SDATA (seq) + ibyte;
1660 unsigned char *to = SDATA (tem) + nbytes;
1661 EMACS_INT n;
1663 ++nchars;
1664 nbytes += cbytes;
1666 for (n = cbytes; n--; )
1667 *to++ = *from++;
1671 seq = tem;
1674 else
1676 Lisp_Object tail, prev;
1678 for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
1680 CHECK_LIST_CONS (tail, seq);
1682 if (!NILP (Fequal (elt, XCAR (tail))))
1684 if (NILP (prev))
1685 seq = XCDR (tail);
1686 else
1687 Fsetcdr (prev, XCDR (tail));
1689 else
1690 prev = tail;
1691 QUIT;
1695 return seq;
1698 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1699 doc: /* Reverse LIST by modifying cdr pointers.
1700 Return the reversed list. */)
1701 (Lisp_Object list)
1703 register Lisp_Object prev, tail, next;
1705 if (NILP (list)) return list;
1706 prev = Qnil;
1707 tail = list;
1708 while (!NILP (tail))
1710 QUIT;
1711 CHECK_LIST_CONS (tail, list);
1712 next = XCDR (tail);
1713 Fsetcdr (tail, prev);
1714 prev = tail;
1715 tail = next;
1717 return prev;
1720 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1721 doc: /* Reverse LIST, copying. Return the reversed list.
1722 See also the function `nreverse', which is used more often. */)
1723 (Lisp_Object list)
1725 Lisp_Object new;
1727 for (new = Qnil; CONSP (list); list = XCDR (list))
1729 QUIT;
1730 new = Fcons (XCAR (list), new);
1732 CHECK_LIST_END (list, list);
1733 return new;
1736 Lisp_Object merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred);
1738 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1739 doc: /* Sort LIST, stably, comparing elements using PREDICATE.
1740 Returns the sorted list. LIST is modified by side effects.
1741 PREDICATE is called with two elements of LIST, and should return non-nil
1742 if the first element should sort before the second. */)
1743 (Lisp_Object list, Lisp_Object predicate)
1745 Lisp_Object front, back;
1746 register Lisp_Object len, tem;
1747 struct gcpro gcpro1, gcpro2;
1748 register int length;
1750 front = list;
1751 len = Flength (list);
1752 length = XINT (len);
1753 if (length < 2)
1754 return list;
1756 XSETINT (len, (length / 2) - 1);
1757 tem = Fnthcdr (len, list);
1758 back = Fcdr (tem);
1759 Fsetcdr (tem, Qnil);
1761 GCPRO2 (front, back);
1762 front = Fsort (front, predicate);
1763 back = Fsort (back, predicate);
1764 UNGCPRO;
1765 return merge (front, back, predicate);
1768 Lisp_Object
1769 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1771 Lisp_Object value;
1772 register Lisp_Object tail;
1773 Lisp_Object tem;
1774 register Lisp_Object l1, l2;
1775 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1777 l1 = org_l1;
1778 l2 = org_l2;
1779 tail = Qnil;
1780 value = Qnil;
1782 /* It is sufficient to protect org_l1 and org_l2.
1783 When l1 and l2 are updated, we copy the new values
1784 back into the org_ vars. */
1785 GCPRO4 (org_l1, org_l2, pred, value);
1787 while (1)
1789 if (NILP (l1))
1791 UNGCPRO;
1792 if (NILP (tail))
1793 return l2;
1794 Fsetcdr (tail, l2);
1795 return value;
1797 if (NILP (l2))
1799 UNGCPRO;
1800 if (NILP (tail))
1801 return l1;
1802 Fsetcdr (tail, l1);
1803 return value;
1805 tem = call2 (pred, Fcar (l2), Fcar (l1));
1806 if (NILP (tem))
1808 tem = l1;
1809 l1 = Fcdr (l1);
1810 org_l1 = l1;
1812 else
1814 tem = l2;
1815 l2 = Fcdr (l2);
1816 org_l2 = l2;
1818 if (NILP (tail))
1819 value = tem;
1820 else
1821 Fsetcdr (tail, tem);
1822 tail = tem;
1827 /* This does not check for quits. That is safe since it must terminate. */
1829 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1830 doc: /* Extract a value from a property list.
1831 PLIST is a property list, which is a list of the form
1832 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1833 corresponding to the given PROP, or nil if PROP is not one of the
1834 properties on the list. This function never signals an error. */)
1835 (Lisp_Object plist, Lisp_Object prop)
1837 Lisp_Object tail, halftail;
1839 /* halftail is used to detect circular lists. */
1840 tail = halftail = plist;
1841 while (CONSP (tail) && CONSP (XCDR (tail)))
1843 if (EQ (prop, XCAR (tail)))
1844 return XCAR (XCDR (tail));
1846 tail = XCDR (XCDR (tail));
1847 halftail = XCDR (halftail);
1848 if (EQ (tail, halftail))
1849 break;
1851 #if 0 /* Unsafe version. */
1852 /* This function can be called asynchronously
1853 (setup_coding_system). Don't QUIT in that case. */
1854 if (!interrupt_input_blocked)
1855 QUIT;
1856 #endif
1859 return Qnil;
1862 DEFUN ("get", Fget, Sget, 2, 2, 0,
1863 doc: /* Return the value of SYMBOL's PROPNAME property.
1864 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1865 (Lisp_Object symbol, Lisp_Object propname)
1867 CHECK_SYMBOL (symbol);
1868 return Fplist_get (XSYMBOL (symbol)->plist, propname);
1871 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1872 doc: /* Change value in PLIST of PROP to VAL.
1873 PLIST is a property list, which is a list of the form
1874 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1875 If PROP is already a property on the list, its value is set to VAL,
1876 otherwise the new PROP VAL pair is added. The new plist is returned;
1877 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1878 The PLIST is modified by side effects. */)
1879 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
1881 register Lisp_Object tail, prev;
1882 Lisp_Object newcell;
1883 prev = Qnil;
1884 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1885 tail = XCDR (XCDR (tail)))
1887 if (EQ (prop, XCAR (tail)))
1889 Fsetcar (XCDR (tail), val);
1890 return plist;
1893 prev = tail;
1894 QUIT;
1896 newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
1897 if (NILP (prev))
1898 return newcell;
1899 else
1900 Fsetcdr (XCDR (prev), newcell);
1901 return plist;
1904 DEFUN ("put", Fput, Sput, 3, 3, 0,
1905 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
1906 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1907 (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
1909 CHECK_SYMBOL (symbol);
1910 XSYMBOL (symbol)->plist
1911 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
1912 return value;
1915 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
1916 doc: /* Extract a value from a property list, comparing with `equal'.
1917 PLIST is a property list, which is a list of the form
1918 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1919 corresponding to the given PROP, or nil if PROP is not
1920 one of the properties on the list. */)
1921 (Lisp_Object plist, Lisp_Object prop)
1923 Lisp_Object tail;
1925 for (tail = plist;
1926 CONSP (tail) && CONSP (XCDR (tail));
1927 tail = XCDR (XCDR (tail)))
1929 if (! NILP (Fequal (prop, XCAR (tail))))
1930 return XCAR (XCDR (tail));
1932 QUIT;
1935 CHECK_LIST_END (tail, prop);
1937 return Qnil;
1940 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
1941 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1942 PLIST is a property list, which is a list of the form
1943 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1944 If PROP is already a property on the list, its value is set to VAL,
1945 otherwise the new PROP VAL pair is added. The new plist is returned;
1946 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1947 The PLIST is modified by side effects. */)
1948 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
1950 register Lisp_Object tail, prev;
1951 Lisp_Object newcell;
1952 prev = Qnil;
1953 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1954 tail = XCDR (XCDR (tail)))
1956 if (! NILP (Fequal (prop, XCAR (tail))))
1958 Fsetcar (XCDR (tail), val);
1959 return plist;
1962 prev = tail;
1963 QUIT;
1965 newcell = Fcons (prop, Fcons (val, Qnil));
1966 if (NILP (prev))
1967 return newcell;
1968 else
1969 Fsetcdr (XCDR (prev), newcell);
1970 return plist;
1973 DEFUN ("eql", Feql, Seql, 2, 2, 0,
1974 doc: /* Return t if the two args are the same Lisp object.
1975 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1976 (Lisp_Object obj1, Lisp_Object obj2)
1978 if (FLOATP (obj1))
1979 return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
1980 else
1981 return EQ (obj1, obj2) ? Qt : Qnil;
1984 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
1985 doc: /* Return t if two Lisp objects have similar structure and contents.
1986 They must have the same data type.
1987 Conses are compared by comparing the cars and the cdrs.
1988 Vectors and strings are compared element by element.
1989 Numbers are compared by value, but integers cannot equal floats.
1990 (Use `=' if you want integers and floats to be able to be equal.)
1991 Symbols must match exactly. */)
1992 (register Lisp_Object o1, Lisp_Object o2)
1994 return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
1997 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
1998 doc: /* Return t if two Lisp objects have similar structure and contents.
1999 This is like `equal' except that it compares the text properties
2000 of strings. (`equal' ignores text properties.) */)
2001 (register Lisp_Object o1, Lisp_Object o2)
2003 return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
2006 /* DEPTH is current depth of recursion. Signal an error if it
2007 gets too deep.
2008 PROPS, if non-nil, means compare string text properties too. */
2010 static int
2011 internal_equal (register Lisp_Object o1, register Lisp_Object o2, int depth, int props)
2013 if (depth > 200)
2014 error ("Stack overflow in equal");
2016 tail_recurse:
2017 QUIT;
2018 if (EQ (o1, o2))
2019 return 1;
2020 if (XTYPE (o1) != XTYPE (o2))
2021 return 0;
2023 switch (XTYPE (o1))
2025 case Lisp_Float:
2027 double d1, d2;
2029 d1 = extract_float (o1);
2030 d2 = extract_float (o2);
2031 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2032 though they are not =. */
2033 return d1 == d2 || (d1 != d1 && d2 != d2);
2036 case Lisp_Cons:
2037 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
2038 return 0;
2039 o1 = XCDR (o1);
2040 o2 = XCDR (o2);
2041 goto tail_recurse;
2043 case Lisp_Misc:
2044 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2045 return 0;
2046 if (OVERLAYP (o1))
2048 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2049 depth + 1, props)
2050 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2051 depth + 1, props))
2052 return 0;
2053 o1 = XOVERLAY (o1)->plist;
2054 o2 = XOVERLAY (o2)->plist;
2055 goto tail_recurse;
2057 if (MARKERP (o1))
2059 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2060 && (XMARKER (o1)->buffer == 0
2061 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2063 break;
2065 case Lisp_Vectorlike:
2067 register int i;
2068 EMACS_INT size = ASIZE (o1);
2069 /* Pseudovectors have the type encoded in the size field, so this test
2070 actually checks that the objects have the same type as well as the
2071 same size. */
2072 if (ASIZE (o2) != size)
2073 return 0;
2074 /* Boolvectors are compared much like strings. */
2075 if (BOOL_VECTOR_P (o1))
2077 int size_in_chars
2078 = ((XBOOL_VECTOR (o1)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2079 / BOOL_VECTOR_BITS_PER_CHAR);
2081 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
2082 return 0;
2083 if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
2084 size_in_chars))
2085 return 0;
2086 return 1;
2088 if (WINDOW_CONFIGURATIONP (o1))
2089 return compare_window_configurations (o1, o2, 0);
2091 /* Aside from them, only true vectors, char-tables, compiled
2092 functions, and fonts (font-spec, font-entity, font-ojbect)
2093 are sensible to compare, so eliminate the others now. */
2094 if (size & PSEUDOVECTOR_FLAG)
2096 if (!(size & (PVEC_COMPILED
2097 | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT)))
2098 return 0;
2099 size &= PSEUDOVECTOR_SIZE_MASK;
2101 for (i = 0; i < size; i++)
2103 Lisp_Object v1, v2;
2104 v1 = AREF (o1, i);
2105 v2 = AREF (o2, i);
2106 if (!internal_equal (v1, v2, depth + 1, props))
2107 return 0;
2109 return 1;
2111 break;
2113 case Lisp_String:
2114 if (SCHARS (o1) != SCHARS (o2))
2115 return 0;
2116 if (SBYTES (o1) != SBYTES (o2))
2117 return 0;
2118 if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
2119 return 0;
2120 if (props && !compare_string_intervals (o1, o2))
2121 return 0;
2122 return 1;
2124 default:
2125 break;
2128 return 0;
2132 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2133 doc: /* Store each element of ARRAY with ITEM.
2134 ARRAY is a vector, string, char-table, or bool-vector. */)
2135 (Lisp_Object array, Lisp_Object item)
2137 register EMACS_INT size, idx;
2138 int charval;
2140 if (VECTORP (array))
2142 register Lisp_Object *p = XVECTOR (array)->contents;
2143 size = ASIZE (array);
2144 for (idx = 0; idx < size; idx++)
2145 p[idx] = item;
2147 else if (CHAR_TABLE_P (array))
2149 int i;
2151 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2152 XCHAR_TABLE (array)->contents[i] = item;
2153 XCHAR_TABLE (array)->defalt = item;
2155 else if (STRINGP (array))
2157 register unsigned char *p = SDATA (array);
2158 CHECK_NUMBER (item);
2159 charval = XINT (item);
2160 size = SCHARS (array);
2161 if (STRING_MULTIBYTE (array))
2163 unsigned char str[MAX_MULTIBYTE_LENGTH];
2164 int len = CHAR_STRING (charval, str);
2165 EMACS_INT size_byte = SBYTES (array);
2166 unsigned char *p1 = p, *endp = p + size_byte;
2167 int i;
2169 if (size != size_byte)
2170 while (p1 < endp)
2172 int this_len = BYTES_BY_CHAR_HEAD (*p1);
2173 if (len != this_len)
2174 error ("Attempt to change byte length of a string");
2175 p1 += this_len;
2177 for (i = 0; i < size_byte; i++)
2178 *p++ = str[i % len];
2180 else
2181 for (idx = 0; idx < size; idx++)
2182 p[idx] = charval;
2184 else if (BOOL_VECTOR_P (array))
2186 register unsigned char *p = XBOOL_VECTOR (array)->data;
2187 int size_in_chars
2188 = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2189 / BOOL_VECTOR_BITS_PER_CHAR);
2191 charval = (! NILP (item) ? -1 : 0);
2192 for (idx = 0; idx < size_in_chars - 1; idx++)
2193 p[idx] = charval;
2194 if (idx < size_in_chars)
2196 /* Mask out bits beyond the vector size. */
2197 if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)
2198 charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2199 p[idx] = charval;
2202 else
2203 wrong_type_argument (Qarrayp, array);
2204 return array;
2207 DEFUN ("clear-string", Fclear_string, Sclear_string,
2208 1, 1, 0,
2209 doc: /* Clear the contents of STRING.
2210 This makes STRING unibyte and may change its length. */)
2211 (Lisp_Object string)
2213 EMACS_INT len;
2214 CHECK_STRING (string);
2215 len = SBYTES (string);
2216 memset (SDATA (string), 0, len);
2217 STRING_SET_CHARS (string, len);
2218 STRING_SET_UNIBYTE (string);
2219 return Qnil;
2222 /* ARGSUSED */
2223 Lisp_Object
2224 nconc2 (Lisp_Object s1, Lisp_Object s2)
2226 Lisp_Object args[2];
2227 args[0] = s1;
2228 args[1] = s2;
2229 return Fnconc (2, args);
2232 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2233 doc: /* Concatenate any number of lists by altering them.
2234 Only the last argument is not altered, and need not be a list.
2235 usage: (nconc &rest LISTS) */)
2236 (size_t nargs, Lisp_Object *args)
2238 register size_t argnum;
2239 register Lisp_Object tail, tem, val;
2241 val = tail = Qnil;
2243 for (argnum = 0; argnum < nargs; argnum++)
2245 tem = args[argnum];
2246 if (NILP (tem)) continue;
2248 if (NILP (val))
2249 val = tem;
2251 if (argnum + 1 == nargs) break;
2253 CHECK_LIST_CONS (tem, tem);
2255 while (CONSP (tem))
2257 tail = tem;
2258 tem = XCDR (tail);
2259 QUIT;
2262 tem = args[argnum + 1];
2263 Fsetcdr (tail, tem);
2264 if (NILP (tem))
2265 args[argnum + 1] = tail;
2268 return val;
2271 /* This is the guts of all mapping functions.
2272 Apply FN to each element of SEQ, one by one,
2273 storing the results into elements of VALS, a C vector of Lisp_Objects.
2274 LENI is the length of VALS, which should also be the length of SEQ. */
2276 static void
2277 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2279 register Lisp_Object tail;
2280 Lisp_Object dummy;
2281 register EMACS_INT i;
2282 struct gcpro gcpro1, gcpro2, gcpro3;
2284 if (vals)
2286 /* Don't let vals contain any garbage when GC happens. */
2287 for (i = 0; i < leni; i++)
2288 vals[i] = Qnil;
2290 GCPRO3 (dummy, fn, seq);
2291 gcpro1.var = vals;
2292 gcpro1.nvars = leni;
2294 else
2295 GCPRO2 (fn, seq);
2296 /* We need not explicitly protect `tail' because it is used only on lists, and
2297 1) lists are not relocated and 2) the list is marked via `seq' so will not
2298 be freed */
2300 if (VECTORP (seq))
2302 for (i = 0; i < leni; i++)
2304 dummy = call1 (fn, AREF (seq, i));
2305 if (vals)
2306 vals[i] = dummy;
2309 else if (BOOL_VECTOR_P (seq))
2311 for (i = 0; i < leni; i++)
2313 int byte;
2314 byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
2315 dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
2316 dummy = call1 (fn, dummy);
2317 if (vals)
2318 vals[i] = dummy;
2321 else if (STRINGP (seq))
2323 EMACS_INT i_byte;
2325 for (i = 0, i_byte = 0; i < leni;)
2327 int c;
2328 EMACS_INT i_before = i;
2330 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2331 XSETFASTINT (dummy, c);
2332 dummy = call1 (fn, dummy);
2333 if (vals)
2334 vals[i_before] = dummy;
2337 else /* Must be a list, since Flength did not get an error */
2339 tail = seq;
2340 for (i = 0; i < leni && CONSP (tail); i++)
2342 dummy = call1 (fn, XCAR (tail));
2343 if (vals)
2344 vals[i] = dummy;
2345 tail = XCDR (tail);
2349 UNGCPRO;
2352 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2353 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2354 In between each pair of results, stick in SEPARATOR. Thus, " " as
2355 SEPARATOR results in spaces between the values returned by FUNCTION.
2356 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2357 (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
2359 Lisp_Object len;
2360 register EMACS_INT leni;
2361 int nargs;
2362 register Lisp_Object *args;
2363 register EMACS_INT i;
2364 struct gcpro gcpro1;
2365 Lisp_Object ret;
2366 USE_SAFE_ALLOCA;
2368 len = Flength (sequence);
2369 if (CHAR_TABLE_P (sequence))
2370 wrong_type_argument (Qlistp, sequence);
2371 leni = XINT (len);
2372 nargs = leni + leni - 1;
2373 if (nargs < 0) return empty_unibyte_string;
2375 SAFE_ALLOCA_LISP (args, nargs);
2377 GCPRO1 (separator);
2378 mapcar1 (leni, args, function, sequence);
2379 UNGCPRO;
2381 for (i = leni - 1; i > 0; i--)
2382 args[i + i] = args[i];
2384 for (i = 1; i < nargs; i += 2)
2385 args[i] = separator;
2387 ret = Fconcat (nargs, args);
2388 SAFE_FREE ();
2390 return ret;
2393 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2394 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2395 The result is a list just as long as SEQUENCE.
2396 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2397 (Lisp_Object function, Lisp_Object sequence)
2399 register Lisp_Object len;
2400 register EMACS_INT leni;
2401 register Lisp_Object *args;
2402 Lisp_Object ret;
2403 USE_SAFE_ALLOCA;
2405 len = Flength (sequence);
2406 if (CHAR_TABLE_P (sequence))
2407 wrong_type_argument (Qlistp, sequence);
2408 leni = XFASTINT (len);
2410 SAFE_ALLOCA_LISP (args, leni);
2412 mapcar1 (leni, args, function, sequence);
2414 ret = Flist (leni, args);
2415 SAFE_FREE ();
2417 return ret;
2420 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2421 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2422 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2423 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2424 (Lisp_Object function, Lisp_Object sequence)
2426 register EMACS_INT leni;
2428 leni = XFASTINT (Flength (sequence));
2429 if (CHAR_TABLE_P (sequence))
2430 wrong_type_argument (Qlistp, sequence);
2431 mapcar1 (leni, 0, function, sequence);
2433 return sequence;
2436 /* This is how C code calls `yes-or-no-p' and allows the user
2437 to redefined it.
2439 Anything that calls this function must protect from GC! */
2441 Lisp_Object
2442 do_yes_or_no_p (Lisp_Object prompt)
2444 return call1 (intern ("yes-or-no-p"), prompt);
2447 /* Anything that calls this function must protect from GC! */
2449 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2450 doc: /* Ask user a yes-or-no question. Return t if answer is yes.
2451 PROMPT is the string to display to ask the question. It should end in
2452 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2454 The user must confirm the answer with RET, and can edit it until it
2455 has been confirmed.
2457 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2458 is nil, and `use-dialog-box' is non-nil. */)
2459 (Lisp_Object prompt)
2461 register Lisp_Object ans;
2462 Lisp_Object args[2];
2463 struct gcpro gcpro1;
2465 CHECK_STRING (prompt);
2467 #ifdef HAVE_MENUS
2468 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2469 && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2470 && use_dialog_box
2471 && have_menus_p ())
2473 Lisp_Object pane, menu, obj;
2474 redisplay_preserve_echo_area (4);
2475 pane = Fcons (Fcons (build_string ("Yes"), Qt),
2476 Fcons (Fcons (build_string ("No"), Qnil),
2477 Qnil));
2478 GCPRO1 (pane);
2479 menu = Fcons (prompt, pane);
2480 obj = Fx_popup_dialog (Qt, menu, Qnil);
2481 UNGCPRO;
2482 return obj;
2484 #endif /* HAVE_MENUS */
2486 args[0] = prompt;
2487 args[1] = build_string ("(yes or no) ");
2488 prompt = Fconcat (2, args);
2490 GCPRO1 (prompt);
2492 while (1)
2494 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2495 Qyes_or_no_p_history, Qnil,
2496 Qnil));
2497 if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
2499 UNGCPRO;
2500 return Qt;
2502 if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
2504 UNGCPRO;
2505 return Qnil;
2508 Fding (Qnil);
2509 Fdiscard_input ();
2510 message ("Please answer yes or no.");
2511 Fsleep_for (make_number (2), Qnil);
2515 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2516 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2518 Each of the three load averages is multiplied by 100, then converted
2519 to integer.
2521 When USE-FLOATS is non-nil, floats will be used instead of integers.
2522 These floats are not multiplied by 100.
2524 If the 5-minute or 15-minute load averages are not available, return a
2525 shortened list, containing only those averages which are available.
2527 An error is thrown if the load average can't be obtained. In some
2528 cases making it work would require Emacs being installed setuid or
2529 setgid so that it can read kernel information, and that usually isn't
2530 advisable. */)
2531 (Lisp_Object use_floats)
2533 double load_ave[3];
2534 int loads = getloadavg (load_ave, 3);
2535 Lisp_Object ret = Qnil;
2537 if (loads < 0)
2538 error ("load-average not implemented for this operating system");
2540 while (loads-- > 0)
2542 Lisp_Object load = (NILP (use_floats) ?
2543 make_number ((int) (100.0 * load_ave[loads]))
2544 : make_float (load_ave[loads]));
2545 ret = Fcons (load, ret);
2548 return ret;
2551 Lisp_Object Qsubfeatures;
2553 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2554 doc: /* Return t if FEATURE is present in this Emacs.
2556 Use this to conditionalize execution of lisp code based on the
2557 presence or absence of Emacs or environment extensions.
2558 Use `provide' to declare that a feature is available. This function
2559 looks at the value of the variable `features'. The optional argument
2560 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2561 (Lisp_Object feature, Lisp_Object subfeature)
2563 register Lisp_Object tem;
2564 CHECK_SYMBOL (feature);
2565 tem = Fmemq (feature, Vfeatures);
2566 if (!NILP (tem) && !NILP (subfeature))
2567 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2568 return (NILP (tem)) ? Qnil : Qt;
2571 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2572 doc: /* Announce that FEATURE is a feature of the current Emacs.
2573 The optional argument SUBFEATURES should be a list of symbols listing
2574 particular subfeatures supported in this version of FEATURE. */)
2575 (Lisp_Object feature, Lisp_Object subfeatures)
2577 register Lisp_Object tem;
2578 CHECK_SYMBOL (feature);
2579 CHECK_LIST (subfeatures);
2580 if (!NILP (Vautoload_queue))
2581 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2582 Vautoload_queue);
2583 tem = Fmemq (feature, Vfeatures);
2584 if (NILP (tem))
2585 Vfeatures = Fcons (feature, Vfeatures);
2586 if (!NILP (subfeatures))
2587 Fput (feature, Qsubfeatures, subfeatures);
2588 LOADHIST_ATTACH (Fcons (Qprovide, feature));
2590 /* Run any load-hooks for this file. */
2591 tem = Fassq (feature, Vafter_load_alist);
2592 if (CONSP (tem))
2593 Fprogn (XCDR (tem));
2595 return feature;
2598 /* `require' and its subroutines. */
2600 /* List of features currently being require'd, innermost first. */
2602 static Lisp_Object require_nesting_list;
2604 static Lisp_Object
2605 require_unwind (Lisp_Object old_value)
2607 return require_nesting_list = old_value;
2610 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2611 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2612 If FEATURE is not a member of the list `features', then the feature
2613 is not loaded; so load the file FILENAME.
2614 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2615 and `load' will try to load this name appended with the suffix `.elc' or
2616 `.el', in that order. The name without appended suffix will not be used.
2617 If the optional third argument NOERROR is non-nil,
2618 then return nil if the file is not found instead of signaling an error.
2619 Normally the return value is FEATURE.
2620 The normal messages at start and end of loading FILENAME are suppressed. */)
2621 (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
2623 register Lisp_Object tem;
2624 struct gcpro gcpro1, gcpro2;
2625 int from_file = load_in_progress;
2627 CHECK_SYMBOL (feature);
2629 /* Record the presence of `require' in this file
2630 even if the feature specified is already loaded.
2631 But not more than once in any file,
2632 and not when we aren't loading or reading from a file. */
2633 if (!from_file)
2634 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2635 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2636 from_file = 1;
2638 if (from_file)
2640 tem = Fcons (Qrequire, feature);
2641 if (NILP (Fmember (tem, Vcurrent_load_list)))
2642 LOADHIST_ATTACH (tem);
2644 tem = Fmemq (feature, Vfeatures);
2646 if (NILP (tem))
2648 int count = SPECPDL_INDEX ();
2649 int nesting = 0;
2651 /* This is to make sure that loadup.el gives a clear picture
2652 of what files are preloaded and when. */
2653 if (! NILP (Vpurify_flag))
2654 error ("(require %s) while preparing to dump",
2655 SDATA (SYMBOL_NAME (feature)));
2657 /* A certain amount of recursive `require' is legitimate,
2658 but if we require the same feature recursively 3 times,
2659 signal an error. */
2660 tem = require_nesting_list;
2661 while (! NILP (tem))
2663 if (! NILP (Fequal (feature, XCAR (tem))))
2664 nesting++;
2665 tem = XCDR (tem);
2667 if (nesting > 3)
2668 error ("Recursive `require' for feature `%s'",
2669 SDATA (SYMBOL_NAME (feature)));
2671 /* Update the list for any nested `require's that occur. */
2672 record_unwind_protect (require_unwind, require_nesting_list);
2673 require_nesting_list = Fcons (feature, require_nesting_list);
2675 /* Value saved here is to be restored into Vautoload_queue */
2676 record_unwind_protect (un_autoload, Vautoload_queue);
2677 Vautoload_queue = Qt;
2679 /* Load the file. */
2680 GCPRO2 (feature, filename);
2681 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2682 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2683 UNGCPRO;
2685 /* If load failed entirely, return nil. */
2686 if (NILP (tem))
2687 return unbind_to (count, Qnil);
2689 tem = Fmemq (feature, Vfeatures);
2690 if (NILP (tem))
2691 error ("Required feature `%s' was not provided",
2692 SDATA (SYMBOL_NAME (feature)));
2694 /* Once loading finishes, don't undo it. */
2695 Vautoload_queue = Qt;
2696 feature = unbind_to (count, feature);
2699 return feature;
2702 /* Primitives for work of the "widget" library.
2703 In an ideal world, this section would not have been necessary.
2704 However, lisp function calls being as slow as they are, it turns
2705 out that some functions in the widget library (wid-edit.el) are the
2706 bottleneck of Widget operation. Here is their translation to C,
2707 for the sole reason of efficiency. */
2709 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2710 doc: /* Return non-nil if PLIST has the property PROP.
2711 PLIST is a property list, which is a list of the form
2712 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2713 Unlike `plist-get', this allows you to distinguish between a missing
2714 property and a property with the value nil.
2715 The value is actually the tail of PLIST whose car is PROP. */)
2716 (Lisp_Object plist, Lisp_Object prop)
2718 while (CONSP (plist) && !EQ (XCAR (plist), prop))
2720 QUIT;
2721 plist = XCDR (plist);
2722 plist = CDR (plist);
2724 return plist;
2727 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2728 doc: /* In WIDGET, set PROPERTY to VALUE.
2729 The value can later be retrieved with `widget-get'. */)
2730 (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
2732 CHECK_CONS (widget);
2733 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
2734 return value;
2737 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2738 doc: /* In WIDGET, get the value of PROPERTY.
2739 The value could either be specified when the widget was created, or
2740 later with `widget-put'. */)
2741 (Lisp_Object widget, Lisp_Object property)
2743 Lisp_Object tmp;
2745 while (1)
2747 if (NILP (widget))
2748 return Qnil;
2749 CHECK_CONS (widget);
2750 tmp = Fplist_member (XCDR (widget), property);
2751 if (CONSP (tmp))
2753 tmp = XCDR (tmp);
2754 return CAR (tmp);
2756 tmp = XCAR (widget);
2757 if (NILP (tmp))
2758 return Qnil;
2759 widget = Fget (tmp, Qwidget_type);
2763 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2764 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2765 ARGS are passed as extra arguments to the function.
2766 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2767 (size_t nargs, Lisp_Object *args)
2769 /* This function can GC. */
2770 Lisp_Object newargs[3];
2771 struct gcpro gcpro1, gcpro2;
2772 Lisp_Object result;
2774 newargs[0] = Fwidget_get (args[0], args[1]);
2775 newargs[1] = args[0];
2776 newargs[2] = Flist (nargs - 2, args + 2);
2777 GCPRO2 (newargs[0], newargs[2]);
2778 result = Fapply (3, newargs);
2779 UNGCPRO;
2780 return result;
2783 #ifdef HAVE_LANGINFO_CODESET
2784 #include <langinfo.h>
2785 #endif
2787 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
2788 doc: /* Access locale data ITEM for the current C locale, if available.
2789 ITEM should be one of the following:
2791 `codeset', returning the character set as a string (locale item CODESET);
2793 `days', returning a 7-element vector of day names (locale items DAY_n);
2795 `months', returning a 12-element vector of month names (locale items MON_n);
2797 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2798 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2800 If the system can't provide such information through a call to
2801 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2803 See also Info node `(libc)Locales'.
2805 The data read from the system are decoded using `locale-coding-system'. */)
2806 (Lisp_Object item)
2808 char *str = NULL;
2809 #ifdef HAVE_LANGINFO_CODESET
2810 Lisp_Object val;
2811 if (EQ (item, Qcodeset))
2813 str = nl_langinfo (CODESET);
2814 return build_string (str);
2816 #ifdef DAY_1
2817 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
2819 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
2820 const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
2821 int i;
2822 struct gcpro gcpro1;
2823 GCPRO1 (v);
2824 synchronize_system_time_locale ();
2825 for (i = 0; i < 7; i++)
2827 str = nl_langinfo (days[i]);
2828 val = make_unibyte_string (str, strlen (str));
2829 /* Fixme: Is this coding system necessarily right, even if
2830 it is consistent with CODESET? If not, what to do? */
2831 Faset (v, make_number (i),
2832 code_convert_string_norecord (val, Vlocale_coding_system,
2833 0));
2835 UNGCPRO;
2836 return v;
2838 #endif /* DAY_1 */
2839 #ifdef MON_1
2840 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
2842 Lisp_Object v = Fmake_vector (make_number (12), Qnil);
2843 const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
2844 MON_8, MON_9, MON_10, MON_11, MON_12};
2845 int i;
2846 struct gcpro gcpro1;
2847 GCPRO1 (v);
2848 synchronize_system_time_locale ();
2849 for (i = 0; i < 12; i++)
2851 str = nl_langinfo (months[i]);
2852 val = make_unibyte_string (str, strlen (str));
2853 Faset (v, make_number (i),
2854 code_convert_string_norecord (val, Vlocale_coding_system, 0));
2856 UNGCPRO;
2857 return v;
2859 #endif /* MON_1 */
2860 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2861 but is in the locale files. This could be used by ps-print. */
2862 #ifdef PAPER_WIDTH
2863 else if (EQ (item, Qpaper))
2865 return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
2866 make_number (nl_langinfo (PAPER_HEIGHT)));
2868 #endif /* PAPER_WIDTH */
2869 #endif /* HAVE_LANGINFO_CODESET*/
2870 return Qnil;
2873 /* base64 encode/decode functions (RFC 2045).
2874 Based on code from GNU recode. */
2876 #define MIME_LINE_LENGTH 76
2878 #define IS_ASCII(Character) \
2879 ((Character) < 128)
2880 #define IS_BASE64(Character) \
2881 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2882 #define IS_BASE64_IGNORABLE(Character) \
2883 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2884 || (Character) == '\f' || (Character) == '\r')
2886 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2887 character or return retval if there are no characters left to
2888 process. */
2889 #define READ_QUADRUPLET_BYTE(retval) \
2890 do \
2892 if (i == length) \
2894 if (nchars_return) \
2895 *nchars_return = nchars; \
2896 return (retval); \
2898 c = from[i++]; \
2900 while (IS_BASE64_IGNORABLE (c))
2902 /* Table of characters coding the 64 values. */
2903 static const char base64_value_to_char[64] =
2905 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2906 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2907 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2908 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2909 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2910 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2911 '8', '9', '+', '/' /* 60-63 */
2914 /* Table of base64 values for first 128 characters. */
2915 static const short base64_char_to_value[128] =
2917 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2918 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2920 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2921 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2922 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2923 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2924 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2925 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2926 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2927 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2928 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2929 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2932 /* The following diagram shows the logical steps by which three octets
2933 get transformed into four base64 characters.
2935 .--------. .--------. .--------.
2936 |aaaaaabb| |bbbbcccc| |ccdddddd|
2937 `--------' `--------' `--------'
2938 6 2 4 4 2 6
2939 .--------+--------+--------+--------.
2940 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2941 `--------+--------+--------+--------'
2943 .--------+--------+--------+--------.
2944 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2945 `--------+--------+--------+--------'
2947 The octets are divided into 6 bit chunks, which are then encoded into
2948 base64 characters. */
2951 static EMACS_INT base64_encode_1 (const char *, char *, EMACS_INT, int, int);
2952 static EMACS_INT base64_decode_1 (const char *, char *, EMACS_INT, int,
2953 EMACS_INT *);
2955 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
2956 2, 3, "r",
2957 doc: /* Base64-encode the region between BEG and END.
2958 Return the length of the encoded text.
2959 Optional third argument NO-LINE-BREAK means do not break long lines
2960 into shorter lines. */)
2961 (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
2963 char *encoded;
2964 EMACS_INT allength, length;
2965 EMACS_INT ibeg, iend, encoded_length;
2966 EMACS_INT old_pos = PT;
2967 USE_SAFE_ALLOCA;
2969 validate_region (&beg, &end);
2971 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
2972 iend = CHAR_TO_BYTE (XFASTINT (end));
2973 move_gap_both (XFASTINT (beg), ibeg);
2975 /* We need to allocate enough room for encoding the text.
2976 We need 33 1/3% more space, plus a newline every 76
2977 characters, and then we round up. */
2978 length = iend - ibeg;
2979 allength = length + length/3 + 1;
2980 allength += allength / MIME_LINE_LENGTH + 1 + 6;
2982 SAFE_ALLOCA (encoded, char *, allength);
2983 encoded_length = base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg),
2984 encoded, length, NILP (no_line_break),
2985 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
2986 if (encoded_length > allength)
2987 abort ();
2989 if (encoded_length < 0)
2991 /* The encoding wasn't possible. */
2992 SAFE_FREE ();
2993 error ("Multibyte character in data for base64 encoding");
2996 /* Now we have encoded the region, so we insert the new contents
2997 and delete the old. (Insert first in order to preserve markers.) */
2998 SET_PT_BOTH (XFASTINT (beg), ibeg);
2999 insert (encoded, encoded_length);
3000 SAFE_FREE ();
3001 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3003 /* If point was outside of the region, restore it exactly; else just
3004 move to the beginning of the region. */
3005 if (old_pos >= XFASTINT (end))
3006 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3007 else if (old_pos > XFASTINT (beg))
3008 old_pos = XFASTINT (beg);
3009 SET_PT (old_pos);
3011 /* We return the length of the encoded text. */
3012 return make_number (encoded_length);
3015 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3016 1, 2, 0,
3017 doc: /* Base64-encode STRING and return the result.
3018 Optional second argument NO-LINE-BREAK means do not break long lines
3019 into shorter lines. */)
3020 (Lisp_Object string, Lisp_Object no_line_break)
3022 EMACS_INT allength, length, encoded_length;
3023 char *encoded;
3024 Lisp_Object encoded_string;
3025 USE_SAFE_ALLOCA;
3027 CHECK_STRING (string);
3029 /* We need to allocate enough room for encoding the text.
3030 We need 33 1/3% more space, plus a newline every 76
3031 characters, and then we round up. */
3032 length = SBYTES (string);
3033 allength = length + length/3 + 1;
3034 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3036 /* We need to allocate enough room for decoding the text. */
3037 SAFE_ALLOCA (encoded, char *, allength);
3039 encoded_length = base64_encode_1 (SSDATA (string),
3040 encoded, length, NILP (no_line_break),
3041 STRING_MULTIBYTE (string));
3042 if (encoded_length > allength)
3043 abort ();
3045 if (encoded_length < 0)
3047 /* The encoding wasn't possible. */
3048 SAFE_FREE ();
3049 error ("Multibyte character in data for base64 encoding");
3052 encoded_string = make_unibyte_string (encoded, encoded_length);
3053 SAFE_FREE ();
3055 return encoded_string;
3058 static EMACS_INT
3059 base64_encode_1 (const char *from, char *to, EMACS_INT length,
3060 int line_break, int multibyte)
3062 int counter = 0;
3063 EMACS_INT i = 0;
3064 char *e = to;
3065 int c;
3066 unsigned int value;
3067 int bytes;
3069 while (i < length)
3071 if (multibyte)
3073 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3074 if (CHAR_BYTE8_P (c))
3075 c = CHAR_TO_BYTE8 (c);
3076 else if (c >= 256)
3077 return -1;
3078 i += bytes;
3080 else
3081 c = from[i++];
3083 /* Wrap line every 76 characters. */
3085 if (line_break)
3087 if (counter < MIME_LINE_LENGTH / 4)
3088 counter++;
3089 else
3091 *e++ = '\n';
3092 counter = 1;
3096 /* Process first byte of a triplet. */
3098 *e++ = base64_value_to_char[0x3f & c >> 2];
3099 value = (0x03 & c) << 4;
3101 /* Process second byte of a triplet. */
3103 if (i == length)
3105 *e++ = base64_value_to_char[value];
3106 *e++ = '=';
3107 *e++ = '=';
3108 break;
3111 if (multibyte)
3113 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3114 if (CHAR_BYTE8_P (c))
3115 c = CHAR_TO_BYTE8 (c);
3116 else if (c >= 256)
3117 return -1;
3118 i += bytes;
3120 else
3121 c = from[i++];
3123 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3124 value = (0x0f & c) << 2;
3126 /* Process third byte of a triplet. */
3128 if (i == length)
3130 *e++ = base64_value_to_char[value];
3131 *e++ = '=';
3132 break;
3135 if (multibyte)
3137 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3138 if (CHAR_BYTE8_P (c))
3139 c = CHAR_TO_BYTE8 (c);
3140 else if (c >= 256)
3141 return -1;
3142 i += bytes;
3144 else
3145 c = from[i++];
3147 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3148 *e++ = base64_value_to_char[0x3f & c];
3151 return e - to;
3155 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3156 2, 2, "r",
3157 doc: /* Base64-decode the region between BEG and END.
3158 Return the length of the decoded text.
3159 If the region can't be decoded, signal an error and don't modify the buffer. */)
3160 (Lisp_Object beg, Lisp_Object end)
3162 EMACS_INT ibeg, iend, length, allength;
3163 char *decoded;
3164 EMACS_INT old_pos = PT;
3165 EMACS_INT decoded_length;
3166 EMACS_INT inserted_chars;
3167 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3168 USE_SAFE_ALLOCA;
3170 validate_region (&beg, &end);
3172 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3173 iend = CHAR_TO_BYTE (XFASTINT (end));
3175 length = iend - ibeg;
3177 /* We need to allocate enough room for decoding the text. If we are
3178 working on a multibyte buffer, each decoded code may occupy at
3179 most two bytes. */
3180 allength = multibyte ? length * 2 : length;
3181 SAFE_ALLOCA (decoded, char *, allength);
3183 move_gap_both (XFASTINT (beg), ibeg);
3184 decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
3185 decoded, length,
3186 multibyte, &inserted_chars);
3187 if (decoded_length > allength)
3188 abort ();
3190 if (decoded_length < 0)
3192 /* The decoding wasn't possible. */
3193 SAFE_FREE ();
3194 error ("Invalid base64 data");
3197 /* Now we have decoded the region, so we insert the new contents
3198 and delete the old. (Insert first in order to preserve markers.) */
3199 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3200 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3201 SAFE_FREE ();
3203 /* Delete the original text. */
3204 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3205 iend + decoded_length, 1);
3207 /* If point was outside of the region, restore it exactly; else just
3208 move to the beginning of the region. */
3209 if (old_pos >= XFASTINT (end))
3210 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3211 else if (old_pos > XFASTINT (beg))
3212 old_pos = XFASTINT (beg);
3213 SET_PT (old_pos > ZV ? ZV : old_pos);
3215 return make_number (inserted_chars);
3218 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3219 1, 1, 0,
3220 doc: /* Base64-decode STRING and return the result. */)
3221 (Lisp_Object string)
3223 char *decoded;
3224 EMACS_INT length, decoded_length;
3225 Lisp_Object decoded_string;
3226 USE_SAFE_ALLOCA;
3228 CHECK_STRING (string);
3230 length = SBYTES (string);
3231 /* We need to allocate enough room for decoding the text. */
3232 SAFE_ALLOCA (decoded, char *, length);
3234 /* The decoded result should be unibyte. */
3235 decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
3236 0, NULL);
3237 if (decoded_length > length)
3238 abort ();
3239 else if (decoded_length >= 0)
3240 decoded_string = make_unibyte_string (decoded, decoded_length);
3241 else
3242 decoded_string = Qnil;
3244 SAFE_FREE ();
3245 if (!STRINGP (decoded_string))
3246 error ("Invalid base64 data");
3248 return decoded_string;
3251 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3252 MULTIBYTE is nonzero, the decoded result should be in multibyte
3253 form. If NCHARS_RETRUN is not NULL, store the number of produced
3254 characters in *NCHARS_RETURN. */
3256 static EMACS_INT
3257 base64_decode_1 (const char *from, char *to, EMACS_INT length,
3258 int multibyte, EMACS_INT *nchars_return)
3260 EMACS_INT i = 0; /* Used inside READ_QUADRUPLET_BYTE */
3261 char *e = to;
3262 unsigned char c;
3263 unsigned long value;
3264 EMACS_INT nchars = 0;
3266 while (1)
3268 /* Process first byte of a quadruplet. */
3270 READ_QUADRUPLET_BYTE (e-to);
3272 if (!IS_BASE64 (c))
3273 return -1;
3274 value = base64_char_to_value[c] << 18;
3276 /* Process second byte of a quadruplet. */
3278 READ_QUADRUPLET_BYTE (-1);
3280 if (!IS_BASE64 (c))
3281 return -1;
3282 value |= base64_char_to_value[c] << 12;
3284 c = (unsigned char) (value >> 16);
3285 if (multibyte && c >= 128)
3286 e += BYTE8_STRING (c, e);
3287 else
3288 *e++ = c;
3289 nchars++;
3291 /* Process third byte of a quadruplet. */
3293 READ_QUADRUPLET_BYTE (-1);
3295 if (c == '=')
3297 READ_QUADRUPLET_BYTE (-1);
3299 if (c != '=')
3300 return -1;
3301 continue;
3304 if (!IS_BASE64 (c))
3305 return -1;
3306 value |= base64_char_to_value[c] << 6;
3308 c = (unsigned char) (0xff & value >> 8);
3309 if (multibyte && c >= 128)
3310 e += BYTE8_STRING (c, e);
3311 else
3312 *e++ = c;
3313 nchars++;
3315 /* Process fourth byte of a quadruplet. */
3317 READ_QUADRUPLET_BYTE (-1);
3319 if (c == '=')
3320 continue;
3322 if (!IS_BASE64 (c))
3323 return -1;
3324 value |= base64_char_to_value[c];
3326 c = (unsigned char) (0xff & value);
3327 if (multibyte && c >= 128)
3328 e += BYTE8_STRING (c, e);
3329 else
3330 *e++ = c;
3331 nchars++;
3337 /***********************************************************************
3338 ***** *****
3339 ***** Hash Tables *****
3340 ***** *****
3341 ***********************************************************************/
3343 /* Implemented by gerd@gnu.org. This hash table implementation was
3344 inspired by CMUCL hash tables. */
3346 /* Ideas:
3348 1. For small tables, association lists are probably faster than
3349 hash tables because they have lower overhead.
3351 For uses of hash tables where the O(1) behavior of table
3352 operations is not a requirement, it might therefore be a good idea
3353 not to hash. Instead, we could just do a linear search in the
3354 key_and_value vector of the hash table. This could be done
3355 if a `:linear-search t' argument is given to make-hash-table. */
3358 /* The list of all weak hash tables. Don't staticpro this one. */
3360 struct Lisp_Hash_Table *weak_hash_tables;
3362 /* Various symbols. */
3364 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
3365 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
3366 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
3368 /* Function prototypes. */
3370 static struct Lisp_Hash_Table *check_hash_table (Lisp_Object);
3371 static size_t get_key_arg (Lisp_Object, size_t, Lisp_Object *, char *);
3372 static void maybe_resize_hash_table (struct Lisp_Hash_Table *);
3373 static int cmpfn_eql (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3374 Lisp_Object, unsigned);
3375 static int cmpfn_equal (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3376 Lisp_Object, unsigned);
3377 static int cmpfn_user_defined (struct Lisp_Hash_Table *, Lisp_Object,
3378 unsigned, Lisp_Object, unsigned);
3379 static unsigned hashfn_eq (struct Lisp_Hash_Table *, Lisp_Object);
3380 static unsigned hashfn_eql (struct Lisp_Hash_Table *, Lisp_Object);
3381 static unsigned hashfn_equal (struct Lisp_Hash_Table *, Lisp_Object);
3382 static unsigned hashfn_user_defined (struct Lisp_Hash_Table *,
3383 Lisp_Object);
3384 static unsigned sxhash_string (unsigned char *, int);
3385 static unsigned sxhash_list (Lisp_Object, int);
3386 static unsigned sxhash_vector (Lisp_Object, int);
3387 static unsigned sxhash_bool_vector (Lisp_Object);
3388 static int sweep_weak_table (struct Lisp_Hash_Table *, int);
3392 /***********************************************************************
3393 Utilities
3394 ***********************************************************************/
3396 /* If OBJ is a Lisp hash table, return a pointer to its struct
3397 Lisp_Hash_Table. Otherwise, signal an error. */
3399 static struct Lisp_Hash_Table *
3400 check_hash_table (Lisp_Object obj)
3402 CHECK_HASH_TABLE (obj);
3403 return XHASH_TABLE (obj);
3407 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3408 number. */
3411 next_almost_prime (int n)
3413 if (n % 2 == 0)
3414 n += 1;
3415 if (n % 3 == 0)
3416 n += 2;
3417 if (n % 7 == 0)
3418 n += 4;
3419 return n;
3423 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3424 which USED[I] is non-zero. If found at index I in ARGS, set
3425 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3426 0. This function is used to extract a keyword/argument pair from
3427 a DEFUN parameter list. */
3429 static size_t
3430 get_key_arg (Lisp_Object key, size_t nargs, Lisp_Object *args, char *used)
3432 size_t i;
3434 for (i = 1; i < nargs; i++)
3435 if (!used[i - 1] && EQ (args[i - 1], key))
3437 used[i - 1] = 1;
3438 used[i] = 1;
3439 return i;
3442 return 0;
3446 /* Return a Lisp vector which has the same contents as VEC but has
3447 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3448 vector that are not copied from VEC are set to INIT. */
3450 Lisp_Object
3451 larger_vector (Lisp_Object vec, int new_size, Lisp_Object init)
3453 struct Lisp_Vector *v;
3454 int i, old_size;
3456 xassert (VECTORP (vec));
3457 old_size = ASIZE (vec);
3458 xassert (new_size >= old_size);
3460 v = allocate_vector (new_size);
3461 memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
3462 for (i = old_size; i < new_size; ++i)
3463 v->contents[i] = init;
3464 XSETVECTOR (vec, v);
3465 return vec;
3469 /***********************************************************************
3470 Low-level Functions
3471 ***********************************************************************/
3473 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3474 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3475 KEY2 are the same. */
3477 static int
3478 cmpfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3480 return (FLOATP (key1)
3481 && FLOATP (key2)
3482 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3486 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3487 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3488 KEY2 are the same. */
3490 static int
3491 cmpfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3493 return hash1 == hash2 && !NILP (Fequal (key1, key2));
3497 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3498 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3499 if KEY1 and KEY2 are the same. */
3501 static int
3502 cmpfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3504 if (hash1 == hash2)
3506 Lisp_Object args[3];
3508 args[0] = h->user_cmp_function;
3509 args[1] = key1;
3510 args[2] = key2;
3511 return !NILP (Ffuncall (3, args));
3513 else
3514 return 0;
3518 /* Value is a hash code for KEY for use in hash table H which uses
3519 `eq' to compare keys. The hash code returned is guaranteed to fit
3520 in a Lisp integer. */
3522 static unsigned
3523 hashfn_eq (struct Lisp_Hash_Table *h, Lisp_Object key)
3525 unsigned hash = XUINT (key) ^ XTYPE (key);
3526 xassert ((hash & ~INTMASK) == 0);
3527 return hash;
3531 /* Value is a hash code for KEY for use in hash table H which uses
3532 `eql' to compare keys. The hash code returned is guaranteed to fit
3533 in a Lisp integer. */
3535 static unsigned
3536 hashfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key)
3538 unsigned hash;
3539 if (FLOATP (key))
3540 hash = sxhash (key, 0);
3541 else
3542 hash = XUINT (key) ^ XTYPE (key);
3543 xassert ((hash & ~INTMASK) == 0);
3544 return hash;
3548 /* Value is a hash code for KEY for use in hash table H which uses
3549 `equal' to compare keys. The hash code returned is guaranteed to fit
3550 in a Lisp integer. */
3552 static unsigned
3553 hashfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key)
3555 unsigned hash = sxhash (key, 0);
3556 xassert ((hash & ~INTMASK) == 0);
3557 return hash;
3561 /* Value is a hash code for KEY for use in hash table H which uses as
3562 user-defined function to compare keys. The hash code returned is
3563 guaranteed to fit in a Lisp integer. */
3565 static unsigned
3566 hashfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key)
3568 Lisp_Object args[2], hash;
3570 args[0] = h->user_hash_function;
3571 args[1] = key;
3572 hash = Ffuncall (2, args);
3573 if (!INTEGERP (hash))
3574 signal_error ("Invalid hash code returned from user-supplied hash function", hash);
3575 return XUINT (hash);
3579 /* Create and initialize a new hash table.
3581 TEST specifies the test the hash table will use to compare keys.
3582 It must be either one of the predefined tests `eq', `eql' or
3583 `equal' or a symbol denoting a user-defined test named TEST with
3584 test and hash functions USER_TEST and USER_HASH.
3586 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3588 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3589 new size when it becomes full is computed by adding REHASH_SIZE to
3590 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3591 table's new size is computed by multiplying its old size with
3592 REHASH_SIZE.
3594 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3595 be resized when the ratio of (number of entries in the table) /
3596 (table size) is >= REHASH_THRESHOLD.
3598 WEAK specifies the weakness of the table. If non-nil, it must be
3599 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3601 Lisp_Object
3602 make_hash_table (Lisp_Object test, Lisp_Object size, Lisp_Object rehash_size,
3603 Lisp_Object rehash_threshold, Lisp_Object weak,
3604 Lisp_Object user_test, Lisp_Object user_hash)
3606 struct Lisp_Hash_Table *h;
3607 Lisp_Object table;
3608 int index_size, i, sz;
3610 /* Preconditions. */
3611 xassert (SYMBOLP (test));
3612 xassert (INTEGERP (size) && XINT (size) >= 0);
3613 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
3614 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
3615 xassert (FLOATP (rehash_threshold)
3616 && XFLOATINT (rehash_threshold) > 0
3617 && XFLOATINT (rehash_threshold) <= 1.0);
3619 if (XFASTINT (size) == 0)
3620 size = make_number (1);
3622 /* Allocate a table and initialize it. */
3623 h = allocate_hash_table ();
3625 /* Initialize hash table slots. */
3626 sz = XFASTINT (size);
3628 h->test = test;
3629 if (EQ (test, Qeql))
3631 h->cmpfn = cmpfn_eql;
3632 h->hashfn = hashfn_eql;
3634 else if (EQ (test, Qeq))
3636 h->cmpfn = NULL;
3637 h->hashfn = hashfn_eq;
3639 else if (EQ (test, Qequal))
3641 h->cmpfn = cmpfn_equal;
3642 h->hashfn = hashfn_equal;
3644 else
3646 h->user_cmp_function = user_test;
3647 h->user_hash_function = user_hash;
3648 h->cmpfn = cmpfn_user_defined;
3649 h->hashfn = hashfn_user_defined;
3652 h->weak = weak;
3653 h->rehash_threshold = rehash_threshold;
3654 h->rehash_size = rehash_size;
3655 h->count = 0;
3656 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
3657 h->hash = Fmake_vector (size, Qnil);
3658 h->next = Fmake_vector (size, Qnil);
3659 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3660 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
3661 h->index = Fmake_vector (make_number (index_size), Qnil);
3663 /* Set up the free list. */
3664 for (i = 0; i < sz - 1; ++i)
3665 HASH_NEXT (h, i) = make_number (i + 1);
3666 h->next_free = make_number (0);
3668 XSET_HASH_TABLE (table, h);
3669 xassert (HASH_TABLE_P (table));
3670 xassert (XHASH_TABLE (table) == h);
3672 /* Maybe add this hash table to the list of all weak hash tables. */
3673 if (NILP (h->weak))
3674 h->next_weak = NULL;
3675 else
3677 h->next_weak = weak_hash_tables;
3678 weak_hash_tables = h;
3681 return table;
3685 /* Return a copy of hash table H1. Keys and values are not copied,
3686 only the table itself is. */
3688 static Lisp_Object
3689 copy_hash_table (struct Lisp_Hash_Table *h1)
3691 Lisp_Object table;
3692 struct Lisp_Hash_Table *h2;
3693 struct Lisp_Vector *next;
3695 h2 = allocate_hash_table ();
3696 next = h2->vec_next;
3697 memcpy (h2, h1, sizeof *h2);
3698 h2->vec_next = next;
3699 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
3700 h2->hash = Fcopy_sequence (h1->hash);
3701 h2->next = Fcopy_sequence (h1->next);
3702 h2->index = Fcopy_sequence (h1->index);
3703 XSET_HASH_TABLE (table, h2);
3705 /* Maybe add this hash table to the list of all weak hash tables. */
3706 if (!NILP (h2->weak))
3708 h2->next_weak = weak_hash_tables;
3709 weak_hash_tables = h2;
3712 return table;
3716 /* Resize hash table H if it's too full. If H cannot be resized
3717 because it's already too large, throw an error. */
3719 static INLINE void
3720 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
3722 if (NILP (h->next_free))
3724 int old_size = HASH_TABLE_SIZE (h);
3725 int i, new_size, index_size;
3726 EMACS_INT nsize;
3728 if (INTEGERP (h->rehash_size))
3729 new_size = old_size + XFASTINT (h->rehash_size);
3730 else
3731 new_size = old_size * XFLOATINT (h->rehash_size);
3732 new_size = max (old_size + 1, new_size);
3733 index_size = next_almost_prime ((int)
3734 (new_size
3735 / XFLOATINT (h->rehash_threshold)));
3736 /* Assignment to EMACS_INT stops GCC whining about limited range
3737 of data type. */
3738 nsize = max (index_size, 2 * new_size);
3739 if (nsize > MOST_POSITIVE_FIXNUM)
3740 error ("Hash table too large to resize");
3742 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
3743 h->next = larger_vector (h->next, new_size, Qnil);
3744 h->hash = larger_vector (h->hash, new_size, Qnil);
3745 h->index = Fmake_vector (make_number (index_size), Qnil);
3747 /* Update the free list. Do it so that new entries are added at
3748 the end of the free list. This makes some operations like
3749 maphash faster. */
3750 for (i = old_size; i < new_size - 1; ++i)
3751 HASH_NEXT (h, i) = make_number (i + 1);
3753 if (!NILP (h->next_free))
3755 Lisp_Object last, next;
3757 last = h->next_free;
3758 while (next = HASH_NEXT (h, XFASTINT (last)),
3759 !NILP (next))
3760 last = next;
3762 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
3764 else
3765 XSETFASTINT (h->next_free, old_size);
3767 /* Rehash. */
3768 for (i = 0; i < old_size; ++i)
3769 if (!NILP (HASH_HASH (h, i)))
3771 unsigned hash_code = XUINT (HASH_HASH (h, i));
3772 int start_of_bucket = hash_code % ASIZE (h->index);
3773 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
3774 HASH_INDEX (h, start_of_bucket) = make_number (i);
3780 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3781 the hash code of KEY. Value is the index of the entry in H
3782 matching KEY, or -1 if not found. */
3785 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, unsigned int *hash)
3787 unsigned hash_code;
3788 int start_of_bucket;
3789 Lisp_Object idx;
3791 hash_code = h->hashfn (h, key);
3792 if (hash)
3793 *hash = hash_code;
3795 start_of_bucket = hash_code % ASIZE (h->index);
3796 idx = HASH_INDEX (h, start_of_bucket);
3798 /* We need not gcpro idx since it's either an integer or nil. */
3799 while (!NILP (idx))
3801 int i = XFASTINT (idx);
3802 if (EQ (key, HASH_KEY (h, i))
3803 || (h->cmpfn
3804 && h->cmpfn (h, key, hash_code,
3805 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
3806 break;
3807 idx = HASH_NEXT (h, i);
3810 return NILP (idx) ? -1 : XFASTINT (idx);
3814 /* Put an entry into hash table H that associates KEY with VALUE.
3815 HASH is a previously computed hash code of KEY.
3816 Value is the index of the entry in H matching KEY. */
3819 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, unsigned int hash)
3821 int start_of_bucket, i;
3823 xassert ((hash & ~INTMASK) == 0);
3825 /* Increment count after resizing because resizing may fail. */
3826 maybe_resize_hash_table (h);
3827 h->count++;
3829 /* Store key/value in the key_and_value vector. */
3830 i = XFASTINT (h->next_free);
3831 h->next_free = HASH_NEXT (h, i);
3832 HASH_KEY (h, i) = key;
3833 HASH_VALUE (h, i) = value;
3835 /* Remember its hash code. */
3836 HASH_HASH (h, i) = make_number (hash);
3838 /* Add new entry to its collision chain. */
3839 start_of_bucket = hash % ASIZE (h->index);
3840 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
3841 HASH_INDEX (h, start_of_bucket) = make_number (i);
3842 return i;
3846 /* Remove the entry matching KEY from hash table H, if there is one. */
3848 static void
3849 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
3851 unsigned hash_code;
3852 int start_of_bucket;
3853 Lisp_Object idx, prev;
3855 hash_code = h->hashfn (h, key);
3856 start_of_bucket = hash_code % ASIZE (h->index);
3857 idx = HASH_INDEX (h, start_of_bucket);
3858 prev = Qnil;
3860 /* We need not gcpro idx, prev since they're either integers or nil. */
3861 while (!NILP (idx))
3863 int i = XFASTINT (idx);
3865 if (EQ (key, HASH_KEY (h, i))
3866 || (h->cmpfn
3867 && h->cmpfn (h, key, hash_code,
3868 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
3870 /* Take entry out of collision chain. */
3871 if (NILP (prev))
3872 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
3873 else
3874 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
3876 /* Clear slots in key_and_value and add the slots to
3877 the free list. */
3878 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
3879 HASH_NEXT (h, i) = h->next_free;
3880 h->next_free = make_number (i);
3881 h->count--;
3882 xassert (h->count >= 0);
3883 break;
3885 else
3887 prev = idx;
3888 idx = HASH_NEXT (h, i);
3894 /* Clear hash table H. */
3896 static void
3897 hash_clear (struct Lisp_Hash_Table *h)
3899 if (h->count > 0)
3901 int i, size = HASH_TABLE_SIZE (h);
3903 for (i = 0; i < size; ++i)
3905 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
3906 HASH_KEY (h, i) = Qnil;
3907 HASH_VALUE (h, i) = Qnil;
3908 HASH_HASH (h, i) = Qnil;
3911 for (i = 0; i < ASIZE (h->index); ++i)
3912 ASET (h->index, i, Qnil);
3914 h->next_free = make_number (0);
3915 h->count = 0;
3921 /************************************************************************
3922 Weak Hash Tables
3923 ************************************************************************/
3925 void
3926 init_weak_hash_tables (void)
3928 weak_hash_tables = NULL;
3931 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3932 entries from the table that don't survive the current GC.
3933 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3934 non-zero if anything was marked. */
3936 static int
3937 sweep_weak_table (struct Lisp_Hash_Table *h, int remove_entries_p)
3939 int bucket, n, marked;
3941 n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
3942 marked = 0;
3944 for (bucket = 0; bucket < n; ++bucket)
3946 Lisp_Object idx, next, prev;
3948 /* Follow collision chain, removing entries that
3949 don't survive this garbage collection. */
3950 prev = Qnil;
3951 for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
3953 int i = XFASTINT (idx);
3954 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
3955 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
3956 int remove_p;
3958 if (EQ (h->weak, Qkey))
3959 remove_p = !key_known_to_survive_p;
3960 else if (EQ (h->weak, Qvalue))
3961 remove_p = !value_known_to_survive_p;
3962 else if (EQ (h->weak, Qkey_or_value))
3963 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
3964 else if (EQ (h->weak, Qkey_and_value))
3965 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
3966 else
3967 abort ();
3969 next = HASH_NEXT (h, i);
3971 if (remove_entries_p)
3973 if (remove_p)
3975 /* Take out of collision chain. */
3976 if (NILP (prev))
3977 HASH_INDEX (h, bucket) = next;
3978 else
3979 HASH_NEXT (h, XFASTINT (prev)) = next;
3981 /* Add to free list. */
3982 HASH_NEXT (h, i) = h->next_free;
3983 h->next_free = idx;
3985 /* Clear key, value, and hash. */
3986 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
3987 HASH_HASH (h, i) = Qnil;
3989 h->count--;
3991 else
3993 prev = idx;
3996 else
3998 if (!remove_p)
4000 /* Make sure key and value survive. */
4001 if (!key_known_to_survive_p)
4003 mark_object (HASH_KEY (h, i));
4004 marked = 1;
4007 if (!value_known_to_survive_p)
4009 mark_object (HASH_VALUE (h, i));
4010 marked = 1;
4017 return marked;
4020 /* Remove elements from weak hash tables that don't survive the
4021 current garbage collection. Remove weak tables that don't survive
4022 from Vweak_hash_tables. Called from gc_sweep. */
4024 void
4025 sweep_weak_hash_tables (void)
4027 struct Lisp_Hash_Table *h, *used, *next;
4028 int marked;
4030 /* Mark all keys and values that are in use. Keep on marking until
4031 there is no more change. This is necessary for cases like
4032 value-weak table A containing an entry X -> Y, where Y is used in a
4033 key-weak table B, Z -> Y. If B comes after A in the list of weak
4034 tables, X -> Y might be removed from A, although when looking at B
4035 one finds that it shouldn't. */
4038 marked = 0;
4039 for (h = weak_hash_tables; h; h = h->next_weak)
4041 if (h->size & ARRAY_MARK_FLAG)
4042 marked |= sweep_weak_table (h, 0);
4045 while (marked);
4047 /* Remove tables and entries that aren't used. */
4048 for (h = weak_hash_tables, used = NULL; h; h = next)
4050 next = h->next_weak;
4052 if (h->size & ARRAY_MARK_FLAG)
4054 /* TABLE is marked as used. Sweep its contents. */
4055 if (h->count > 0)
4056 sweep_weak_table (h, 1);
4058 /* Add table to the list of used weak hash tables. */
4059 h->next_weak = used;
4060 used = h;
4064 weak_hash_tables = used;
4069 /***********************************************************************
4070 Hash Code Computation
4071 ***********************************************************************/
4073 /* Maximum depth up to which to dive into Lisp structures. */
4075 #define SXHASH_MAX_DEPTH 3
4077 /* Maximum length up to which to take list and vector elements into
4078 account. */
4080 #define SXHASH_MAX_LEN 7
4082 /* Combine two integers X and Y for hashing. */
4084 #define SXHASH_COMBINE(X, Y) \
4085 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4086 + (unsigned)(Y))
4089 /* Return a hash for string PTR which has length LEN. The hash
4090 code returned is guaranteed to fit in a Lisp integer. */
4092 static unsigned
4093 sxhash_string (unsigned char *ptr, int len)
4095 unsigned char *p = ptr;
4096 unsigned char *end = p + len;
4097 unsigned char c;
4098 unsigned hash = 0;
4100 while (p != end)
4102 c = *p++;
4103 if (c >= 0140)
4104 c -= 40;
4105 hash = ((hash << 4) + (hash >> 28) + c);
4108 return hash & INTMASK;
4112 /* Return a hash for list LIST. DEPTH is the current depth in the
4113 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4115 static unsigned
4116 sxhash_list (Lisp_Object list, int depth)
4118 unsigned hash = 0;
4119 int i;
4121 if (depth < SXHASH_MAX_DEPTH)
4122 for (i = 0;
4123 CONSP (list) && i < SXHASH_MAX_LEN;
4124 list = XCDR (list), ++i)
4126 unsigned hash2 = sxhash (XCAR (list), depth + 1);
4127 hash = SXHASH_COMBINE (hash, hash2);
4130 if (!NILP (list))
4132 unsigned hash2 = sxhash (list, depth + 1);
4133 hash = SXHASH_COMBINE (hash, hash2);
4136 return hash;
4140 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4141 the Lisp structure. */
4143 static unsigned
4144 sxhash_vector (Lisp_Object vec, int depth)
4146 unsigned hash = ASIZE (vec);
4147 int i, n;
4149 n = min (SXHASH_MAX_LEN, ASIZE (vec));
4150 for (i = 0; i < n; ++i)
4152 unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
4153 hash = SXHASH_COMBINE (hash, hash2);
4156 return hash;
4160 /* Return a hash for bool-vector VECTOR. */
4162 static unsigned
4163 sxhash_bool_vector (Lisp_Object vec)
4165 unsigned hash = XBOOL_VECTOR (vec)->size;
4166 int i, n;
4168 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
4169 for (i = 0; i < n; ++i)
4170 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
4172 return hash;
4176 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4177 structure. Value is an unsigned integer clipped to INTMASK. */
4179 unsigned
4180 sxhash (Lisp_Object obj, int depth)
4182 unsigned hash;
4184 if (depth > SXHASH_MAX_DEPTH)
4185 return 0;
4187 switch (XTYPE (obj))
4189 case_Lisp_Int:
4190 hash = XUINT (obj);
4191 break;
4193 case Lisp_Misc:
4194 hash = XUINT (obj);
4195 break;
4197 case Lisp_Symbol:
4198 obj = SYMBOL_NAME (obj);
4199 /* Fall through. */
4201 case Lisp_String:
4202 hash = sxhash_string (SDATA (obj), SCHARS (obj));
4203 break;
4205 /* This can be everything from a vector to an overlay. */
4206 case Lisp_Vectorlike:
4207 if (VECTORP (obj))
4208 /* According to the CL HyperSpec, two arrays are equal only if
4209 they are `eq', except for strings and bit-vectors. In
4210 Emacs, this works differently. We have to compare element
4211 by element. */
4212 hash = sxhash_vector (obj, depth);
4213 else if (BOOL_VECTOR_P (obj))
4214 hash = sxhash_bool_vector (obj);
4215 else
4216 /* Others are `equal' if they are `eq', so let's take their
4217 address as hash. */
4218 hash = XUINT (obj);
4219 break;
4221 case Lisp_Cons:
4222 hash = sxhash_list (obj, depth);
4223 break;
4225 case Lisp_Float:
4227 double val = XFLOAT_DATA (obj);
4228 unsigned char *p = (unsigned char *) &val;
4229 unsigned char *e = p + sizeof val;
4230 for (hash = 0; p < e; ++p)
4231 hash = SXHASH_COMBINE (hash, *p);
4232 break;
4235 default:
4236 abort ();
4239 return hash & INTMASK;
4244 /***********************************************************************
4245 Lisp Interface
4246 ***********************************************************************/
4249 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
4250 doc: /* Compute a hash code for OBJ and return it as integer. */)
4251 (Lisp_Object obj)
4253 unsigned hash = sxhash (obj, 0);
4254 return make_number (hash);
4258 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4259 doc: /* Create and return a new hash table.
4261 Arguments are specified as keyword/argument pairs. The following
4262 arguments are defined:
4264 :test TEST -- TEST must be a symbol that specifies how to compare
4265 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4266 `equal'. User-supplied test and hash functions can be specified via
4267 `define-hash-table-test'.
4269 :size SIZE -- A hint as to how many elements will be put in the table.
4270 Default is 65.
4272 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4273 fills up. If REHASH-SIZE is an integer, increase the size by that
4274 amount. If it is a float, it must be > 1.0, and the new size is the
4275 old size multiplied by that factor. Default is 1.5.
4277 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4278 Resize the hash table when the ratio (number of entries / table size)
4279 is greater than or equal to THRESHOLD. Default is 0.8.
4281 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4282 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4283 returned is a weak table. Key/value pairs are removed from a weak
4284 hash table when there are no non-weak references pointing to their
4285 key, value, one of key or value, or both key and value, depending on
4286 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4287 is nil.
4289 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4290 (size_t nargs, Lisp_Object *args)
4292 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4293 Lisp_Object user_test, user_hash;
4294 char *used;
4295 size_t i;
4297 /* The vector `used' is used to keep track of arguments that
4298 have been consumed. */
4299 used = (char *) alloca (nargs * sizeof *used);
4300 memset (used, 0, nargs * sizeof *used);
4302 /* See if there's a `:test TEST' among the arguments. */
4303 i = get_key_arg (QCtest, nargs, args, used);
4304 test = i ? args[i] : Qeql;
4305 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
4307 /* See if it is a user-defined test. */
4308 Lisp_Object prop;
4310 prop = Fget (test, Qhash_table_test);
4311 if (!CONSP (prop) || !CONSP (XCDR (prop)))
4312 signal_error ("Invalid hash table test", test);
4313 user_test = XCAR (prop);
4314 user_hash = XCAR (XCDR (prop));
4316 else
4317 user_test = user_hash = Qnil;
4319 /* See if there's a `:size SIZE' argument. */
4320 i = get_key_arg (QCsize, nargs, args, used);
4321 size = i ? args[i] : Qnil;
4322 if (NILP (size))
4323 size = make_number (DEFAULT_HASH_SIZE);
4324 else if (!INTEGERP (size) || XINT (size) < 0)
4325 signal_error ("Invalid hash table size", size);
4327 /* Look for `:rehash-size SIZE'. */
4328 i = get_key_arg (QCrehash_size, nargs, args, used);
4329 rehash_size = i ? args[i] : make_float (DEFAULT_REHASH_SIZE);
4330 if (!NUMBERP (rehash_size)
4331 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
4332 || XFLOATINT (rehash_size) <= 1.0)
4333 signal_error ("Invalid hash table rehash size", rehash_size);
4335 /* Look for `:rehash-threshold THRESHOLD'. */
4336 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4337 rehash_threshold = i ? args[i] : make_float (DEFAULT_REHASH_THRESHOLD);
4338 if (!FLOATP (rehash_threshold)
4339 || XFLOATINT (rehash_threshold) <= 0.0
4340 || XFLOATINT (rehash_threshold) > 1.0)
4341 signal_error ("Invalid hash table rehash threshold", rehash_threshold);
4343 /* Look for `:weakness WEAK'. */
4344 i = get_key_arg (QCweakness, nargs, args, used);
4345 weak = i ? args[i] : Qnil;
4346 if (EQ (weak, Qt))
4347 weak = Qkey_and_value;
4348 if (!NILP (weak)
4349 && !EQ (weak, Qkey)
4350 && !EQ (weak, Qvalue)
4351 && !EQ (weak, Qkey_or_value)
4352 && !EQ (weak, Qkey_and_value))
4353 signal_error ("Invalid hash table weakness", weak);
4355 /* Now, all args should have been used up, or there's a problem. */
4356 for (i = 0; i < nargs; ++i)
4357 if (!used[i])
4358 signal_error ("Invalid argument list", args[i]);
4360 return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
4361 user_test, user_hash);
4365 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4366 doc: /* Return a copy of hash table TABLE. */)
4367 (Lisp_Object table)
4369 return copy_hash_table (check_hash_table (table));
4373 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4374 doc: /* Return the number of elements in TABLE. */)
4375 (Lisp_Object table)
4377 return make_number (check_hash_table (table)->count);
4381 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4382 Shash_table_rehash_size, 1, 1, 0,
4383 doc: /* Return the current rehash size of TABLE. */)
4384 (Lisp_Object table)
4386 return check_hash_table (table)->rehash_size;
4390 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4391 Shash_table_rehash_threshold, 1, 1, 0,
4392 doc: /* Return the current rehash threshold of TABLE. */)
4393 (Lisp_Object table)
4395 return check_hash_table (table)->rehash_threshold;
4399 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4400 doc: /* Return the size of TABLE.
4401 The size can be used as an argument to `make-hash-table' to create
4402 a hash table than can hold as many elements as TABLE holds
4403 without need for resizing. */)
4404 (Lisp_Object table)
4406 struct Lisp_Hash_Table *h = check_hash_table (table);
4407 return make_number (HASH_TABLE_SIZE (h));
4411 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4412 doc: /* Return the test TABLE uses. */)
4413 (Lisp_Object table)
4415 return check_hash_table (table)->test;
4419 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4420 1, 1, 0,
4421 doc: /* Return the weakness of TABLE. */)
4422 (Lisp_Object table)
4424 return check_hash_table (table)->weak;
4428 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4429 doc: /* Return t if OBJ is a Lisp hash table object. */)
4430 (Lisp_Object obj)
4432 return HASH_TABLE_P (obj) ? Qt : Qnil;
4436 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4437 doc: /* Clear hash table TABLE and return it. */)
4438 (Lisp_Object table)
4440 hash_clear (check_hash_table (table));
4441 /* Be compatible with XEmacs. */
4442 return table;
4446 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4447 doc: /* Look up KEY in TABLE and return its associated value.
4448 If KEY is not found, return DFLT which defaults to nil. */)
4449 (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
4451 struct Lisp_Hash_Table *h = check_hash_table (table);
4452 int i = hash_lookup (h, key, NULL);
4453 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4457 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4458 doc: /* Associate KEY with VALUE in hash table TABLE.
4459 If KEY is already present in table, replace its current value with
4460 VALUE. */)
4461 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4463 struct Lisp_Hash_Table *h = check_hash_table (table);
4464 int i;
4465 unsigned hash;
4467 i = hash_lookup (h, key, &hash);
4468 if (i >= 0)
4469 HASH_VALUE (h, i) = value;
4470 else
4471 hash_put (h, key, value, hash);
4473 return value;
4477 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4478 doc: /* Remove KEY from TABLE. */)
4479 (Lisp_Object key, Lisp_Object table)
4481 struct Lisp_Hash_Table *h = check_hash_table (table);
4482 hash_remove_from_table (h, key);
4483 return Qnil;
4487 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4488 doc: /* Call FUNCTION for all entries in hash table TABLE.
4489 FUNCTION is called with two arguments, KEY and VALUE. */)
4490 (Lisp_Object function, Lisp_Object table)
4492 struct Lisp_Hash_Table *h = check_hash_table (table);
4493 Lisp_Object args[3];
4494 int i;
4496 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
4497 if (!NILP (HASH_HASH (h, i)))
4499 args[0] = function;
4500 args[1] = HASH_KEY (h, i);
4501 args[2] = HASH_VALUE (h, i);
4502 Ffuncall (3, args);
4505 return Qnil;
4509 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4510 Sdefine_hash_table_test, 3, 3, 0,
4511 doc: /* Define a new hash table test with name NAME, a symbol.
4513 In hash tables created with NAME specified as test, use TEST to
4514 compare keys, and HASH for computing hash codes of keys.
4516 TEST must be a function taking two arguments and returning non-nil if
4517 both arguments are the same. HASH must be a function taking one
4518 argument and return an integer that is the hash code of the argument.
4519 Hash code computation should use the whole value range of integers,
4520 including negative integers. */)
4521 (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
4523 return Fput (name, Qhash_table_test, list2 (test, hash));
4528 /************************************************************************
4530 ************************************************************************/
4532 #include "md5.h"
4534 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4535 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
4537 A message digest is a cryptographic checksum of a document, and the
4538 algorithm to calculate it is defined in RFC 1321.
4540 The two optional arguments START and END are character positions
4541 specifying for which part of OBJECT the message digest should be
4542 computed. If nil or omitted, the digest is computed for the whole
4543 OBJECT.
4545 The MD5 message digest is computed from the result of encoding the
4546 text in a coding system, not directly from the internal Emacs form of
4547 the text. The optional fourth argument CODING-SYSTEM specifies which
4548 coding system to encode the text with. It should be the same coding
4549 system that you used or will use when actually writing the text into a
4550 file.
4552 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4553 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4554 system would be chosen by default for writing this text into a file.
4556 If OBJECT is a string, the most preferred coding system (see the
4557 command `prefer-coding-system') is used.
4559 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4560 guesswork fails. Normally, an error is signaled in such case. */)
4561 (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
4563 unsigned char digest[16];
4564 char value[33];
4565 int i;
4566 EMACS_INT size;
4567 EMACS_INT size_byte = 0;
4568 EMACS_INT start_char = 0, end_char = 0;
4569 EMACS_INT start_byte = 0, end_byte = 0;
4570 register EMACS_INT b, e;
4571 register struct buffer *bp;
4572 EMACS_INT temp;
4574 if (STRINGP (object))
4576 if (NILP (coding_system))
4578 /* Decide the coding-system to encode the data with. */
4580 if (STRING_MULTIBYTE (object))
4581 /* use default, we can't guess correct value */
4582 coding_system = preferred_coding_system ();
4583 else
4584 coding_system = Qraw_text;
4587 if (NILP (Fcoding_system_p (coding_system)))
4589 /* Invalid coding system. */
4591 if (!NILP (noerror))
4592 coding_system = Qraw_text;
4593 else
4594 xsignal1 (Qcoding_system_error, coding_system);
4597 if (STRING_MULTIBYTE (object))
4598 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4600 size = SCHARS (object);
4601 size_byte = SBYTES (object);
4603 if (!NILP (start))
4605 CHECK_NUMBER (start);
4607 start_char = XINT (start);
4609 if (start_char < 0)
4610 start_char += size;
4612 start_byte = string_char_to_byte (object, start_char);
4615 if (NILP (end))
4617 end_char = size;
4618 end_byte = size_byte;
4620 else
4622 CHECK_NUMBER (end);
4624 end_char = XINT (end);
4626 if (end_char < 0)
4627 end_char += size;
4629 end_byte = string_char_to_byte (object, end_char);
4632 if (!(0 <= start_char && start_char <= end_char && end_char <= size))
4633 args_out_of_range_3 (object, make_number (start_char),
4634 make_number (end_char));
4636 else
4638 struct buffer *prev = current_buffer;
4640 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4642 CHECK_BUFFER (object);
4644 bp = XBUFFER (object);
4645 if (bp != current_buffer)
4646 set_buffer_internal (bp);
4648 if (NILP (start))
4649 b = BEGV;
4650 else
4652 CHECK_NUMBER_COERCE_MARKER (start);
4653 b = XINT (start);
4656 if (NILP (end))
4657 e = ZV;
4658 else
4660 CHECK_NUMBER_COERCE_MARKER (end);
4661 e = XINT (end);
4664 if (b > e)
4665 temp = b, b = e, e = temp;
4667 if (!(BEGV <= b && e <= ZV))
4668 args_out_of_range (start, end);
4670 if (NILP (coding_system))
4672 /* Decide the coding-system to encode the data with.
4673 See fileio.c:Fwrite-region */
4675 if (!NILP (Vcoding_system_for_write))
4676 coding_system = Vcoding_system_for_write;
4677 else
4679 int force_raw_text = 0;
4681 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4682 if (NILP (coding_system)
4683 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4685 coding_system = Qnil;
4686 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4687 force_raw_text = 1;
4690 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
4692 /* Check file-coding-system-alist. */
4693 Lisp_Object args[4], val;
4695 args[0] = Qwrite_region; args[1] = start; args[2] = end;
4696 args[3] = Fbuffer_file_name(object);
4697 val = Ffind_operation_coding_system (4, args);
4698 if (CONSP (val) && !NILP (XCDR (val)))
4699 coding_system = XCDR (val);
4702 if (NILP (coding_system)
4703 && !NILP (BVAR (XBUFFER (object), buffer_file_coding_system)))
4705 /* If we still have not decided a coding system, use the
4706 default value of buffer-file-coding-system. */
4707 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4710 if (!force_raw_text
4711 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4712 /* Confirm that VAL can surely encode the current region. */
4713 coding_system = call4 (Vselect_safe_coding_system_function,
4714 make_number (b), make_number (e),
4715 coding_system, Qnil);
4717 if (force_raw_text)
4718 coding_system = Qraw_text;
4721 if (NILP (Fcoding_system_p (coding_system)))
4723 /* Invalid coding system. */
4725 if (!NILP (noerror))
4726 coding_system = Qraw_text;
4727 else
4728 xsignal1 (Qcoding_system_error, coding_system);
4732 object = make_buffer_string (b, e, 0);
4733 if (prev != current_buffer)
4734 set_buffer_internal (prev);
4735 /* Discard the unwind protect for recovering the current
4736 buffer. */
4737 specpdl_ptr--;
4739 if (STRING_MULTIBYTE (object))
4740 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
4743 md5_buffer (SSDATA (object) + start_byte,
4744 SBYTES (object) - (size_byte - end_byte),
4745 digest);
4747 for (i = 0; i < 16; i++)
4748 sprintf (&value[2 * i], "%02x", digest[i]);
4749 value[32] = '\0';
4751 return make_string (value, 32);
4755 void
4756 syms_of_fns (void)
4758 /* Hash table stuff. */
4759 Qhash_table_p = intern_c_string ("hash-table-p");
4760 staticpro (&Qhash_table_p);
4761 Qeq = intern_c_string ("eq");
4762 staticpro (&Qeq);
4763 Qeql = intern_c_string ("eql");
4764 staticpro (&Qeql);
4765 Qequal = intern_c_string ("equal");
4766 staticpro (&Qequal);
4767 QCtest = intern_c_string (":test");
4768 staticpro (&QCtest);
4769 QCsize = intern_c_string (":size");
4770 staticpro (&QCsize);
4771 QCrehash_size = intern_c_string (":rehash-size");
4772 staticpro (&QCrehash_size);
4773 QCrehash_threshold = intern_c_string (":rehash-threshold");
4774 staticpro (&QCrehash_threshold);
4775 QCweakness = intern_c_string (":weakness");
4776 staticpro (&QCweakness);
4777 Qkey = intern_c_string ("key");
4778 staticpro (&Qkey);
4779 Qvalue = intern_c_string ("value");
4780 staticpro (&Qvalue);
4781 Qhash_table_test = intern_c_string ("hash-table-test");
4782 staticpro (&Qhash_table_test);
4783 Qkey_or_value = intern_c_string ("key-or-value");
4784 staticpro (&Qkey_or_value);
4785 Qkey_and_value = intern_c_string ("key-and-value");
4786 staticpro (&Qkey_and_value);
4788 defsubr (&Ssxhash);
4789 defsubr (&Smake_hash_table);
4790 defsubr (&Scopy_hash_table);
4791 defsubr (&Shash_table_count);
4792 defsubr (&Shash_table_rehash_size);
4793 defsubr (&Shash_table_rehash_threshold);
4794 defsubr (&Shash_table_size);
4795 defsubr (&Shash_table_test);
4796 defsubr (&Shash_table_weakness);
4797 defsubr (&Shash_table_p);
4798 defsubr (&Sclrhash);
4799 defsubr (&Sgethash);
4800 defsubr (&Sputhash);
4801 defsubr (&Sremhash);
4802 defsubr (&Smaphash);
4803 defsubr (&Sdefine_hash_table_test);
4805 Qstring_lessp = intern_c_string ("string-lessp");
4806 staticpro (&Qstring_lessp);
4807 Qprovide = intern_c_string ("provide");
4808 staticpro (&Qprovide);
4809 Qrequire = intern_c_string ("require");
4810 staticpro (&Qrequire);
4811 Qyes_or_no_p_history = intern_c_string ("yes-or-no-p-history");
4812 staticpro (&Qyes_or_no_p_history);
4813 Qcursor_in_echo_area = intern_c_string ("cursor-in-echo-area");
4814 staticpro (&Qcursor_in_echo_area);
4815 Qwidget_type = intern_c_string ("widget-type");
4816 staticpro (&Qwidget_type);
4818 staticpro (&string_char_byte_cache_string);
4819 string_char_byte_cache_string = Qnil;
4821 require_nesting_list = Qnil;
4822 staticpro (&require_nesting_list);
4824 Fset (Qyes_or_no_p_history, Qnil);
4826 DEFVAR_LISP ("features", Vfeatures,
4827 doc: /* A list of symbols which are the features of the executing Emacs.
4828 Used by `featurep' and `require', and altered by `provide'. */);
4829 Vfeatures = Fcons (intern_c_string ("emacs"), Qnil);
4830 Qsubfeatures = intern_c_string ("subfeatures");
4831 staticpro (&Qsubfeatures);
4833 #ifdef HAVE_LANGINFO_CODESET
4834 Qcodeset = intern_c_string ("codeset");
4835 staticpro (&Qcodeset);
4836 Qdays = intern_c_string ("days");
4837 staticpro (&Qdays);
4838 Qmonths = intern_c_string ("months");
4839 staticpro (&Qmonths);
4840 Qpaper = intern_c_string ("paper");
4841 staticpro (&Qpaper);
4842 #endif /* HAVE_LANGINFO_CODESET */
4844 DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
4845 doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4846 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4847 invoked by mouse clicks and mouse menu items.
4849 On some platforms, file selection dialogs are also enabled if this is
4850 non-nil. */);
4851 use_dialog_box = 1;
4853 DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
4854 doc: /* *Non-nil means mouse commands use a file dialog to ask for files.
4855 This applies to commands from menus and tool bar buttons even when
4856 they are initiated from the keyboard. If `use-dialog-box' is nil,
4857 that disables the use of a file dialog, regardless of the value of
4858 this variable. */);
4859 use_file_dialog = 1;
4861 defsubr (&Sidentity);
4862 defsubr (&Srandom);
4863 defsubr (&Slength);
4864 defsubr (&Ssafe_length);
4865 defsubr (&Sstring_bytes);
4866 defsubr (&Sstring_equal);
4867 defsubr (&Scompare_strings);
4868 defsubr (&Sstring_lessp);
4869 defsubr (&Sappend);
4870 defsubr (&Sconcat);
4871 defsubr (&Svconcat);
4872 defsubr (&Scopy_sequence);
4873 defsubr (&Sstring_make_multibyte);
4874 defsubr (&Sstring_make_unibyte);
4875 defsubr (&Sstring_as_multibyte);
4876 defsubr (&Sstring_as_unibyte);
4877 defsubr (&Sstring_to_multibyte);
4878 defsubr (&Sstring_to_unibyte);
4879 defsubr (&Scopy_alist);
4880 defsubr (&Ssubstring);
4881 defsubr (&Ssubstring_no_properties);
4882 defsubr (&Snthcdr);
4883 defsubr (&Snth);
4884 defsubr (&Selt);
4885 defsubr (&Smember);
4886 defsubr (&Smemq);
4887 defsubr (&Smemql);
4888 defsubr (&Sassq);
4889 defsubr (&Sassoc);
4890 defsubr (&Srassq);
4891 defsubr (&Srassoc);
4892 defsubr (&Sdelq);
4893 defsubr (&Sdelete);
4894 defsubr (&Snreverse);
4895 defsubr (&Sreverse);
4896 defsubr (&Ssort);
4897 defsubr (&Splist_get);
4898 defsubr (&Sget);
4899 defsubr (&Splist_put);
4900 defsubr (&Sput);
4901 defsubr (&Slax_plist_get);
4902 defsubr (&Slax_plist_put);
4903 defsubr (&Seql);
4904 defsubr (&Sequal);
4905 defsubr (&Sequal_including_properties);
4906 defsubr (&Sfillarray);
4907 defsubr (&Sclear_string);
4908 defsubr (&Snconc);
4909 defsubr (&Smapcar);
4910 defsubr (&Smapc);
4911 defsubr (&Smapconcat);
4912 defsubr (&Syes_or_no_p);
4913 defsubr (&Sload_average);
4914 defsubr (&Sfeaturep);
4915 defsubr (&Srequire);
4916 defsubr (&Sprovide);
4917 defsubr (&Splist_member);
4918 defsubr (&Swidget_put);
4919 defsubr (&Swidget_get);
4920 defsubr (&Swidget_apply);
4921 defsubr (&Sbase64_encode_region);
4922 defsubr (&Sbase64_decode_region);
4923 defsubr (&Sbase64_encode_string);
4924 defsubr (&Sbase64_decode_string);
4925 defsubr (&Smd5);
4926 defsubr (&Slocale_info);
4930 void
4931 init_fns (void)