Use add/delete_read_fd in xsmfns to simplify. Also restart with initial_argv.
[emacs.git] / src / fns.c
blobe2853c2be944ecc48fff7c59401b9f9b3ee9aeb7
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 extern long get_random (void);
61 extern void seed_random (long);
63 #ifndef HAVE_UNISTD_H
64 extern long time ();
65 #endif
67 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
68 doc: /* Return the argument unchanged. */)
69 (Lisp_Object arg)
71 return arg;
74 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
75 doc: /* Return a pseudo-random number.
76 All integers representable in Lisp are equally likely.
77 On most systems, this is 29 bits' worth.
78 With positive integer LIMIT, return random number in interval [0,LIMIT).
79 With argument t, set the random number seed from the current time and pid.
80 Other values of LIMIT are ignored. */)
81 (Lisp_Object limit)
83 EMACS_INT val;
84 Lisp_Object lispy_val;
85 unsigned long denominator;
87 if (EQ (limit, Qt))
88 seed_random (getpid () + time (NULL));
89 if (NATNUMP (limit) && XFASTINT (limit) != 0)
91 /* Try to take our random number from the higher bits of VAL,
92 not the lower, since (says Gentzel) the low bits of `random'
93 are less random than the higher ones. We do this by using the
94 quotient rather than the remainder. At the high end of the RNG
95 it's possible to get a quotient larger than n; discarding
96 these values eliminates the bias that would otherwise appear
97 when using a large n. */
98 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
100 val = get_random () / denominator;
101 while (val >= XFASTINT (limit));
103 else
104 val = get_random ();
105 XSETINT (lispy_val, val);
106 return lispy_val;
109 /* Random data-structure functions */
111 DEFUN ("length", Flength, Slength, 1, 1, 0,
112 doc: /* Return the length of vector, list or string SEQUENCE.
113 A byte-code function object is also allowed.
114 If the string contains multibyte characters, this is not necessarily
115 the number of bytes in the string; it is the number of characters.
116 To get the number of bytes, use `string-bytes'. */)
117 (register Lisp_Object sequence)
119 register Lisp_Object val;
120 register int i;
122 if (STRINGP (sequence))
123 XSETFASTINT (val, SCHARS (sequence));
124 else if (VECTORP (sequence))
125 XSETFASTINT (val, ASIZE (sequence));
126 else if (CHAR_TABLE_P (sequence))
127 XSETFASTINT (val, MAX_CHAR);
128 else if (BOOL_VECTOR_P (sequence))
129 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
130 else if (COMPILEDP (sequence))
131 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
132 else if (CONSP (sequence))
134 i = 0;
135 while (CONSP (sequence))
137 sequence = XCDR (sequence);
138 ++i;
140 if (!CONSP (sequence))
141 break;
143 sequence = XCDR (sequence);
144 ++i;
145 QUIT;
148 CHECK_LIST_END (sequence, sequence);
150 val = make_number (i);
152 else if (NILP (sequence))
153 XSETFASTINT (val, 0);
154 else
155 wrong_type_argument (Qsequencep, sequence);
157 return val;
160 /* This does not check for quits. That is safe since it must terminate. */
162 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
163 doc: /* Return the length of a list, but avoid error or infinite loop.
164 This function never gets an error. If LIST is not really a list,
165 it returns 0. If LIST is circular, it returns a finite value
166 which is at least the number of distinct elements. */)
167 (Lisp_Object list)
169 Lisp_Object tail, halftail, length;
170 int len = 0;
172 /* halftail is used to detect circular lists. */
173 halftail = list;
174 for (tail = list; CONSP (tail); tail = XCDR (tail))
176 if (EQ (tail, halftail) && len != 0)
177 break;
178 len++;
179 if ((len & 1) == 0)
180 halftail = XCDR (halftail);
183 XSETINT (length, len);
184 return length;
187 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
188 doc: /* Return the number of bytes in STRING.
189 If STRING is multibyte, this may be greater than the length of STRING. */)
190 (Lisp_Object string)
192 CHECK_STRING (string);
193 return make_number (SBYTES (string));
196 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
197 doc: /* Return t if two strings have identical contents.
198 Case is significant, but text properties are ignored.
199 Symbols are also allowed; their print names are used instead. */)
200 (register Lisp_Object s1, Lisp_Object s2)
202 if (SYMBOLP (s1))
203 s1 = SYMBOL_NAME (s1);
204 if (SYMBOLP (s2))
205 s2 = SYMBOL_NAME (s2);
206 CHECK_STRING (s1);
207 CHECK_STRING (s2);
209 if (SCHARS (s1) != SCHARS (s2)
210 || SBYTES (s1) != SBYTES (s2)
211 || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
212 return Qnil;
213 return Qt;
216 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
217 doc: /* Compare the contents of two strings, converting to multibyte if needed.
218 In string STR1, skip the first START1 characters and stop at END1.
219 In string STR2, skip the first START2 characters and stop at END2.
220 END1 and END2 default to the full lengths of the respective strings.
222 Case is significant in this comparison if IGNORE-CASE is nil.
223 Unibyte strings are converted to multibyte for comparison.
225 The value is t if the strings (or specified portions) match.
226 If string STR1 is less, the value is a negative number N;
227 - 1 - N is the number of characters that match at the beginning.
228 If string STR1 is greater, the value is a positive number N;
229 N - 1 is the number of characters that match at the beginning. */)
230 (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
232 register EMACS_INT end1_char, end2_char;
233 register EMACS_INT i1, i1_byte, i2, i2_byte;
235 CHECK_STRING (str1);
236 CHECK_STRING (str2);
237 if (NILP (start1))
238 start1 = make_number (0);
239 if (NILP (start2))
240 start2 = make_number (0);
241 CHECK_NATNUM (start1);
242 CHECK_NATNUM (start2);
243 if (! NILP (end1))
244 CHECK_NATNUM (end1);
245 if (! NILP (end2))
246 CHECK_NATNUM (end2);
248 i1 = XINT (start1);
249 i2 = XINT (start2);
251 i1_byte = string_char_to_byte (str1, i1);
252 i2_byte = string_char_to_byte (str2, i2);
254 end1_char = SCHARS (str1);
255 if (! NILP (end1) && end1_char > XINT (end1))
256 end1_char = XINT (end1);
258 end2_char = SCHARS (str2);
259 if (! NILP (end2) && end2_char > XINT (end2))
260 end2_char = XINT (end2);
262 while (i1 < end1_char && i2 < end2_char)
264 /* When we find a mismatch, we must compare the
265 characters, not just the bytes. */
266 int c1, c2;
268 if (STRING_MULTIBYTE (str1))
269 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
270 else
272 c1 = SREF (str1, i1++);
273 MAKE_CHAR_MULTIBYTE (c1);
276 if (STRING_MULTIBYTE (str2))
277 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
278 else
280 c2 = SREF (str2, i2++);
281 MAKE_CHAR_MULTIBYTE (c2);
284 if (c1 == c2)
285 continue;
287 if (! NILP (ignore_case))
289 Lisp_Object tem;
291 tem = Fupcase (make_number (c1));
292 c1 = XINT (tem);
293 tem = Fupcase (make_number (c2));
294 c2 = XINT (tem);
297 if (c1 == c2)
298 continue;
300 /* Note that I1 has already been incremented
301 past the character that we are comparing;
302 hence we don't add or subtract 1 here. */
303 if (c1 < c2)
304 return make_number (- i1 + XINT (start1));
305 else
306 return make_number (i1 - XINT (start1));
309 if (i1 < end1_char)
310 return make_number (i1 - XINT (start1) + 1);
311 if (i2 < end2_char)
312 return make_number (- i1 + XINT (start1) - 1);
314 return Qt;
317 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
318 doc: /* Return t if first arg string is less than second in lexicographic order.
319 Case is significant.
320 Symbols are also allowed; their print names are used instead. */)
321 (register Lisp_Object s1, Lisp_Object s2)
323 register EMACS_INT end;
324 register EMACS_INT i1, i1_byte, i2, i2_byte;
326 if (SYMBOLP (s1))
327 s1 = SYMBOL_NAME (s1);
328 if (SYMBOLP (s2))
329 s2 = SYMBOL_NAME (s2);
330 CHECK_STRING (s1);
331 CHECK_STRING (s2);
333 i1 = i1_byte = i2 = i2_byte = 0;
335 end = SCHARS (s1);
336 if (end > SCHARS (s2))
337 end = SCHARS (s2);
339 while (i1 < end)
341 /* When we find a mismatch, we must compare the
342 characters, not just the bytes. */
343 int c1, c2;
345 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
346 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
348 if (c1 != c2)
349 return c1 < c2 ? Qt : Qnil;
351 return i1 < SCHARS (s2) ? Qt : Qnil;
354 static Lisp_Object concat (int nargs, Lisp_Object *args,
355 enum Lisp_Type target_type, int last_special);
357 /* ARGSUSED */
358 Lisp_Object
359 concat2 (Lisp_Object s1, Lisp_Object s2)
361 Lisp_Object args[2];
362 args[0] = s1;
363 args[1] = s2;
364 return concat (2, args, Lisp_String, 0);
367 /* ARGSUSED */
368 Lisp_Object
369 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
371 Lisp_Object args[3];
372 args[0] = s1;
373 args[1] = s2;
374 args[2] = s3;
375 return concat (3, args, Lisp_String, 0);
378 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
379 doc: /* Concatenate all the arguments and make the result a list.
380 The result is a list whose elements are the elements of all the arguments.
381 Each argument may be a list, vector or string.
382 The last argument is not copied, just used as the tail of the new list.
383 usage: (append &rest SEQUENCES) */)
384 (int nargs, Lisp_Object *args)
386 return concat (nargs, args, Lisp_Cons, 1);
389 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
390 doc: /* Concatenate all the arguments and make the result a string.
391 The result is a string whose elements are the elements of all the arguments.
392 Each argument may be a string or a list or vector of characters (integers).
393 usage: (concat &rest SEQUENCES) */)
394 (int nargs, Lisp_Object *args)
396 return concat (nargs, args, Lisp_String, 0);
399 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
400 doc: /* Concatenate all the arguments and make the result a vector.
401 The result is a vector whose elements are the elements of all the arguments.
402 Each argument may be a list, vector or string.
403 usage: (vconcat &rest SEQUENCES) */)
404 (int nargs, Lisp_Object *args)
406 return concat (nargs, args, Lisp_Vectorlike, 0);
410 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
411 doc: /* Return a copy of a list, vector, string or char-table.
412 The elements of a list or vector are not copied; they are shared
413 with the original. */)
414 (Lisp_Object arg)
416 if (NILP (arg)) return arg;
418 if (CHAR_TABLE_P (arg))
420 return copy_char_table (arg);
423 if (BOOL_VECTOR_P (arg))
425 Lisp_Object val;
426 int size_in_chars
427 = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
428 / BOOL_VECTOR_BITS_PER_CHAR);
430 val = Fmake_bool_vector (Flength (arg), Qnil);
431 memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
432 size_in_chars);
433 return val;
436 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
437 wrong_type_argument (Qsequencep, arg);
439 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
442 /* This structure holds information of an argument of `concat' that is
443 a string and has text properties to be copied. */
444 struct textprop_rec
446 int argnum; /* refer to ARGS (arguments of `concat') */
447 EMACS_INT from; /* refer to ARGS[argnum] (argument string) */
448 EMACS_INT to; /* refer to VAL (the target string) */
451 static Lisp_Object
452 concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)
454 Lisp_Object val;
455 register Lisp_Object tail;
456 register Lisp_Object this;
457 EMACS_INT toindex;
458 EMACS_INT toindex_byte = 0;
459 register EMACS_INT result_len;
460 register EMACS_INT result_len_byte;
461 register int argnum;
462 Lisp_Object last_tail;
463 Lisp_Object prev;
464 int some_multibyte;
465 /* When we make a multibyte string, we can't copy text properties
466 while concatinating each string because the length of resulting
467 string can't be decided until we finish the whole concatination.
468 So, we record strings that have text properties to be copied
469 here, and copy the text properties after the concatination. */
470 struct textprop_rec *textprops = NULL;
471 /* Number of elements in textprops. */
472 int num_textprops = 0;
473 USE_SAFE_ALLOCA;
475 tail = Qnil;
477 /* In append, the last arg isn't treated like the others */
478 if (last_special && nargs > 0)
480 nargs--;
481 last_tail = args[nargs];
483 else
484 last_tail = Qnil;
486 /* Check each argument. */
487 for (argnum = 0; argnum < nargs; argnum++)
489 this = args[argnum];
490 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
491 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
492 wrong_type_argument (Qsequencep, this);
495 /* Compute total length in chars of arguments in RESULT_LEN.
496 If desired output is a string, also compute length in bytes
497 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
498 whether the result should be a multibyte string. */
499 result_len_byte = 0;
500 result_len = 0;
501 some_multibyte = 0;
502 for (argnum = 0; argnum < nargs; argnum++)
504 EMACS_INT len;
505 this = args[argnum];
506 len = XFASTINT (Flength (this));
507 if (target_type == Lisp_String)
509 /* We must count the number of bytes needed in the string
510 as well as the number of characters. */
511 EMACS_INT i;
512 Lisp_Object ch;
513 EMACS_INT this_len_byte;
515 if (VECTORP (this))
516 for (i = 0; i < len; i++)
518 ch = AREF (this, i);
519 CHECK_CHARACTER (ch);
520 this_len_byte = CHAR_BYTES (XINT (ch));
521 result_len_byte += this_len_byte;
522 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
523 some_multibyte = 1;
525 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
526 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
527 else if (CONSP (this))
528 for (; CONSP (this); this = XCDR (this))
530 ch = XCAR (this);
531 CHECK_CHARACTER (ch);
532 this_len_byte = CHAR_BYTES (XINT (ch));
533 result_len_byte += this_len_byte;
534 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
535 some_multibyte = 1;
537 else if (STRINGP (this))
539 if (STRING_MULTIBYTE (this))
541 some_multibyte = 1;
542 result_len_byte += SBYTES (this);
544 else
545 result_len_byte += count_size_as_multibyte (SDATA (this),
546 SCHARS (this));
550 result_len += len;
551 if (result_len < 0)
552 error ("String overflow");
555 if (! some_multibyte)
556 result_len_byte = result_len;
558 /* Create the output object. */
559 if (target_type == Lisp_Cons)
560 val = Fmake_list (make_number (result_len), Qnil);
561 else if (target_type == Lisp_Vectorlike)
562 val = Fmake_vector (make_number (result_len), Qnil);
563 else if (some_multibyte)
564 val = make_uninit_multibyte_string (result_len, result_len_byte);
565 else
566 val = make_uninit_string (result_len);
568 /* In `append', if all but last arg are nil, return last arg. */
569 if (target_type == Lisp_Cons && EQ (val, Qnil))
570 return last_tail;
572 /* Copy the contents of the args into the result. */
573 if (CONSP (val))
574 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
575 else
576 toindex = 0, toindex_byte = 0;
578 prev = Qnil;
579 if (STRINGP (val))
580 SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
582 for (argnum = 0; argnum < nargs; argnum++)
584 Lisp_Object thislen;
585 EMACS_INT thisleni = 0;
586 register EMACS_INT thisindex = 0;
587 register EMACS_INT thisindex_byte = 0;
589 this = args[argnum];
590 if (!CONSP (this))
591 thislen = Flength (this), thisleni = XINT (thislen);
593 /* Between strings of the same kind, copy fast. */
594 if (STRINGP (this) && STRINGP (val)
595 && STRING_MULTIBYTE (this) == some_multibyte)
597 EMACS_INT thislen_byte = SBYTES (this);
599 memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
600 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
602 textprops[num_textprops].argnum = argnum;
603 textprops[num_textprops].from = 0;
604 textprops[num_textprops++].to = toindex;
606 toindex_byte += thislen_byte;
607 toindex += thisleni;
609 /* Copy a single-byte string to a multibyte string. */
610 else if (STRINGP (this) && STRINGP (val))
612 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
614 textprops[num_textprops].argnum = argnum;
615 textprops[num_textprops].from = 0;
616 textprops[num_textprops++].to = toindex;
618 toindex_byte += copy_text (SDATA (this),
619 SDATA (val) + toindex_byte,
620 SCHARS (this), 0, 1);
621 toindex += thisleni;
623 else
624 /* Copy element by element. */
625 while (1)
627 register Lisp_Object elt;
629 /* Fetch next element of `this' arg into `elt', or break if
630 `this' is exhausted. */
631 if (NILP (this)) break;
632 if (CONSP (this))
633 elt = XCAR (this), this = XCDR (this);
634 else if (thisindex >= thisleni)
635 break;
636 else if (STRINGP (this))
638 int c;
639 if (STRING_MULTIBYTE (this))
641 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
642 thisindex,
643 thisindex_byte);
644 XSETFASTINT (elt, c);
646 else
648 XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
649 if (some_multibyte
650 && !ASCII_CHAR_P (XINT (elt))
651 && XINT (elt) < 0400)
653 c = BYTE8_TO_CHAR (XINT (elt));
654 XSETINT (elt, c);
658 else if (BOOL_VECTOR_P (this))
660 int byte;
661 byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
662 if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
663 elt = Qt;
664 else
665 elt = Qnil;
666 thisindex++;
668 else
670 elt = AREF (this, thisindex);
671 thisindex++;
674 /* Store this element into the result. */
675 if (toindex < 0)
677 XSETCAR (tail, elt);
678 prev = tail;
679 tail = XCDR (tail);
681 else if (VECTORP (val))
683 ASET (val, toindex, elt);
684 toindex++;
686 else
688 CHECK_NUMBER (elt);
689 if (some_multibyte)
690 toindex_byte += CHAR_STRING (XINT (elt),
691 SDATA (val) + toindex_byte);
692 else
693 SSET (val, toindex_byte++, XINT (elt));
694 toindex++;
698 if (!NILP (prev))
699 XSETCDR (prev, last_tail);
701 if (num_textprops > 0)
703 Lisp_Object props;
704 EMACS_INT last_to_end = -1;
706 for (argnum = 0; argnum < num_textprops; argnum++)
708 this = args[textprops[argnum].argnum];
709 props = text_property_list (this,
710 make_number (0),
711 make_number (SCHARS (this)),
712 Qnil);
713 /* If successive arguments have properites, be sure that the
714 value of `composition' property be the copy. */
715 if (last_to_end == textprops[argnum].to)
716 make_composition_value_copy (props);
717 add_text_properties_from_list (val, props,
718 make_number (textprops[argnum].to));
719 last_to_end = textprops[argnum].to + SCHARS (this);
723 SAFE_FREE ();
724 return val;
727 static Lisp_Object string_char_byte_cache_string;
728 static EMACS_INT string_char_byte_cache_charpos;
729 static EMACS_INT string_char_byte_cache_bytepos;
731 void
732 clear_string_char_byte_cache (void)
734 string_char_byte_cache_string = Qnil;
737 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
739 EMACS_INT
740 string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
742 EMACS_INT i_byte;
743 EMACS_INT best_below, best_below_byte;
744 EMACS_INT best_above, best_above_byte;
746 best_below = best_below_byte = 0;
747 best_above = SCHARS (string);
748 best_above_byte = SBYTES (string);
749 if (best_above == best_above_byte)
750 return char_index;
752 if (EQ (string, string_char_byte_cache_string))
754 if (string_char_byte_cache_charpos < char_index)
756 best_below = string_char_byte_cache_charpos;
757 best_below_byte = string_char_byte_cache_bytepos;
759 else
761 best_above = string_char_byte_cache_charpos;
762 best_above_byte = string_char_byte_cache_bytepos;
766 if (char_index - best_below < best_above - char_index)
768 unsigned char *p = SDATA (string) + best_below_byte;
770 while (best_below < char_index)
772 p += BYTES_BY_CHAR_HEAD (*p);
773 best_below++;
775 i_byte = p - SDATA (string);
777 else
779 unsigned char *p = SDATA (string) + best_above_byte;
781 while (best_above > char_index)
783 p--;
784 while (!CHAR_HEAD_P (*p)) p--;
785 best_above--;
787 i_byte = p - SDATA (string);
790 string_char_byte_cache_bytepos = i_byte;
791 string_char_byte_cache_charpos = char_index;
792 string_char_byte_cache_string = string;
794 return i_byte;
797 /* Return the character index corresponding to BYTE_INDEX in STRING. */
799 EMACS_INT
800 string_byte_to_char (Lisp_Object string, EMACS_INT byte_index)
802 EMACS_INT i, i_byte;
803 EMACS_INT best_below, best_below_byte;
804 EMACS_INT best_above, best_above_byte;
806 best_below = best_below_byte = 0;
807 best_above = SCHARS (string);
808 best_above_byte = SBYTES (string);
809 if (best_above == best_above_byte)
810 return byte_index;
812 if (EQ (string, string_char_byte_cache_string))
814 if (string_char_byte_cache_bytepos < byte_index)
816 best_below = string_char_byte_cache_charpos;
817 best_below_byte = string_char_byte_cache_bytepos;
819 else
821 best_above = string_char_byte_cache_charpos;
822 best_above_byte = string_char_byte_cache_bytepos;
826 if (byte_index - best_below_byte < best_above_byte - byte_index)
828 unsigned char *p = SDATA (string) + best_below_byte;
829 unsigned char *pend = SDATA (string) + byte_index;
831 while (p < pend)
833 p += BYTES_BY_CHAR_HEAD (*p);
834 best_below++;
836 i = best_below;
837 i_byte = p - SDATA (string);
839 else
841 unsigned char *p = SDATA (string) + best_above_byte;
842 unsigned char *pbeg = SDATA (string) + byte_index;
844 while (p > pbeg)
846 p--;
847 while (!CHAR_HEAD_P (*p)) p--;
848 best_above--;
850 i = best_above;
851 i_byte = p - SDATA (string);
854 string_char_byte_cache_bytepos = i_byte;
855 string_char_byte_cache_charpos = i;
856 string_char_byte_cache_string = string;
858 return i;
861 /* Convert STRING to a multibyte string. */
863 static Lisp_Object
864 string_make_multibyte (Lisp_Object string)
866 unsigned char *buf;
867 EMACS_INT nbytes;
868 Lisp_Object ret;
869 USE_SAFE_ALLOCA;
871 if (STRING_MULTIBYTE (string))
872 return string;
874 nbytes = count_size_as_multibyte (SDATA (string),
875 SCHARS (string));
876 /* If all the chars are ASCII, they won't need any more bytes
877 once converted. In that case, we can return STRING itself. */
878 if (nbytes == SBYTES (string))
879 return string;
881 SAFE_ALLOCA (buf, unsigned char *, nbytes);
882 copy_text (SDATA (string), buf, SBYTES (string),
883 0, 1);
885 ret = make_multibyte_string (buf, SCHARS (string), nbytes);
886 SAFE_FREE ();
888 return ret;
892 /* Convert STRING (if unibyte) to a multibyte string without changing
893 the number of characters. Characters 0200 trough 0237 are
894 converted to eight-bit characters. */
896 Lisp_Object
897 string_to_multibyte (Lisp_Object string)
899 unsigned char *buf;
900 EMACS_INT nbytes;
901 Lisp_Object ret;
902 USE_SAFE_ALLOCA;
904 if (STRING_MULTIBYTE (string))
905 return string;
907 nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
908 /* If all the chars are ASCII, they won't need any more bytes once
909 converted. */
910 if (nbytes == SBYTES (string))
911 return make_multibyte_string (SSDATA (string), nbytes, nbytes);
913 SAFE_ALLOCA (buf, unsigned char *, nbytes);
914 memcpy (buf, SDATA (string), SBYTES (string));
915 str_to_multibyte (buf, nbytes, SBYTES (string));
917 ret = make_multibyte_string (buf, SCHARS (string), nbytes);
918 SAFE_FREE ();
920 return ret;
924 /* Convert STRING to a single-byte string. */
926 Lisp_Object
927 string_make_unibyte (Lisp_Object string)
929 EMACS_INT nchars;
930 unsigned char *buf;
931 Lisp_Object ret;
932 USE_SAFE_ALLOCA;
934 if (! STRING_MULTIBYTE (string))
935 return string;
937 nchars = SCHARS (string);
939 SAFE_ALLOCA (buf, unsigned char *, nchars);
940 copy_text (SDATA (string), buf, SBYTES (string),
941 1, 0);
943 ret = make_unibyte_string (buf, nchars);
944 SAFE_FREE ();
946 return ret;
949 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
950 1, 1, 0,
951 doc: /* Return the multibyte equivalent of STRING.
952 If STRING is unibyte and contains non-ASCII characters, the function
953 `unibyte-char-to-multibyte' is used to convert each unibyte character
954 to a multibyte character. In this case, the returned string is a
955 newly created string with no text properties. If STRING is multibyte
956 or entirely ASCII, it is returned unchanged. In particular, when
957 STRING is unibyte and entirely ASCII, the returned string is unibyte.
958 \(When the characters are all ASCII, Emacs primitives will treat the
959 string the same way whether it is unibyte or multibyte.) */)
960 (Lisp_Object string)
962 CHECK_STRING (string);
964 return string_make_multibyte (string);
967 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
968 1, 1, 0,
969 doc: /* Return the unibyte equivalent of STRING.
970 Multibyte character codes are converted to unibyte according to
971 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
972 If the lookup in the translation table fails, this function takes just
973 the low 8 bits of each character. */)
974 (Lisp_Object string)
976 CHECK_STRING (string);
978 return string_make_unibyte (string);
981 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
982 1, 1, 0,
983 doc: /* Return a unibyte string with the same individual bytes as STRING.
984 If STRING is unibyte, the result is STRING itself.
985 Otherwise it is a newly created string, with no text properties.
986 If STRING is multibyte and contains a character of charset
987 `eight-bit', it is converted to the corresponding single byte. */)
988 (Lisp_Object string)
990 CHECK_STRING (string);
992 if (STRING_MULTIBYTE (string))
994 EMACS_INT bytes = SBYTES (string);
995 unsigned char *str = (unsigned char *) xmalloc (bytes);
997 memcpy (str, SDATA (string), bytes);
998 bytes = str_as_unibyte (str, bytes);
999 string = make_unibyte_string (str, bytes);
1000 xfree (str);
1002 return string;
1005 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1006 1, 1, 0,
1007 doc: /* Return a multibyte string with the same individual bytes as STRING.
1008 If STRING is multibyte, the result is STRING itself.
1009 Otherwise it is a newly created string, with no text properties.
1011 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1012 part of a correct utf-8 sequence), it is converted to the corresponding
1013 multibyte character of charset `eight-bit'.
1014 See also `string-to-multibyte'.
1016 Beware, this often doesn't really do what you think it does.
1017 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1018 If you're not sure, whether to use `string-as-multibyte' or
1019 `string-to-multibyte', use `string-to-multibyte'. */)
1020 (Lisp_Object string)
1022 CHECK_STRING (string);
1024 if (! STRING_MULTIBYTE (string))
1026 Lisp_Object new_string;
1027 EMACS_INT nchars, nbytes;
1029 parse_str_as_multibyte (SDATA (string),
1030 SBYTES (string),
1031 &nchars, &nbytes);
1032 new_string = make_uninit_multibyte_string (nchars, nbytes);
1033 memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
1034 if (nbytes != SBYTES (string))
1035 str_as_multibyte (SDATA (new_string), nbytes,
1036 SBYTES (string), NULL);
1037 string = new_string;
1038 STRING_SET_INTERVALS (string, NULL_INTERVAL);
1040 return string;
1043 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1044 1, 1, 0,
1045 doc: /* Return a multibyte string with the same individual chars as STRING.
1046 If STRING is multibyte, the result is STRING itself.
1047 Otherwise it is a newly created string, with no text properties.
1049 If STRING is unibyte and contains an 8-bit byte, it is converted to
1050 the corresponding multibyte character of charset `eight-bit'.
1052 This differs from `string-as-multibyte' by converting each byte of a correct
1053 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1054 correct sequence. */)
1055 (Lisp_Object string)
1057 CHECK_STRING (string);
1059 return string_to_multibyte (string);
1062 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1063 1, 1, 0,
1064 doc: /* Return a unibyte string with the same individual chars as STRING.
1065 If STRING is unibyte, the result is STRING itself.
1066 Otherwise it is a newly created string, with no text properties,
1067 where each `eight-bit' character is converted to the corresponding byte.
1068 If STRING contains a non-ASCII, non-`eight-bit' character,
1069 an error is signaled. */)
1070 (Lisp_Object string)
1072 CHECK_STRING (string);
1074 if (STRING_MULTIBYTE (string))
1076 EMACS_INT chars = SCHARS (string);
1077 unsigned char *str = (unsigned char *) xmalloc (chars);
1078 EMACS_INT converted = str_to_unibyte (SDATA (string), str, chars, 0);
1080 if (converted < chars)
1081 error ("Can't convert the %dth character to unibyte", converted);
1082 string = make_unibyte_string (str, chars);
1083 xfree (str);
1085 return string;
1089 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1090 doc: /* Return a copy of ALIST.
1091 This is an alist which represents the same mapping from objects to objects,
1092 but does not share the alist structure with ALIST.
1093 The objects mapped (cars and cdrs of elements of the alist)
1094 are shared, however.
1095 Elements of ALIST that are not conses are also shared. */)
1096 (Lisp_Object alist)
1098 register Lisp_Object tem;
1100 CHECK_LIST (alist);
1101 if (NILP (alist))
1102 return alist;
1103 alist = concat (1, &alist, Lisp_Cons, 0);
1104 for (tem = alist; CONSP (tem); tem = XCDR (tem))
1106 register Lisp_Object car;
1107 car = XCAR (tem);
1109 if (CONSP (car))
1110 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1112 return alist;
1115 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
1116 doc: /* Return a new string whose contents are a substring of STRING.
1117 The returned string consists of the characters between index FROM
1118 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1119 zero-indexed: 0 means the first character of STRING. Negative values
1120 are counted from the end of STRING. If TO is nil, the substring runs
1121 to the end of STRING.
1123 The STRING argument may also be a vector. In that case, the return
1124 value is a new vector that contains the elements between index FROM
1125 \(inclusive) and index TO (exclusive) of that vector argument. */)
1126 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1128 Lisp_Object res;
1129 EMACS_INT size;
1130 EMACS_INT size_byte = 0;
1131 EMACS_INT from_char, to_char;
1132 EMACS_INT from_byte = 0, to_byte = 0;
1134 CHECK_VECTOR_OR_STRING (string);
1135 CHECK_NUMBER (from);
1137 if (STRINGP (string))
1139 size = SCHARS (string);
1140 size_byte = SBYTES (string);
1142 else
1143 size = ASIZE (string);
1145 if (NILP (to))
1147 to_char = size;
1148 to_byte = size_byte;
1150 else
1152 CHECK_NUMBER (to);
1154 to_char = XINT (to);
1155 if (to_char < 0)
1156 to_char += size;
1158 if (STRINGP (string))
1159 to_byte = string_char_to_byte (string, to_char);
1162 from_char = XINT (from);
1163 if (from_char < 0)
1164 from_char += size;
1165 if (STRINGP (string))
1166 from_byte = string_char_to_byte (string, from_char);
1168 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1169 args_out_of_range_3 (string, make_number (from_char),
1170 make_number (to_char));
1172 if (STRINGP (string))
1174 res = make_specified_string (SSDATA (string) + from_byte,
1175 to_char - from_char, to_byte - from_byte,
1176 STRING_MULTIBYTE (string));
1177 copy_text_properties (make_number (from_char), make_number (to_char),
1178 string, make_number (0), res, Qnil);
1180 else
1181 res = Fvector (to_char - from_char, &AREF (string, from_char));
1183 return res;
1187 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1188 doc: /* Return a substring of STRING, without text properties.
1189 It starts at index FROM and ends before TO.
1190 TO may be nil or omitted; then the substring runs to the end of STRING.
1191 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1192 If FROM or TO is negative, it counts from the end.
1194 With one argument, just copy STRING without its properties. */)
1195 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1197 EMACS_INT size, size_byte;
1198 EMACS_INT from_char, to_char;
1199 EMACS_INT from_byte, to_byte;
1201 CHECK_STRING (string);
1203 size = SCHARS (string);
1204 size_byte = SBYTES (string);
1206 if (NILP (from))
1207 from_char = from_byte = 0;
1208 else
1210 CHECK_NUMBER (from);
1211 from_char = XINT (from);
1212 if (from_char < 0)
1213 from_char += size;
1215 from_byte = string_char_to_byte (string, from_char);
1218 if (NILP (to))
1220 to_char = size;
1221 to_byte = size_byte;
1223 else
1225 CHECK_NUMBER (to);
1227 to_char = XINT (to);
1228 if (to_char < 0)
1229 to_char += size;
1231 to_byte = string_char_to_byte (string, to_char);
1234 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1235 args_out_of_range_3 (string, make_number (from_char),
1236 make_number (to_char));
1238 return make_specified_string (SSDATA (string) + from_byte,
1239 to_char - from_char, to_byte - from_byte,
1240 STRING_MULTIBYTE (string));
1243 /* Extract a substring of STRING, giving start and end positions
1244 both in characters and in bytes. */
1246 Lisp_Object
1247 substring_both (Lisp_Object string, EMACS_INT from, EMACS_INT from_byte,
1248 EMACS_INT to, EMACS_INT to_byte)
1250 Lisp_Object res;
1251 EMACS_INT size;
1252 EMACS_INT size_byte;
1254 CHECK_VECTOR_OR_STRING (string);
1256 if (STRINGP (string))
1258 size = SCHARS (string);
1259 size_byte = SBYTES (string);
1261 else
1262 size = ASIZE (string);
1264 if (!(0 <= from && from <= to && to <= size))
1265 args_out_of_range_3 (string, make_number (from), make_number (to));
1267 if (STRINGP (string))
1269 res = make_specified_string (SSDATA (string) + from_byte,
1270 to - from, to_byte - from_byte,
1271 STRING_MULTIBYTE (string));
1272 copy_text_properties (make_number (from), make_number (to),
1273 string, make_number (0), res, Qnil);
1275 else
1276 res = Fvector (to - from, &AREF (string, from));
1278 return res;
1281 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1282 doc: /* Take cdr N times on LIST, return the result. */)
1283 (Lisp_Object n, Lisp_Object list)
1285 register int i, num;
1286 CHECK_NUMBER (n);
1287 num = XINT (n);
1288 for (i = 0; i < num && !NILP (list); i++)
1290 QUIT;
1291 CHECK_LIST_CONS (list, list);
1292 list = XCDR (list);
1294 return list;
1297 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1298 doc: /* Return the Nth element of LIST.
1299 N counts from zero. If LIST is not that long, nil is returned. */)
1300 (Lisp_Object n, Lisp_Object list)
1302 return Fcar (Fnthcdr (n, list));
1305 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1306 doc: /* Return element of SEQUENCE at index N. */)
1307 (register Lisp_Object sequence, Lisp_Object n)
1309 CHECK_NUMBER (n);
1310 if (CONSP (sequence) || NILP (sequence))
1311 return Fcar (Fnthcdr (n, sequence));
1313 /* Faref signals a "not array" error, so check here. */
1314 CHECK_ARRAY (sequence, Qsequencep);
1315 return Faref (sequence, n);
1318 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1319 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1320 The value is actually the tail of LIST whose car is ELT. */)
1321 (register Lisp_Object elt, Lisp_Object list)
1323 register Lisp_Object tail;
1324 for (tail = list; CONSP (tail); tail = XCDR (tail))
1326 register Lisp_Object tem;
1327 CHECK_LIST_CONS (tail, list);
1328 tem = XCAR (tail);
1329 if (! NILP (Fequal (elt, tem)))
1330 return tail;
1331 QUIT;
1333 return Qnil;
1336 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1337 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1338 The value is actually the tail of LIST whose car is ELT. */)
1339 (register Lisp_Object elt, Lisp_Object list)
1341 while (1)
1343 if (!CONSP (list) || EQ (XCAR (list), elt))
1344 break;
1346 list = XCDR (list);
1347 if (!CONSP (list) || EQ (XCAR (list), elt))
1348 break;
1350 list = XCDR (list);
1351 if (!CONSP (list) || EQ (XCAR (list), elt))
1352 break;
1354 list = XCDR (list);
1355 QUIT;
1358 CHECK_LIST (list);
1359 return list;
1362 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1363 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1364 The value is actually the tail of LIST whose car is ELT. */)
1365 (register Lisp_Object elt, Lisp_Object list)
1367 register Lisp_Object tail;
1369 if (!FLOATP (elt))
1370 return Fmemq (elt, list);
1372 for (tail = list; CONSP (tail); tail = XCDR (tail))
1374 register Lisp_Object tem;
1375 CHECK_LIST_CONS (tail, list);
1376 tem = XCAR (tail);
1377 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
1378 return tail;
1379 QUIT;
1381 return Qnil;
1384 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1385 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1386 The value is actually the first element of LIST whose car is KEY.
1387 Elements of LIST that are not conses are ignored. */)
1388 (Lisp_Object key, Lisp_Object list)
1390 while (1)
1392 if (!CONSP (list)
1393 || (CONSP (XCAR (list))
1394 && EQ (XCAR (XCAR (list)), key)))
1395 break;
1397 list = XCDR (list);
1398 if (!CONSP (list)
1399 || (CONSP (XCAR (list))
1400 && EQ (XCAR (XCAR (list)), key)))
1401 break;
1403 list = XCDR (list);
1404 if (!CONSP (list)
1405 || (CONSP (XCAR (list))
1406 && EQ (XCAR (XCAR (list)), key)))
1407 break;
1409 list = XCDR (list);
1410 QUIT;
1413 return CAR (list);
1416 /* Like Fassq but never report an error and do not allow quits.
1417 Use only on lists known never to be circular. */
1419 Lisp_Object
1420 assq_no_quit (Lisp_Object key, Lisp_Object list)
1422 while (CONSP (list)
1423 && (!CONSP (XCAR (list))
1424 || !EQ (XCAR (XCAR (list)), key)))
1425 list = XCDR (list);
1427 return CAR_SAFE (list);
1430 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1431 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1432 The value is actually the first element of LIST whose car equals KEY. */)
1433 (Lisp_Object key, Lisp_Object list)
1435 Lisp_Object car;
1437 while (1)
1439 if (!CONSP (list)
1440 || (CONSP (XCAR (list))
1441 && (car = XCAR (XCAR (list)),
1442 EQ (car, key) || !NILP (Fequal (car, key)))))
1443 break;
1445 list = XCDR (list);
1446 if (!CONSP (list)
1447 || (CONSP (XCAR (list))
1448 && (car = XCAR (XCAR (list)),
1449 EQ (car, key) || !NILP (Fequal (car, key)))))
1450 break;
1452 list = XCDR (list);
1453 if (!CONSP (list)
1454 || (CONSP (XCAR (list))
1455 && (car = XCAR (XCAR (list)),
1456 EQ (car, key) || !NILP (Fequal (car, key)))))
1457 break;
1459 list = XCDR (list);
1460 QUIT;
1463 return CAR (list);
1466 /* Like Fassoc but never report an error and do not allow quits.
1467 Use only on lists known never to be circular. */
1469 Lisp_Object
1470 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1472 while (CONSP (list)
1473 && (!CONSP (XCAR (list))
1474 || (!EQ (XCAR (XCAR (list)), key)
1475 && NILP (Fequal (XCAR (XCAR (list)), key)))))
1476 list = XCDR (list);
1478 return CONSP (list) ? XCAR (list) : Qnil;
1481 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1482 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1483 The value is actually the first element of LIST whose cdr is KEY. */)
1484 (register Lisp_Object key, Lisp_Object list)
1486 while (1)
1488 if (!CONSP (list)
1489 || (CONSP (XCAR (list))
1490 && EQ (XCDR (XCAR (list)), key)))
1491 break;
1493 list = XCDR (list);
1494 if (!CONSP (list)
1495 || (CONSP (XCAR (list))
1496 && EQ (XCDR (XCAR (list)), key)))
1497 break;
1499 list = XCDR (list);
1500 if (!CONSP (list)
1501 || (CONSP (XCAR (list))
1502 && EQ (XCDR (XCAR (list)), key)))
1503 break;
1505 list = XCDR (list);
1506 QUIT;
1509 return CAR (list);
1512 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1513 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1514 The value is actually the first element of LIST whose cdr equals KEY. */)
1515 (Lisp_Object key, Lisp_Object list)
1517 Lisp_Object cdr;
1519 while (1)
1521 if (!CONSP (list)
1522 || (CONSP (XCAR (list))
1523 && (cdr = XCDR (XCAR (list)),
1524 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1525 break;
1527 list = XCDR (list);
1528 if (!CONSP (list)
1529 || (CONSP (XCAR (list))
1530 && (cdr = XCDR (XCAR (list)),
1531 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1532 break;
1534 list = XCDR (list);
1535 if (!CONSP (list)
1536 || (CONSP (XCAR (list))
1537 && (cdr = XCDR (XCAR (list)),
1538 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1539 break;
1541 list = XCDR (list);
1542 QUIT;
1545 return CAR (list);
1548 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1549 doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
1550 The modified LIST is returned. Comparison is done with `eq'.
1551 If the first member of LIST is ELT, there is no way to remove it by side effect;
1552 therefore, write `(setq foo (delq element foo))'
1553 to be sure of changing the value of `foo'. */)
1554 (register Lisp_Object elt, Lisp_Object list)
1556 register Lisp_Object tail, prev;
1557 register Lisp_Object tem;
1559 tail = list;
1560 prev = Qnil;
1561 while (!NILP (tail))
1563 CHECK_LIST_CONS (tail, list);
1564 tem = XCAR (tail);
1565 if (EQ (elt, tem))
1567 if (NILP (prev))
1568 list = XCDR (tail);
1569 else
1570 Fsetcdr (prev, XCDR (tail));
1572 else
1573 prev = tail;
1574 tail = XCDR (tail);
1575 QUIT;
1577 return list;
1580 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1581 doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1582 SEQ must be a list, a vector, or a string.
1583 The modified SEQ is returned. Comparison is done with `equal'.
1584 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1585 is not a side effect; it is simply using a different sequence.
1586 Therefore, write `(setq foo (delete element foo))'
1587 to be sure of changing the value of `foo'. */)
1588 (Lisp_Object elt, Lisp_Object seq)
1590 if (VECTORP (seq))
1592 EMACS_INT i, n;
1594 for (i = n = 0; i < ASIZE (seq); ++i)
1595 if (NILP (Fequal (AREF (seq, i), elt)))
1596 ++n;
1598 if (n != ASIZE (seq))
1600 struct Lisp_Vector *p = allocate_vector (n);
1602 for (i = n = 0; i < ASIZE (seq); ++i)
1603 if (NILP (Fequal (AREF (seq, i), elt)))
1604 p->contents[n++] = AREF (seq, i);
1606 XSETVECTOR (seq, p);
1609 else if (STRINGP (seq))
1611 EMACS_INT i, ibyte, nchars, nbytes, cbytes;
1612 int c;
1614 for (i = nchars = nbytes = ibyte = 0;
1615 i < SCHARS (seq);
1616 ++i, ibyte += cbytes)
1618 if (STRING_MULTIBYTE (seq))
1620 c = STRING_CHAR (SDATA (seq) + ibyte);
1621 cbytes = CHAR_BYTES (c);
1623 else
1625 c = SREF (seq, i);
1626 cbytes = 1;
1629 if (!INTEGERP (elt) || c != XINT (elt))
1631 ++nchars;
1632 nbytes += cbytes;
1636 if (nchars != SCHARS (seq))
1638 Lisp_Object tem;
1640 tem = make_uninit_multibyte_string (nchars, nbytes);
1641 if (!STRING_MULTIBYTE (seq))
1642 STRING_SET_UNIBYTE (tem);
1644 for (i = nchars = nbytes = ibyte = 0;
1645 i < SCHARS (seq);
1646 ++i, ibyte += cbytes)
1648 if (STRING_MULTIBYTE (seq))
1650 c = STRING_CHAR (SDATA (seq) + ibyte);
1651 cbytes = CHAR_BYTES (c);
1653 else
1655 c = SREF (seq, i);
1656 cbytes = 1;
1659 if (!INTEGERP (elt) || c != XINT (elt))
1661 unsigned char *from = SDATA (seq) + ibyte;
1662 unsigned char *to = SDATA (tem) + nbytes;
1663 EMACS_INT n;
1665 ++nchars;
1666 nbytes += cbytes;
1668 for (n = cbytes; n--; )
1669 *to++ = *from++;
1673 seq = tem;
1676 else
1678 Lisp_Object tail, prev;
1680 for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
1682 CHECK_LIST_CONS (tail, seq);
1684 if (!NILP (Fequal (elt, XCAR (tail))))
1686 if (NILP (prev))
1687 seq = XCDR (tail);
1688 else
1689 Fsetcdr (prev, XCDR (tail));
1691 else
1692 prev = tail;
1693 QUIT;
1697 return seq;
1700 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1701 doc: /* Reverse LIST by modifying cdr pointers.
1702 Return the reversed list. */)
1703 (Lisp_Object list)
1705 register Lisp_Object prev, tail, next;
1707 if (NILP (list)) return list;
1708 prev = Qnil;
1709 tail = list;
1710 while (!NILP (tail))
1712 QUIT;
1713 CHECK_LIST_CONS (tail, list);
1714 next = XCDR (tail);
1715 Fsetcdr (tail, prev);
1716 prev = tail;
1717 tail = next;
1719 return prev;
1722 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1723 doc: /* Reverse LIST, copying. Return the reversed list.
1724 See also the function `nreverse', which is used more often. */)
1725 (Lisp_Object list)
1727 Lisp_Object new;
1729 for (new = Qnil; CONSP (list); list = XCDR (list))
1731 QUIT;
1732 new = Fcons (XCAR (list), new);
1734 CHECK_LIST_END (list, list);
1735 return new;
1738 Lisp_Object merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred);
1740 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1741 doc: /* Sort LIST, stably, comparing elements using PREDICATE.
1742 Returns the sorted list. LIST is modified by side effects.
1743 PREDICATE is called with two elements of LIST, and should return non-nil
1744 if the first element should sort before the second. */)
1745 (Lisp_Object list, Lisp_Object predicate)
1747 Lisp_Object front, back;
1748 register Lisp_Object len, tem;
1749 struct gcpro gcpro1, gcpro2;
1750 register int length;
1752 front = list;
1753 len = Flength (list);
1754 length = XINT (len);
1755 if (length < 2)
1756 return list;
1758 XSETINT (len, (length / 2) - 1);
1759 tem = Fnthcdr (len, list);
1760 back = Fcdr (tem);
1761 Fsetcdr (tem, Qnil);
1763 GCPRO2 (front, back);
1764 front = Fsort (front, predicate);
1765 back = Fsort (back, predicate);
1766 UNGCPRO;
1767 return merge (front, back, predicate);
1770 Lisp_Object
1771 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1773 Lisp_Object value;
1774 register Lisp_Object tail;
1775 Lisp_Object tem;
1776 register Lisp_Object l1, l2;
1777 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1779 l1 = org_l1;
1780 l2 = org_l2;
1781 tail = Qnil;
1782 value = Qnil;
1784 /* It is sufficient to protect org_l1 and org_l2.
1785 When l1 and l2 are updated, we copy the new values
1786 back into the org_ vars. */
1787 GCPRO4 (org_l1, org_l2, pred, value);
1789 while (1)
1791 if (NILP (l1))
1793 UNGCPRO;
1794 if (NILP (tail))
1795 return l2;
1796 Fsetcdr (tail, l2);
1797 return value;
1799 if (NILP (l2))
1801 UNGCPRO;
1802 if (NILP (tail))
1803 return l1;
1804 Fsetcdr (tail, l1);
1805 return value;
1807 tem = call2 (pred, Fcar (l2), Fcar (l1));
1808 if (NILP (tem))
1810 tem = l1;
1811 l1 = Fcdr (l1);
1812 org_l1 = l1;
1814 else
1816 tem = l2;
1817 l2 = Fcdr (l2);
1818 org_l2 = l2;
1820 if (NILP (tail))
1821 value = tem;
1822 else
1823 Fsetcdr (tail, tem);
1824 tail = tem;
1829 /* This does not check for quits. That is safe since it must terminate. */
1831 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1832 doc: /* Extract a value from a property list.
1833 PLIST is a property list, which is a list of the form
1834 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1835 corresponding to the given PROP, or nil if PROP is not one of the
1836 properties on the list. This function never signals an error. */)
1837 (Lisp_Object plist, Lisp_Object prop)
1839 Lisp_Object tail, halftail;
1841 /* halftail is used to detect circular lists. */
1842 tail = halftail = plist;
1843 while (CONSP (tail) && CONSP (XCDR (tail)))
1845 if (EQ (prop, XCAR (tail)))
1846 return XCAR (XCDR (tail));
1848 tail = XCDR (XCDR (tail));
1849 halftail = XCDR (halftail);
1850 if (EQ (tail, halftail))
1851 break;
1853 #if 0 /* Unsafe version. */
1854 /* This function can be called asynchronously
1855 (setup_coding_system). Don't QUIT in that case. */
1856 if (!interrupt_input_blocked)
1857 QUIT;
1858 #endif
1861 return Qnil;
1864 DEFUN ("get", Fget, Sget, 2, 2, 0,
1865 doc: /* Return the value of SYMBOL's PROPNAME property.
1866 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1867 (Lisp_Object symbol, Lisp_Object propname)
1869 CHECK_SYMBOL (symbol);
1870 return Fplist_get (XSYMBOL (symbol)->plist, propname);
1873 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1874 doc: /* Change value in PLIST of PROP to VAL.
1875 PLIST is a property list, which is a list of the form
1876 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1877 If PROP is already a property on the list, its value is set to VAL,
1878 otherwise the new PROP VAL pair is added. The new plist is returned;
1879 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1880 The PLIST is modified by side effects. */)
1881 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
1883 register Lisp_Object tail, prev;
1884 Lisp_Object newcell;
1885 prev = Qnil;
1886 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1887 tail = XCDR (XCDR (tail)))
1889 if (EQ (prop, XCAR (tail)))
1891 Fsetcar (XCDR (tail), val);
1892 return plist;
1895 prev = tail;
1896 QUIT;
1898 newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
1899 if (NILP (prev))
1900 return newcell;
1901 else
1902 Fsetcdr (XCDR (prev), newcell);
1903 return plist;
1906 DEFUN ("put", Fput, Sput, 3, 3, 0,
1907 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
1908 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1909 (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
1911 CHECK_SYMBOL (symbol);
1912 XSYMBOL (symbol)->plist
1913 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
1914 return value;
1917 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
1918 doc: /* Extract a value from a property list, comparing with `equal'.
1919 PLIST is a property list, which is a list of the form
1920 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1921 corresponding to the given PROP, or nil if PROP is not
1922 one of the properties on the list. */)
1923 (Lisp_Object plist, Lisp_Object prop)
1925 Lisp_Object tail;
1927 for (tail = plist;
1928 CONSP (tail) && CONSP (XCDR (tail));
1929 tail = XCDR (XCDR (tail)))
1931 if (! NILP (Fequal (prop, XCAR (tail))))
1932 return XCAR (XCDR (tail));
1934 QUIT;
1937 CHECK_LIST_END (tail, prop);
1939 return Qnil;
1942 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
1943 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1944 PLIST is a property list, which is a list of the form
1945 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1946 If PROP is already a property on the list, its value is set to VAL,
1947 otherwise the new PROP VAL pair is added. The new plist is returned;
1948 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1949 The PLIST is modified by side effects. */)
1950 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
1952 register Lisp_Object tail, prev;
1953 Lisp_Object newcell;
1954 prev = Qnil;
1955 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1956 tail = XCDR (XCDR (tail)))
1958 if (! NILP (Fequal (prop, XCAR (tail))))
1960 Fsetcar (XCDR (tail), val);
1961 return plist;
1964 prev = tail;
1965 QUIT;
1967 newcell = Fcons (prop, Fcons (val, Qnil));
1968 if (NILP (prev))
1969 return newcell;
1970 else
1971 Fsetcdr (XCDR (prev), newcell);
1972 return plist;
1975 DEFUN ("eql", Feql, Seql, 2, 2, 0,
1976 doc: /* Return t if the two args are the same Lisp object.
1977 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1978 (Lisp_Object obj1, Lisp_Object obj2)
1980 if (FLOATP (obj1))
1981 return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
1982 else
1983 return EQ (obj1, obj2) ? Qt : Qnil;
1986 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
1987 doc: /* Return t if two Lisp objects have similar structure and contents.
1988 They must have the same data type.
1989 Conses are compared by comparing the cars and the cdrs.
1990 Vectors and strings are compared element by element.
1991 Numbers are compared by value, but integers cannot equal floats.
1992 (Use `=' if you want integers and floats to be able to be equal.)
1993 Symbols must match exactly. */)
1994 (register Lisp_Object o1, Lisp_Object o2)
1996 return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
1999 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
2000 doc: /* Return t if two Lisp objects have similar structure and contents.
2001 This is like `equal' except that it compares the text properties
2002 of strings. (`equal' ignores text properties.) */)
2003 (register Lisp_Object o1, Lisp_Object o2)
2005 return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
2008 /* DEPTH is current depth of recursion. Signal an error if it
2009 gets too deep.
2010 PROPS, if non-nil, means compare string text properties too. */
2012 static int
2013 internal_equal (register Lisp_Object o1, register Lisp_Object o2, int depth, int props)
2015 if (depth > 200)
2016 error ("Stack overflow in equal");
2018 tail_recurse:
2019 QUIT;
2020 if (EQ (o1, o2))
2021 return 1;
2022 if (XTYPE (o1) != XTYPE (o2))
2023 return 0;
2025 switch (XTYPE (o1))
2027 case Lisp_Float:
2029 double d1, d2;
2031 d1 = extract_float (o1);
2032 d2 = extract_float (o2);
2033 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2034 though they are not =. */
2035 return d1 == d2 || (d1 != d1 && d2 != d2);
2038 case Lisp_Cons:
2039 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
2040 return 0;
2041 o1 = XCDR (o1);
2042 o2 = XCDR (o2);
2043 goto tail_recurse;
2045 case Lisp_Misc:
2046 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2047 return 0;
2048 if (OVERLAYP (o1))
2050 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2051 depth + 1, props)
2052 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2053 depth + 1, props))
2054 return 0;
2055 o1 = XOVERLAY (o1)->plist;
2056 o2 = XOVERLAY (o2)->plist;
2057 goto tail_recurse;
2059 if (MARKERP (o1))
2061 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2062 && (XMARKER (o1)->buffer == 0
2063 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2065 break;
2067 case Lisp_Vectorlike:
2069 register int i;
2070 EMACS_INT size = ASIZE (o1);
2071 /* Pseudovectors have the type encoded in the size field, so this test
2072 actually checks that the objects have the same type as well as the
2073 same size. */
2074 if (ASIZE (o2) != size)
2075 return 0;
2076 /* Boolvectors are compared much like strings. */
2077 if (BOOL_VECTOR_P (o1))
2079 int size_in_chars
2080 = ((XBOOL_VECTOR (o1)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2081 / BOOL_VECTOR_BITS_PER_CHAR);
2083 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
2084 return 0;
2085 if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
2086 size_in_chars))
2087 return 0;
2088 return 1;
2090 if (WINDOW_CONFIGURATIONP (o1))
2091 return compare_window_configurations (o1, o2, 0);
2093 /* Aside from them, only true vectors, char-tables, compiled
2094 functions, and fonts (font-spec, font-entity, font-ojbect)
2095 are sensible to compare, so eliminate the others now. */
2096 if (size & PSEUDOVECTOR_FLAG)
2098 if (!(size & (PVEC_COMPILED
2099 | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT)))
2100 return 0;
2101 size &= PSEUDOVECTOR_SIZE_MASK;
2103 for (i = 0; i < size; i++)
2105 Lisp_Object v1, v2;
2106 v1 = AREF (o1, i);
2107 v2 = AREF (o2, i);
2108 if (!internal_equal (v1, v2, depth + 1, props))
2109 return 0;
2111 return 1;
2113 break;
2115 case Lisp_String:
2116 if (SCHARS (o1) != SCHARS (o2))
2117 return 0;
2118 if (SBYTES (o1) != SBYTES (o2))
2119 return 0;
2120 if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
2121 return 0;
2122 if (props && !compare_string_intervals (o1, o2))
2123 return 0;
2124 return 1;
2126 default:
2127 break;
2130 return 0;
2134 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2135 doc: /* Store each element of ARRAY with ITEM.
2136 ARRAY is a vector, string, char-table, or bool-vector. */)
2137 (Lisp_Object array, Lisp_Object item)
2139 register EMACS_INT size, index;
2140 int charval;
2142 if (VECTORP (array))
2144 register Lisp_Object *p = XVECTOR (array)->contents;
2145 size = ASIZE (array);
2146 for (index = 0; index < size; index++)
2147 p[index] = item;
2149 else if (CHAR_TABLE_P (array))
2151 int i;
2153 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2154 XCHAR_TABLE (array)->contents[i] = item;
2155 XCHAR_TABLE (array)->defalt = item;
2157 else if (STRINGP (array))
2159 register unsigned char *p = SDATA (array);
2160 CHECK_NUMBER (item);
2161 charval = XINT (item);
2162 size = SCHARS (array);
2163 if (STRING_MULTIBYTE (array))
2165 unsigned char str[MAX_MULTIBYTE_LENGTH];
2166 int len = CHAR_STRING (charval, str);
2167 EMACS_INT size_byte = SBYTES (array);
2168 unsigned char *p1 = p, *endp = p + size_byte;
2169 int i;
2171 if (size != size_byte)
2172 while (p1 < endp)
2174 int this_len = BYTES_BY_CHAR_HEAD (*p1);
2175 if (len != this_len)
2176 error ("Attempt to change byte length of a string");
2177 p1 += this_len;
2179 for (i = 0; i < size_byte; i++)
2180 *p++ = str[i % len];
2182 else
2183 for (index = 0; index < size; index++)
2184 p[index] = charval;
2186 else if (BOOL_VECTOR_P (array))
2188 register unsigned char *p = XBOOL_VECTOR (array)->data;
2189 int size_in_chars
2190 = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2191 / BOOL_VECTOR_BITS_PER_CHAR);
2193 charval = (! NILP (item) ? -1 : 0);
2194 for (index = 0; index < size_in_chars - 1; index++)
2195 p[index] = charval;
2196 if (index < size_in_chars)
2198 /* Mask out bits beyond the vector size. */
2199 if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)
2200 charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2201 p[index] = charval;
2204 else
2205 wrong_type_argument (Qarrayp, array);
2206 return array;
2209 DEFUN ("clear-string", Fclear_string, Sclear_string,
2210 1, 1, 0,
2211 doc: /* Clear the contents of STRING.
2212 This makes STRING unibyte and may change its length. */)
2213 (Lisp_Object string)
2215 EMACS_INT len;
2216 CHECK_STRING (string);
2217 len = SBYTES (string);
2218 memset (SDATA (string), 0, len);
2219 STRING_SET_CHARS (string, len);
2220 STRING_SET_UNIBYTE (string);
2221 return Qnil;
2224 /* ARGSUSED */
2225 Lisp_Object
2226 nconc2 (Lisp_Object s1, Lisp_Object s2)
2228 Lisp_Object args[2];
2229 args[0] = s1;
2230 args[1] = s2;
2231 return Fnconc (2, args);
2234 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2235 doc: /* Concatenate any number of lists by altering them.
2236 Only the last argument is not altered, and need not be a list.
2237 usage: (nconc &rest LISTS) */)
2238 (int nargs, Lisp_Object *args)
2240 register int argnum;
2241 register Lisp_Object tail, tem, val;
2243 val = tail = Qnil;
2245 for (argnum = 0; argnum < nargs; argnum++)
2247 tem = args[argnum];
2248 if (NILP (tem)) continue;
2250 if (NILP (val))
2251 val = tem;
2253 if (argnum + 1 == nargs) break;
2255 CHECK_LIST_CONS (tem, tem);
2257 while (CONSP (tem))
2259 tail = tem;
2260 tem = XCDR (tail);
2261 QUIT;
2264 tem = args[argnum + 1];
2265 Fsetcdr (tail, tem);
2266 if (NILP (tem))
2267 args[argnum + 1] = tail;
2270 return val;
2273 /* This is the guts of all mapping functions.
2274 Apply FN to each element of SEQ, one by one,
2275 storing the results into elements of VALS, a C vector of Lisp_Objects.
2276 LENI is the length of VALS, which should also be the length of SEQ. */
2278 static void
2279 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2281 register Lisp_Object tail;
2282 Lisp_Object dummy;
2283 register EMACS_INT i;
2284 struct gcpro gcpro1, gcpro2, gcpro3;
2286 if (vals)
2288 /* Don't let vals contain any garbage when GC happens. */
2289 for (i = 0; i < leni; i++)
2290 vals[i] = Qnil;
2292 GCPRO3 (dummy, fn, seq);
2293 gcpro1.var = vals;
2294 gcpro1.nvars = leni;
2296 else
2297 GCPRO2 (fn, seq);
2298 /* We need not explicitly protect `tail' because it is used only on lists, and
2299 1) lists are not relocated and 2) the list is marked via `seq' so will not
2300 be freed */
2302 if (VECTORP (seq))
2304 for (i = 0; i < leni; i++)
2306 dummy = call1 (fn, AREF (seq, i));
2307 if (vals)
2308 vals[i] = dummy;
2311 else if (BOOL_VECTOR_P (seq))
2313 for (i = 0; i < leni; i++)
2315 int byte;
2316 byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
2317 dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
2318 dummy = call1 (fn, dummy);
2319 if (vals)
2320 vals[i] = dummy;
2323 else if (STRINGP (seq))
2325 EMACS_INT i_byte;
2327 for (i = 0, i_byte = 0; i < leni;)
2329 int c;
2330 EMACS_INT i_before = i;
2332 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2333 XSETFASTINT (dummy, c);
2334 dummy = call1 (fn, dummy);
2335 if (vals)
2336 vals[i_before] = dummy;
2339 else /* Must be a list, since Flength did not get an error */
2341 tail = seq;
2342 for (i = 0; i < leni && CONSP (tail); i++)
2344 dummy = call1 (fn, XCAR (tail));
2345 if (vals)
2346 vals[i] = dummy;
2347 tail = XCDR (tail);
2351 UNGCPRO;
2354 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2355 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2356 In between each pair of results, stick in SEPARATOR. Thus, " " as
2357 SEPARATOR results in spaces between the values returned by FUNCTION.
2358 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2359 (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
2361 Lisp_Object len;
2362 register EMACS_INT leni;
2363 int nargs;
2364 register Lisp_Object *args;
2365 register EMACS_INT i;
2366 struct gcpro gcpro1;
2367 Lisp_Object ret;
2368 USE_SAFE_ALLOCA;
2370 len = Flength (sequence);
2371 if (CHAR_TABLE_P (sequence))
2372 wrong_type_argument (Qlistp, sequence);
2373 leni = XINT (len);
2374 nargs = leni + leni - 1;
2375 if (nargs < 0) return empty_unibyte_string;
2377 SAFE_ALLOCA_LISP (args, nargs);
2379 GCPRO1 (separator);
2380 mapcar1 (leni, args, function, sequence);
2381 UNGCPRO;
2383 for (i = leni - 1; i > 0; i--)
2384 args[i + i] = args[i];
2386 for (i = 1; i < nargs; i += 2)
2387 args[i] = separator;
2389 ret = Fconcat (nargs, args);
2390 SAFE_FREE ();
2392 return ret;
2395 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2396 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2397 The result is a list just as long as SEQUENCE.
2398 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2399 (Lisp_Object function, Lisp_Object sequence)
2401 register Lisp_Object len;
2402 register EMACS_INT leni;
2403 register Lisp_Object *args;
2404 Lisp_Object ret;
2405 USE_SAFE_ALLOCA;
2407 len = Flength (sequence);
2408 if (CHAR_TABLE_P (sequence))
2409 wrong_type_argument (Qlistp, sequence);
2410 leni = XFASTINT (len);
2412 SAFE_ALLOCA_LISP (args, leni);
2414 mapcar1 (leni, args, function, sequence);
2416 ret = Flist (leni, args);
2417 SAFE_FREE ();
2419 return ret;
2422 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2423 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2424 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2425 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2426 (Lisp_Object function, Lisp_Object sequence)
2428 register EMACS_INT leni;
2430 leni = XFASTINT (Flength (sequence));
2431 if (CHAR_TABLE_P (sequence))
2432 wrong_type_argument (Qlistp, sequence);
2433 mapcar1 (leni, 0, function, sequence);
2435 return sequence;
2438 /* This is how C code calls `yes-or-no-p' and allows the user
2439 to redefined it.
2441 Anything that calls this function must protect from GC! */
2443 Lisp_Object
2444 do_yes_or_no_p (Lisp_Object prompt)
2446 return call1 (intern ("yes-or-no-p"), prompt);
2449 /* Anything that calls this function must protect from GC! */
2451 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2452 doc: /* Ask user a yes-or-no question. Return t if answer is yes.
2453 PROMPT is the string to display to ask the question. It should end in
2454 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2456 The user must confirm the answer with RET, and can edit it until it
2457 has been confirmed.
2459 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2460 is nil, and `use-dialog-box' is non-nil. */)
2461 (Lisp_Object prompt)
2463 register Lisp_Object ans;
2464 Lisp_Object args[2];
2465 struct gcpro gcpro1;
2467 CHECK_STRING (prompt);
2469 #ifdef HAVE_MENUS
2470 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2471 && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2472 && use_dialog_box
2473 && have_menus_p ())
2475 Lisp_Object pane, menu, obj;
2476 redisplay_preserve_echo_area (4);
2477 pane = Fcons (Fcons (build_string ("Yes"), Qt),
2478 Fcons (Fcons (build_string ("No"), Qnil),
2479 Qnil));
2480 GCPRO1 (pane);
2481 menu = Fcons (prompt, pane);
2482 obj = Fx_popup_dialog (Qt, menu, Qnil);
2483 UNGCPRO;
2484 return obj;
2486 #endif /* HAVE_MENUS */
2488 args[0] = prompt;
2489 args[1] = build_string ("(yes or no) ");
2490 prompt = Fconcat (2, args);
2492 GCPRO1 (prompt);
2494 while (1)
2496 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2497 Qyes_or_no_p_history, Qnil,
2498 Qnil));
2499 if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
2501 UNGCPRO;
2502 return Qt;
2504 if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
2506 UNGCPRO;
2507 return Qnil;
2510 Fding (Qnil);
2511 Fdiscard_input ();
2512 message ("Please answer yes or no.");
2513 Fsleep_for (make_number (2), Qnil);
2517 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2518 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2520 Each of the three load averages is multiplied by 100, then converted
2521 to integer.
2523 When USE-FLOATS is non-nil, floats will be used instead of integers.
2524 These floats are not multiplied by 100.
2526 If the 5-minute or 15-minute load averages are not available, return a
2527 shortened list, containing only those averages which are available.
2529 An error is thrown if the load average can't be obtained. In some
2530 cases making it work would require Emacs being installed setuid or
2531 setgid so that it can read kernel information, and that usually isn't
2532 advisable. */)
2533 (Lisp_Object use_floats)
2535 double load_ave[3];
2536 int loads = getloadavg (load_ave, 3);
2537 Lisp_Object ret = Qnil;
2539 if (loads < 0)
2540 error ("load-average not implemented for this operating system");
2542 while (loads-- > 0)
2544 Lisp_Object load = (NILP (use_floats) ?
2545 make_number ((int) (100.0 * load_ave[loads]))
2546 : make_float (load_ave[loads]));
2547 ret = Fcons (load, ret);
2550 return ret;
2553 Lisp_Object Qsubfeatures;
2555 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2556 doc: /* Return t if FEATURE is present in this Emacs.
2558 Use this to conditionalize execution of lisp code based on the
2559 presence or absence of Emacs or environment extensions.
2560 Use `provide' to declare that a feature is available. This function
2561 looks at the value of the variable `features'. The optional argument
2562 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2563 (Lisp_Object feature, Lisp_Object subfeature)
2565 register Lisp_Object tem;
2566 CHECK_SYMBOL (feature);
2567 tem = Fmemq (feature, Vfeatures);
2568 if (!NILP (tem) && !NILP (subfeature))
2569 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2570 return (NILP (tem)) ? Qnil : Qt;
2573 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2574 doc: /* Announce that FEATURE is a feature of the current Emacs.
2575 The optional argument SUBFEATURES should be a list of symbols listing
2576 particular subfeatures supported in this version of FEATURE. */)
2577 (Lisp_Object feature, Lisp_Object subfeatures)
2579 register Lisp_Object tem;
2580 CHECK_SYMBOL (feature);
2581 CHECK_LIST (subfeatures);
2582 if (!NILP (Vautoload_queue))
2583 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2584 Vautoload_queue);
2585 tem = Fmemq (feature, Vfeatures);
2586 if (NILP (tem))
2587 Vfeatures = Fcons (feature, Vfeatures);
2588 if (!NILP (subfeatures))
2589 Fput (feature, Qsubfeatures, subfeatures);
2590 LOADHIST_ATTACH (Fcons (Qprovide, feature));
2592 /* Run any load-hooks for this file. */
2593 tem = Fassq (feature, Vafter_load_alist);
2594 if (CONSP (tem))
2595 Fprogn (XCDR (tem));
2597 return feature;
2600 /* `require' and its subroutines. */
2602 /* List of features currently being require'd, innermost first. */
2604 Lisp_Object require_nesting_list;
2606 Lisp_Object
2607 require_unwind (Lisp_Object old_value)
2609 return require_nesting_list = old_value;
2612 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2613 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2614 If FEATURE is not a member of the list `features', then the feature
2615 is not loaded; so load the file FILENAME.
2616 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2617 and `load' will try to load this name appended with the suffix `.elc' or
2618 `.el', in that order. The name without appended suffix will not be used.
2619 If the optional third argument NOERROR is non-nil,
2620 then return nil if the file is not found instead of signaling an error.
2621 Normally the return value is FEATURE.
2622 The normal messages at start and end of loading FILENAME are suppressed. */)
2623 (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
2625 register Lisp_Object tem;
2626 struct gcpro gcpro1, gcpro2;
2627 int from_file = load_in_progress;
2629 CHECK_SYMBOL (feature);
2631 /* Record the presence of `require' in this file
2632 even if the feature specified is already loaded.
2633 But not more than once in any file,
2634 and not when we aren't loading or reading from a file. */
2635 if (!from_file)
2636 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2637 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2638 from_file = 1;
2640 if (from_file)
2642 tem = Fcons (Qrequire, feature);
2643 if (NILP (Fmember (tem, Vcurrent_load_list)))
2644 LOADHIST_ATTACH (tem);
2646 tem = Fmemq (feature, Vfeatures);
2648 if (NILP (tem))
2650 int count = SPECPDL_INDEX ();
2651 int nesting = 0;
2653 /* This is to make sure that loadup.el gives a clear picture
2654 of what files are preloaded and when. */
2655 if (! NILP (Vpurify_flag))
2656 error ("(require %s) while preparing to dump",
2657 SDATA (SYMBOL_NAME (feature)));
2659 /* A certain amount of recursive `require' is legitimate,
2660 but if we require the same feature recursively 3 times,
2661 signal an error. */
2662 tem = require_nesting_list;
2663 while (! NILP (tem))
2665 if (! NILP (Fequal (feature, XCAR (tem))))
2666 nesting++;
2667 tem = XCDR (tem);
2669 if (nesting > 3)
2670 error ("Recursive `require' for feature `%s'",
2671 SDATA (SYMBOL_NAME (feature)));
2673 /* Update the list for any nested `require's that occur. */
2674 record_unwind_protect (require_unwind, require_nesting_list);
2675 require_nesting_list = Fcons (feature, require_nesting_list);
2677 /* Value saved here is to be restored into Vautoload_queue */
2678 record_unwind_protect (un_autoload, Vautoload_queue);
2679 Vautoload_queue = Qt;
2681 /* Load the file. */
2682 GCPRO2 (feature, filename);
2683 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2684 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2685 UNGCPRO;
2687 /* If load failed entirely, return nil. */
2688 if (NILP (tem))
2689 return unbind_to (count, Qnil);
2691 tem = Fmemq (feature, Vfeatures);
2692 if (NILP (tem))
2693 error ("Required feature `%s' was not provided",
2694 SDATA (SYMBOL_NAME (feature)));
2696 /* Once loading finishes, don't undo it. */
2697 Vautoload_queue = Qt;
2698 feature = unbind_to (count, feature);
2701 return feature;
2704 /* Primitives for work of the "widget" library.
2705 In an ideal world, this section would not have been necessary.
2706 However, lisp function calls being as slow as they are, it turns
2707 out that some functions in the widget library (wid-edit.el) are the
2708 bottleneck of Widget operation. Here is their translation to C,
2709 for the sole reason of efficiency. */
2711 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2712 doc: /* Return non-nil if PLIST has the property PROP.
2713 PLIST is a property list, which is a list of the form
2714 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2715 Unlike `plist-get', this allows you to distinguish between a missing
2716 property and a property with the value nil.
2717 The value is actually the tail of PLIST whose car is PROP. */)
2718 (Lisp_Object plist, Lisp_Object prop)
2720 while (CONSP (plist) && !EQ (XCAR (plist), prop))
2722 QUIT;
2723 plist = XCDR (plist);
2724 plist = CDR (plist);
2726 return plist;
2729 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2730 doc: /* In WIDGET, set PROPERTY to VALUE.
2731 The value can later be retrieved with `widget-get'. */)
2732 (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
2734 CHECK_CONS (widget);
2735 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
2736 return value;
2739 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2740 doc: /* In WIDGET, get the value of PROPERTY.
2741 The value could either be specified when the widget was created, or
2742 later with `widget-put'. */)
2743 (Lisp_Object widget, Lisp_Object property)
2745 Lisp_Object tmp;
2747 while (1)
2749 if (NILP (widget))
2750 return Qnil;
2751 CHECK_CONS (widget);
2752 tmp = Fplist_member (XCDR (widget), property);
2753 if (CONSP (tmp))
2755 tmp = XCDR (tmp);
2756 return CAR (tmp);
2758 tmp = XCAR (widget);
2759 if (NILP (tmp))
2760 return Qnil;
2761 widget = Fget (tmp, Qwidget_type);
2765 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2766 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2767 ARGS are passed as extra arguments to the function.
2768 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2769 (int nargs, Lisp_Object *args)
2771 /* This function can GC. */
2772 Lisp_Object newargs[3];
2773 struct gcpro gcpro1, gcpro2;
2774 Lisp_Object result;
2776 newargs[0] = Fwidget_get (args[0], args[1]);
2777 newargs[1] = args[0];
2778 newargs[2] = Flist (nargs - 2, args + 2);
2779 GCPRO2 (newargs[0], newargs[2]);
2780 result = Fapply (3, newargs);
2781 UNGCPRO;
2782 return result;
2785 #ifdef HAVE_LANGINFO_CODESET
2786 #include <langinfo.h>
2787 #endif
2789 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
2790 doc: /* Access locale data ITEM for the current C locale, if available.
2791 ITEM should be one of the following:
2793 `codeset', returning the character set as a string (locale item CODESET);
2795 `days', returning a 7-element vector of day names (locale items DAY_n);
2797 `months', returning a 12-element vector of month names (locale items MON_n);
2799 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2800 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2802 If the system can't provide such information through a call to
2803 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2805 See also Info node `(libc)Locales'.
2807 The data read from the system are decoded using `locale-coding-system'. */)
2808 (Lisp_Object item)
2810 char *str = NULL;
2811 #ifdef HAVE_LANGINFO_CODESET
2812 Lisp_Object val;
2813 if (EQ (item, Qcodeset))
2815 str = nl_langinfo (CODESET);
2816 return build_string (str);
2818 #ifdef DAY_1
2819 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
2821 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
2822 const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
2823 int i;
2824 struct gcpro gcpro1;
2825 GCPRO1 (v);
2826 synchronize_system_time_locale ();
2827 for (i = 0; i < 7; i++)
2829 str = nl_langinfo (days[i]);
2830 val = make_unibyte_string (str, strlen (str));
2831 /* Fixme: Is this coding system necessarily right, even if
2832 it is consistent with CODESET? If not, what to do? */
2833 Faset (v, make_number (i),
2834 code_convert_string_norecord (val, Vlocale_coding_system,
2835 0));
2837 UNGCPRO;
2838 return v;
2840 #endif /* DAY_1 */
2841 #ifdef MON_1
2842 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
2844 Lisp_Object v = Fmake_vector (make_number (12), Qnil);
2845 const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
2846 MON_8, MON_9, MON_10, MON_11, MON_12};
2847 int i;
2848 struct gcpro gcpro1;
2849 GCPRO1 (v);
2850 synchronize_system_time_locale ();
2851 for (i = 0; i < 12; i++)
2853 str = nl_langinfo (months[i]);
2854 val = make_unibyte_string (str, strlen (str));
2855 Faset (v, make_number (i),
2856 code_convert_string_norecord (val, Vlocale_coding_system, 0));
2858 UNGCPRO;
2859 return v;
2861 #endif /* MON_1 */
2862 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2863 but is in the locale files. This could be used by ps-print. */
2864 #ifdef PAPER_WIDTH
2865 else if (EQ (item, Qpaper))
2867 return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
2868 make_number (nl_langinfo (PAPER_HEIGHT)));
2870 #endif /* PAPER_WIDTH */
2871 #endif /* HAVE_LANGINFO_CODESET*/
2872 return Qnil;
2875 /* base64 encode/decode functions (RFC 2045).
2876 Based on code from GNU recode. */
2878 #define MIME_LINE_LENGTH 76
2880 #define IS_ASCII(Character) \
2881 ((Character) < 128)
2882 #define IS_BASE64(Character) \
2883 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2884 #define IS_BASE64_IGNORABLE(Character) \
2885 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2886 || (Character) == '\f' || (Character) == '\r')
2888 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2889 character or return retval if there are no characters left to
2890 process. */
2891 #define READ_QUADRUPLET_BYTE(retval) \
2892 do \
2894 if (i == length) \
2896 if (nchars_return) \
2897 *nchars_return = nchars; \
2898 return (retval); \
2900 c = from[i++]; \
2902 while (IS_BASE64_IGNORABLE (c))
2904 /* Table of characters coding the 64 values. */
2905 static const char base64_value_to_char[64] =
2907 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2908 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2909 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2910 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2911 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2912 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2913 '8', '9', '+', '/' /* 60-63 */
2916 /* Table of base64 values for first 128 characters. */
2917 static const short base64_char_to_value[128] =
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2920 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2921 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2922 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2923 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2924 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2925 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2926 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2927 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2928 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2929 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2930 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2931 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2934 /* The following diagram shows the logical steps by which three octets
2935 get transformed into four base64 characters.
2937 .--------. .--------. .--------.
2938 |aaaaaabb| |bbbbcccc| |ccdddddd|
2939 `--------' `--------' `--------'
2940 6 2 4 4 2 6
2941 .--------+--------+--------+--------.
2942 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2943 `--------+--------+--------+--------'
2945 .--------+--------+--------+--------.
2946 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2947 `--------+--------+--------+--------'
2949 The octets are divided into 6 bit chunks, which are then encoded into
2950 base64 characters. */
2953 static EMACS_INT base64_encode_1 (const char *, char *, EMACS_INT, int, int);
2954 static EMACS_INT base64_decode_1 (const char *, char *, EMACS_INT, int,
2955 EMACS_INT *);
2957 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
2958 2, 3, "r",
2959 doc: /* Base64-encode the region between BEG and END.
2960 Return the length of the encoded text.
2961 Optional third argument NO-LINE-BREAK means do not break long lines
2962 into shorter lines. */)
2963 (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
2965 char *encoded;
2966 EMACS_INT allength, length;
2967 EMACS_INT ibeg, iend, encoded_length;
2968 EMACS_INT old_pos = PT;
2969 USE_SAFE_ALLOCA;
2971 validate_region (&beg, &end);
2973 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
2974 iend = CHAR_TO_BYTE (XFASTINT (end));
2975 move_gap_both (XFASTINT (beg), ibeg);
2977 /* We need to allocate enough room for encoding the text.
2978 We need 33 1/3% more space, plus a newline every 76
2979 characters, and then we round up. */
2980 length = iend - ibeg;
2981 allength = length + length/3 + 1;
2982 allength += allength / MIME_LINE_LENGTH + 1 + 6;
2984 SAFE_ALLOCA (encoded, char *, allength);
2985 encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
2986 NILP (no_line_break),
2987 !NILP (current_buffer->enable_multibyte_characters));
2988 if (encoded_length > allength)
2989 abort ();
2991 if (encoded_length < 0)
2993 /* The encoding wasn't possible. */
2994 SAFE_FREE ();
2995 error ("Multibyte character in data for base64 encoding");
2998 /* Now we have encoded the region, so we insert the new contents
2999 and delete the old. (Insert first in order to preserve markers.) */
3000 SET_PT_BOTH (XFASTINT (beg), ibeg);
3001 insert (encoded, encoded_length);
3002 SAFE_FREE ();
3003 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3005 /* If point was outside of the region, restore it exactly; else just
3006 move to the beginning of the region. */
3007 if (old_pos >= XFASTINT (end))
3008 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3009 else if (old_pos > XFASTINT (beg))
3010 old_pos = XFASTINT (beg);
3011 SET_PT (old_pos);
3013 /* We return the length of the encoded text. */
3014 return make_number (encoded_length);
3017 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3018 1, 2, 0,
3019 doc: /* Base64-encode STRING and return the result.
3020 Optional second argument NO-LINE-BREAK means do not break long lines
3021 into shorter lines. */)
3022 (Lisp_Object string, Lisp_Object no_line_break)
3024 EMACS_INT allength, length, encoded_length;
3025 char *encoded;
3026 Lisp_Object encoded_string;
3027 USE_SAFE_ALLOCA;
3029 CHECK_STRING (string);
3031 /* We need to allocate enough room for encoding the text.
3032 We need 33 1/3% more space, plus a newline every 76
3033 characters, and then we round up. */
3034 length = SBYTES (string);
3035 allength = length + length/3 + 1;
3036 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3038 /* We need to allocate enough room for decoding the text. */
3039 SAFE_ALLOCA (encoded, char *, allength);
3041 encoded_length = base64_encode_1 (SSDATA (string),
3042 encoded, length, NILP (no_line_break),
3043 STRING_MULTIBYTE (string));
3044 if (encoded_length > allength)
3045 abort ();
3047 if (encoded_length < 0)
3049 /* The encoding wasn't possible. */
3050 SAFE_FREE ();
3051 error ("Multibyte character in data for base64 encoding");
3054 encoded_string = make_unibyte_string (encoded, encoded_length);
3055 SAFE_FREE ();
3057 return encoded_string;
3060 static EMACS_INT
3061 base64_encode_1 (const char *from, char *to, EMACS_INT length,
3062 int line_break, int multibyte)
3064 int counter = 0;
3065 EMACS_INT i = 0;
3066 char *e = to;
3067 int c;
3068 unsigned int value;
3069 int bytes;
3071 while (i < length)
3073 if (multibyte)
3075 c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3076 if (CHAR_BYTE8_P (c))
3077 c = CHAR_TO_BYTE8 (c);
3078 else if (c >= 256)
3079 return -1;
3080 i += bytes;
3082 else
3083 c = from[i++];
3085 /* Wrap line every 76 characters. */
3087 if (line_break)
3089 if (counter < MIME_LINE_LENGTH / 4)
3090 counter++;
3091 else
3093 *e++ = '\n';
3094 counter = 1;
3098 /* Process first byte of a triplet. */
3100 *e++ = base64_value_to_char[0x3f & c >> 2];
3101 value = (0x03 & c) << 4;
3103 /* Process second byte of a triplet. */
3105 if (i == length)
3107 *e++ = base64_value_to_char[value];
3108 *e++ = '=';
3109 *e++ = '=';
3110 break;
3113 if (multibyte)
3115 c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3116 if (CHAR_BYTE8_P (c))
3117 c = CHAR_TO_BYTE8 (c);
3118 else if (c >= 256)
3119 return -1;
3120 i += bytes;
3122 else
3123 c = from[i++];
3125 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3126 value = (0x0f & c) << 2;
3128 /* Process third byte of a triplet. */
3130 if (i == length)
3132 *e++ = base64_value_to_char[value];
3133 *e++ = '=';
3134 break;
3137 if (multibyte)
3139 c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3140 if (CHAR_BYTE8_P (c))
3141 c = CHAR_TO_BYTE8 (c);
3142 else if (c >= 256)
3143 return -1;
3144 i += bytes;
3146 else
3147 c = from[i++];
3149 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3150 *e++ = base64_value_to_char[0x3f & c];
3153 return e - to;
3157 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3158 2, 2, "r",
3159 doc: /* Base64-decode the region between BEG and END.
3160 Return the length of the decoded text.
3161 If the region can't be decoded, signal an error and don't modify the buffer. */)
3162 (Lisp_Object beg, Lisp_Object end)
3164 EMACS_INT ibeg, iend, length, allength;
3165 char *decoded;
3166 EMACS_INT old_pos = PT;
3167 EMACS_INT decoded_length;
3168 EMACS_INT inserted_chars;
3169 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
3170 USE_SAFE_ALLOCA;
3172 validate_region (&beg, &end);
3174 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3175 iend = CHAR_TO_BYTE (XFASTINT (end));
3177 length = iend - ibeg;
3179 /* We need to allocate enough room for decoding the text. If we are
3180 working on a multibyte buffer, each decoded code may occupy at
3181 most two bytes. */
3182 allength = multibyte ? length * 2 : length;
3183 SAFE_ALLOCA (decoded, char *, allength);
3185 move_gap_both (XFASTINT (beg), ibeg);
3186 decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
3187 multibyte, &inserted_chars);
3188 if (decoded_length > allength)
3189 abort ();
3191 if (decoded_length < 0)
3193 /* The decoding wasn't possible. */
3194 SAFE_FREE ();
3195 error ("Invalid base64 data");
3198 /* Now we have decoded the region, so we insert the new contents
3199 and delete the old. (Insert first in order to preserve markers.) */
3200 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3201 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3202 SAFE_FREE ();
3204 /* Delete the original text. */
3205 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3206 iend + decoded_length, 1);
3208 /* If point was outside of the region, restore it exactly; else just
3209 move to the beginning of the region. */
3210 if (old_pos >= XFASTINT (end))
3211 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3212 else if (old_pos > XFASTINT (beg))
3213 old_pos = XFASTINT (beg);
3214 SET_PT (old_pos > ZV ? ZV : old_pos);
3216 return make_number (inserted_chars);
3219 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3220 1, 1, 0,
3221 doc: /* Base64-decode STRING and return the result. */)
3222 (Lisp_Object string)
3224 char *decoded;
3225 EMACS_INT length, decoded_length;
3226 Lisp_Object decoded_string;
3227 USE_SAFE_ALLOCA;
3229 CHECK_STRING (string);
3231 length = SBYTES (string);
3232 /* We need to allocate enough room for decoding the text. */
3233 SAFE_ALLOCA (decoded, char *, length);
3235 /* The decoded result should be unibyte. */
3236 decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
3237 0, NULL);
3238 if (decoded_length > length)
3239 abort ();
3240 else if (decoded_length >= 0)
3241 decoded_string = make_unibyte_string (decoded, decoded_length);
3242 else
3243 decoded_string = Qnil;
3245 SAFE_FREE ();
3246 if (!STRINGP (decoded_string))
3247 error ("Invalid base64 data");
3249 return decoded_string;
3252 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3253 MULTIBYTE is nonzero, the decoded result should be in multibyte
3254 form. If NCHARS_RETRUN is not NULL, store the number of produced
3255 characters in *NCHARS_RETURN. */
3257 static EMACS_INT
3258 base64_decode_1 (const char *from, char *to, EMACS_INT length,
3259 int multibyte, EMACS_INT *nchars_return)
3261 EMACS_INT i = 0; /* Used inside READ_QUADRUPLET_BYTE */
3262 char *e = to;
3263 unsigned char c;
3264 unsigned long value;
3265 EMACS_INT nchars = 0;
3267 while (1)
3269 /* Process first byte of a quadruplet. */
3271 READ_QUADRUPLET_BYTE (e-to);
3273 if (!IS_BASE64 (c))
3274 return -1;
3275 value = base64_char_to_value[c] << 18;
3277 /* Process second byte of a quadruplet. */
3279 READ_QUADRUPLET_BYTE (-1);
3281 if (!IS_BASE64 (c))
3282 return -1;
3283 value |= base64_char_to_value[c] << 12;
3285 c = (unsigned char) (value >> 16);
3286 if (multibyte && c >= 128)
3287 e += BYTE8_STRING (c, e);
3288 else
3289 *e++ = c;
3290 nchars++;
3292 /* Process third byte of a quadruplet. */
3294 READ_QUADRUPLET_BYTE (-1);
3296 if (c == '=')
3298 READ_QUADRUPLET_BYTE (-1);
3300 if (c != '=')
3301 return -1;
3302 continue;
3305 if (!IS_BASE64 (c))
3306 return -1;
3307 value |= base64_char_to_value[c] << 6;
3309 c = (unsigned char) (0xff & value >> 8);
3310 if (multibyte && c >= 128)
3311 e += BYTE8_STRING (c, e);
3312 else
3313 *e++ = c;
3314 nchars++;
3316 /* Process fourth byte of a quadruplet. */
3318 READ_QUADRUPLET_BYTE (-1);
3320 if (c == '=')
3321 continue;
3323 if (!IS_BASE64 (c))
3324 return -1;
3325 value |= base64_char_to_value[c];
3327 c = (unsigned char) (0xff & value);
3328 if (multibyte && c >= 128)
3329 e += BYTE8_STRING (c, e);
3330 else
3331 *e++ = c;
3332 nchars++;
3338 /***********************************************************************
3339 ***** *****
3340 ***** Hash Tables *****
3341 ***** *****
3342 ***********************************************************************/
3344 /* Implemented by gerd@gnu.org. This hash table implementation was
3345 inspired by CMUCL hash tables. */
3347 /* Ideas:
3349 1. For small tables, association lists are probably faster than
3350 hash tables because they have lower overhead.
3352 For uses of hash tables where the O(1) behavior of table
3353 operations is not a requirement, it might therefore be a good idea
3354 not to hash. Instead, we could just do a linear search in the
3355 key_and_value vector of the hash table. This could be done
3356 if a `:linear-search t' argument is given to make-hash-table. */
3359 /* The list of all weak hash tables. Don't staticpro this one. */
3361 struct Lisp_Hash_Table *weak_hash_tables;
3363 /* Various symbols. */
3365 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
3366 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
3367 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
3369 /* Function prototypes. */
3371 static struct Lisp_Hash_Table *check_hash_table (Lisp_Object);
3372 static int get_key_arg (Lisp_Object, int, Lisp_Object *, char *);
3373 static void maybe_resize_hash_table (struct Lisp_Hash_Table *);
3374 static int cmpfn_eql (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3375 Lisp_Object, unsigned);
3376 static int cmpfn_equal (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3377 Lisp_Object, unsigned);
3378 static int cmpfn_user_defined (struct Lisp_Hash_Table *, Lisp_Object,
3379 unsigned, Lisp_Object, unsigned);
3380 static unsigned hashfn_eq (struct Lisp_Hash_Table *, Lisp_Object);
3381 static unsigned hashfn_eql (struct Lisp_Hash_Table *, Lisp_Object);
3382 static unsigned hashfn_equal (struct Lisp_Hash_Table *, Lisp_Object);
3383 static unsigned hashfn_user_defined (struct Lisp_Hash_Table *,
3384 Lisp_Object);
3385 static unsigned sxhash_string (unsigned char *, int);
3386 static unsigned sxhash_list (Lisp_Object, int);
3387 static unsigned sxhash_vector (Lisp_Object, int);
3388 static unsigned sxhash_bool_vector (Lisp_Object);
3389 static int sweep_weak_table (struct Lisp_Hash_Table *, int);
3393 /***********************************************************************
3394 Utilities
3395 ***********************************************************************/
3397 /* If OBJ is a Lisp hash table, return a pointer to its struct
3398 Lisp_Hash_Table. Otherwise, signal an error. */
3400 static struct Lisp_Hash_Table *
3401 check_hash_table (Lisp_Object obj)
3403 CHECK_HASH_TABLE (obj);
3404 return XHASH_TABLE (obj);
3408 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3409 number. */
3412 next_almost_prime (int n)
3414 if (n % 2 == 0)
3415 n += 1;
3416 if (n % 3 == 0)
3417 n += 2;
3418 if (n % 7 == 0)
3419 n += 4;
3420 return n;
3424 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3425 which USED[I] is non-zero. If found at index I in ARGS, set
3426 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3427 -1. This function is used to extract a keyword/argument pair from
3428 a DEFUN parameter list. */
3430 static int
3431 get_key_arg (Lisp_Object key, int nargs, Lisp_Object *args, char *used)
3433 int i;
3435 for (i = 0; i < nargs - 1; ++i)
3436 if (!used[i] && EQ (args[i], key))
3437 break;
3439 if (i >= nargs - 1)
3440 i = -1;
3441 else
3443 used[i++] = 1;
3444 used[i] = 1;
3447 return i;
3451 /* Return a Lisp vector which has the same contents as VEC but has
3452 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3453 vector that are not copied from VEC are set to INIT. */
3455 Lisp_Object
3456 larger_vector (Lisp_Object vec, int new_size, Lisp_Object init)
3458 struct Lisp_Vector *v;
3459 int i, old_size;
3461 xassert (VECTORP (vec));
3462 old_size = ASIZE (vec);
3463 xassert (new_size >= old_size);
3465 v = allocate_vector (new_size);
3466 memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
3467 for (i = old_size; i < new_size; ++i)
3468 v->contents[i] = init;
3469 XSETVECTOR (vec, v);
3470 return vec;
3474 /***********************************************************************
3475 Low-level Functions
3476 ***********************************************************************/
3478 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3479 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3480 KEY2 are the same. */
3482 static int
3483 cmpfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3485 return (FLOATP (key1)
3486 && FLOATP (key2)
3487 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3491 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3492 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3493 KEY2 are the same. */
3495 static int
3496 cmpfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3498 return hash1 == hash2 && !NILP (Fequal (key1, key2));
3502 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3503 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3504 if KEY1 and KEY2 are the same. */
3506 static int
3507 cmpfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
3509 if (hash1 == hash2)
3511 Lisp_Object args[3];
3513 args[0] = h->user_cmp_function;
3514 args[1] = key1;
3515 args[2] = key2;
3516 return !NILP (Ffuncall (3, args));
3518 else
3519 return 0;
3523 /* Value is a hash code for KEY for use in hash table H which uses
3524 `eq' to compare keys. The hash code returned is guaranteed to fit
3525 in a Lisp integer. */
3527 static unsigned
3528 hashfn_eq (struct Lisp_Hash_Table *h, Lisp_Object key)
3530 unsigned hash = XUINT (key) ^ XTYPE (key);
3531 xassert ((hash & ~INTMASK) == 0);
3532 return hash;
3536 /* Value is a hash code for KEY for use in hash table H which uses
3537 `eql' to compare keys. The hash code returned is guaranteed to fit
3538 in a Lisp integer. */
3540 static unsigned
3541 hashfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key)
3543 unsigned hash;
3544 if (FLOATP (key))
3545 hash = sxhash (key, 0);
3546 else
3547 hash = XUINT (key) ^ XTYPE (key);
3548 xassert ((hash & ~INTMASK) == 0);
3549 return hash;
3553 /* Value is a hash code for KEY for use in hash table H which uses
3554 `equal' to compare keys. The hash code returned is guaranteed to fit
3555 in a Lisp integer. */
3557 static unsigned
3558 hashfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key)
3560 unsigned hash = sxhash (key, 0);
3561 xassert ((hash & ~INTMASK) == 0);
3562 return hash;
3566 /* Value is a hash code for KEY for use in hash table H which uses as
3567 user-defined function to compare keys. The hash code returned is
3568 guaranteed to fit in a Lisp integer. */
3570 static unsigned
3571 hashfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key)
3573 Lisp_Object args[2], hash;
3575 args[0] = h->user_hash_function;
3576 args[1] = key;
3577 hash = Ffuncall (2, args);
3578 if (!INTEGERP (hash))
3579 signal_error ("Invalid hash code returned from user-supplied hash function", hash);
3580 return XUINT (hash);
3584 /* Create and initialize a new hash table.
3586 TEST specifies the test the hash table will use to compare keys.
3587 It must be either one of the predefined tests `eq', `eql' or
3588 `equal' or a symbol denoting a user-defined test named TEST with
3589 test and hash functions USER_TEST and USER_HASH.
3591 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3593 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3594 new size when it becomes full is computed by adding REHASH_SIZE to
3595 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3596 table's new size is computed by multiplying its old size with
3597 REHASH_SIZE.
3599 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3600 be resized when the ratio of (number of entries in the table) /
3601 (table size) is >= REHASH_THRESHOLD.
3603 WEAK specifies the weakness of the table. If non-nil, it must be
3604 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3606 Lisp_Object
3607 make_hash_table (Lisp_Object test, Lisp_Object size, Lisp_Object rehash_size,
3608 Lisp_Object rehash_threshold, Lisp_Object weak,
3609 Lisp_Object user_test, Lisp_Object user_hash)
3611 struct Lisp_Hash_Table *h;
3612 Lisp_Object table;
3613 int index_size, i, sz;
3615 /* Preconditions. */
3616 xassert (SYMBOLP (test));
3617 xassert (INTEGERP (size) && XINT (size) >= 0);
3618 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
3619 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
3620 xassert (FLOATP (rehash_threshold)
3621 && XFLOATINT (rehash_threshold) > 0
3622 && XFLOATINT (rehash_threshold) <= 1.0);
3624 if (XFASTINT (size) == 0)
3625 size = make_number (1);
3627 /* Allocate a table and initialize it. */
3628 h = allocate_hash_table ();
3630 /* Initialize hash table slots. */
3631 sz = XFASTINT (size);
3633 h->test = test;
3634 if (EQ (test, Qeql))
3636 h->cmpfn = cmpfn_eql;
3637 h->hashfn = hashfn_eql;
3639 else if (EQ (test, Qeq))
3641 h->cmpfn = NULL;
3642 h->hashfn = hashfn_eq;
3644 else if (EQ (test, Qequal))
3646 h->cmpfn = cmpfn_equal;
3647 h->hashfn = hashfn_equal;
3649 else
3651 h->user_cmp_function = user_test;
3652 h->user_hash_function = user_hash;
3653 h->cmpfn = cmpfn_user_defined;
3654 h->hashfn = hashfn_user_defined;
3657 h->weak = weak;
3658 h->rehash_threshold = rehash_threshold;
3659 h->rehash_size = rehash_size;
3660 h->count = 0;
3661 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
3662 h->hash = Fmake_vector (size, Qnil);
3663 h->next = Fmake_vector (size, Qnil);
3664 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3665 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
3666 h->index = Fmake_vector (make_number (index_size), Qnil);
3668 /* Set up the free list. */
3669 for (i = 0; i < sz - 1; ++i)
3670 HASH_NEXT (h, i) = make_number (i + 1);
3671 h->next_free = make_number (0);
3673 XSET_HASH_TABLE (table, h);
3674 xassert (HASH_TABLE_P (table));
3675 xassert (XHASH_TABLE (table) == h);
3677 /* Maybe add this hash table to the list of all weak hash tables. */
3678 if (NILP (h->weak))
3679 h->next_weak = NULL;
3680 else
3682 h->next_weak = weak_hash_tables;
3683 weak_hash_tables = h;
3686 return table;
3690 /* Return a copy of hash table H1. Keys and values are not copied,
3691 only the table itself is. */
3693 static Lisp_Object
3694 copy_hash_table (struct Lisp_Hash_Table *h1)
3696 Lisp_Object table;
3697 struct Lisp_Hash_Table *h2;
3698 struct Lisp_Vector *next;
3700 h2 = allocate_hash_table ();
3701 next = h2->vec_next;
3702 memcpy (h2, h1, sizeof *h2);
3703 h2->vec_next = next;
3704 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
3705 h2->hash = Fcopy_sequence (h1->hash);
3706 h2->next = Fcopy_sequence (h1->next);
3707 h2->index = Fcopy_sequence (h1->index);
3708 XSET_HASH_TABLE (table, h2);
3710 /* Maybe add this hash table to the list of all weak hash tables. */
3711 if (!NILP (h2->weak))
3713 h2->next_weak = weak_hash_tables;
3714 weak_hash_tables = h2;
3717 return table;
3721 /* Resize hash table H if it's too full. If H cannot be resized
3722 because it's already too large, throw an error. */
3724 static INLINE void
3725 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
3727 if (NILP (h->next_free))
3729 int old_size = HASH_TABLE_SIZE (h);
3730 int i, new_size, index_size;
3731 EMACS_INT nsize;
3733 if (INTEGERP (h->rehash_size))
3734 new_size = old_size + XFASTINT (h->rehash_size);
3735 else
3736 new_size = old_size * XFLOATINT (h->rehash_size);
3737 new_size = max (old_size + 1, new_size);
3738 index_size = next_almost_prime ((int)
3739 (new_size
3740 / XFLOATINT (h->rehash_threshold)));
3741 /* Assignment to EMACS_INT stops GCC whining about limited range
3742 of data type. */
3743 nsize = max (index_size, 2 * new_size);
3744 if (nsize > MOST_POSITIVE_FIXNUM)
3745 error ("Hash table too large to resize");
3747 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
3748 h->next = larger_vector (h->next, new_size, Qnil);
3749 h->hash = larger_vector (h->hash, new_size, Qnil);
3750 h->index = Fmake_vector (make_number (index_size), Qnil);
3752 /* Update the free list. Do it so that new entries are added at
3753 the end of the free list. This makes some operations like
3754 maphash faster. */
3755 for (i = old_size; i < new_size - 1; ++i)
3756 HASH_NEXT (h, i) = make_number (i + 1);
3758 if (!NILP (h->next_free))
3760 Lisp_Object last, next;
3762 last = h->next_free;
3763 while (next = HASH_NEXT (h, XFASTINT (last)),
3764 !NILP (next))
3765 last = next;
3767 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
3769 else
3770 XSETFASTINT (h->next_free, old_size);
3772 /* Rehash. */
3773 for (i = 0; i < old_size; ++i)
3774 if (!NILP (HASH_HASH (h, i)))
3776 unsigned hash_code = XUINT (HASH_HASH (h, i));
3777 int start_of_bucket = hash_code % ASIZE (h->index);
3778 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
3779 HASH_INDEX (h, start_of_bucket) = make_number (i);
3785 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3786 the hash code of KEY. Value is the index of the entry in H
3787 matching KEY, or -1 if not found. */
3790 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, unsigned int *hash)
3792 unsigned hash_code;
3793 int start_of_bucket;
3794 Lisp_Object idx;
3796 hash_code = h->hashfn (h, key);
3797 if (hash)
3798 *hash = hash_code;
3800 start_of_bucket = hash_code % ASIZE (h->index);
3801 idx = HASH_INDEX (h, start_of_bucket);
3803 /* We need not gcpro idx since it's either an integer or nil. */
3804 while (!NILP (idx))
3806 int i = XFASTINT (idx);
3807 if (EQ (key, HASH_KEY (h, i))
3808 || (h->cmpfn
3809 && h->cmpfn (h, key, hash_code,
3810 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
3811 break;
3812 idx = HASH_NEXT (h, i);
3815 return NILP (idx) ? -1 : XFASTINT (idx);
3819 /* Put an entry into hash table H that associates KEY with VALUE.
3820 HASH is a previously computed hash code of KEY.
3821 Value is the index of the entry in H matching KEY. */
3824 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, unsigned int hash)
3826 int start_of_bucket, i;
3828 xassert ((hash & ~INTMASK) == 0);
3830 /* Increment count after resizing because resizing may fail. */
3831 maybe_resize_hash_table (h);
3832 h->count++;
3834 /* Store key/value in the key_and_value vector. */
3835 i = XFASTINT (h->next_free);
3836 h->next_free = HASH_NEXT (h, i);
3837 HASH_KEY (h, i) = key;
3838 HASH_VALUE (h, i) = value;
3840 /* Remember its hash code. */
3841 HASH_HASH (h, i) = make_number (hash);
3843 /* Add new entry to its collision chain. */
3844 start_of_bucket = hash % ASIZE (h->index);
3845 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
3846 HASH_INDEX (h, start_of_bucket) = make_number (i);
3847 return i;
3851 /* Remove the entry matching KEY from hash table H, if there is one. */
3853 static void
3854 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
3856 unsigned hash_code;
3857 int start_of_bucket;
3858 Lisp_Object idx, prev;
3860 hash_code = h->hashfn (h, key);
3861 start_of_bucket = hash_code % ASIZE (h->index);
3862 idx = HASH_INDEX (h, start_of_bucket);
3863 prev = Qnil;
3865 /* We need not gcpro idx, prev since they're either integers or nil. */
3866 while (!NILP (idx))
3868 int i = XFASTINT (idx);
3870 if (EQ (key, HASH_KEY (h, i))
3871 || (h->cmpfn
3872 && h->cmpfn (h, key, hash_code,
3873 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
3875 /* Take entry out of collision chain. */
3876 if (NILP (prev))
3877 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
3878 else
3879 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
3881 /* Clear slots in key_and_value and add the slots to
3882 the free list. */
3883 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
3884 HASH_NEXT (h, i) = h->next_free;
3885 h->next_free = make_number (i);
3886 h->count--;
3887 xassert (h->count >= 0);
3888 break;
3890 else
3892 prev = idx;
3893 idx = HASH_NEXT (h, i);
3899 /* Clear hash table H. */
3901 static void
3902 hash_clear (struct Lisp_Hash_Table *h)
3904 if (h->count > 0)
3906 int i, size = HASH_TABLE_SIZE (h);
3908 for (i = 0; i < size; ++i)
3910 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
3911 HASH_KEY (h, i) = Qnil;
3912 HASH_VALUE (h, i) = Qnil;
3913 HASH_HASH (h, i) = Qnil;
3916 for (i = 0; i < ASIZE (h->index); ++i)
3917 ASET (h->index, i, Qnil);
3919 h->next_free = make_number (0);
3920 h->count = 0;
3926 /************************************************************************
3927 Weak Hash Tables
3928 ************************************************************************/
3930 void
3931 init_weak_hash_tables (void)
3933 weak_hash_tables = NULL;
3936 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3937 entries from the table that don't survive the current GC.
3938 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3939 non-zero if anything was marked. */
3941 static int
3942 sweep_weak_table (struct Lisp_Hash_Table *h, int remove_entries_p)
3944 int bucket, n, marked;
3946 n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
3947 marked = 0;
3949 for (bucket = 0; bucket < n; ++bucket)
3951 Lisp_Object idx, next, prev;
3953 /* Follow collision chain, removing entries that
3954 don't survive this garbage collection. */
3955 prev = Qnil;
3956 for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
3958 int i = XFASTINT (idx);
3959 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
3960 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
3961 int remove_p;
3963 if (EQ (h->weak, Qkey))
3964 remove_p = !key_known_to_survive_p;
3965 else if (EQ (h->weak, Qvalue))
3966 remove_p = !value_known_to_survive_p;
3967 else if (EQ (h->weak, Qkey_or_value))
3968 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
3969 else if (EQ (h->weak, Qkey_and_value))
3970 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
3971 else
3972 abort ();
3974 next = HASH_NEXT (h, i);
3976 if (remove_entries_p)
3978 if (remove_p)
3980 /* Take out of collision chain. */
3981 if (NILP (prev))
3982 HASH_INDEX (h, bucket) = next;
3983 else
3984 HASH_NEXT (h, XFASTINT (prev)) = next;
3986 /* Add to free list. */
3987 HASH_NEXT (h, i) = h->next_free;
3988 h->next_free = idx;
3990 /* Clear key, value, and hash. */
3991 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
3992 HASH_HASH (h, i) = Qnil;
3994 h->count--;
3996 else
3998 prev = idx;
4001 else
4003 if (!remove_p)
4005 /* Make sure key and value survive. */
4006 if (!key_known_to_survive_p)
4008 mark_object (HASH_KEY (h, i));
4009 marked = 1;
4012 if (!value_known_to_survive_p)
4014 mark_object (HASH_VALUE (h, i));
4015 marked = 1;
4022 return marked;
4025 /* Remove elements from weak hash tables that don't survive the
4026 current garbage collection. Remove weak tables that don't survive
4027 from Vweak_hash_tables. Called from gc_sweep. */
4029 void
4030 sweep_weak_hash_tables (void)
4032 struct Lisp_Hash_Table *h, *used, *next;
4033 int marked;
4035 /* Mark all keys and values that are in use. Keep on marking until
4036 there is no more change. This is necessary for cases like
4037 value-weak table A containing an entry X -> Y, where Y is used in a
4038 key-weak table B, Z -> Y. If B comes after A in the list of weak
4039 tables, X -> Y might be removed from A, although when looking at B
4040 one finds that it shouldn't. */
4043 marked = 0;
4044 for (h = weak_hash_tables; h; h = h->next_weak)
4046 if (h->size & ARRAY_MARK_FLAG)
4047 marked |= sweep_weak_table (h, 0);
4050 while (marked);
4052 /* Remove tables and entries that aren't used. */
4053 for (h = weak_hash_tables, used = NULL; h; h = next)
4055 next = h->next_weak;
4057 if (h->size & ARRAY_MARK_FLAG)
4059 /* TABLE is marked as used. Sweep its contents. */
4060 if (h->count > 0)
4061 sweep_weak_table (h, 1);
4063 /* Add table to the list of used weak hash tables. */
4064 h->next_weak = used;
4065 used = h;
4069 weak_hash_tables = used;
4074 /***********************************************************************
4075 Hash Code Computation
4076 ***********************************************************************/
4078 /* Maximum depth up to which to dive into Lisp structures. */
4080 #define SXHASH_MAX_DEPTH 3
4082 /* Maximum length up to which to take list and vector elements into
4083 account. */
4085 #define SXHASH_MAX_LEN 7
4087 /* Combine two integers X and Y for hashing. */
4089 #define SXHASH_COMBINE(X, Y) \
4090 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4091 + (unsigned)(Y))
4094 /* Return a hash for string PTR which has length LEN. The hash
4095 code returned is guaranteed to fit in a Lisp integer. */
4097 static unsigned
4098 sxhash_string (unsigned char *ptr, int len)
4100 unsigned char *p = ptr;
4101 unsigned char *end = p + len;
4102 unsigned char c;
4103 unsigned hash = 0;
4105 while (p != end)
4107 c = *p++;
4108 if (c >= 0140)
4109 c -= 40;
4110 hash = ((hash << 4) + (hash >> 28) + c);
4113 return hash & INTMASK;
4117 /* Return a hash for list LIST. DEPTH is the current depth in the
4118 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4120 static unsigned
4121 sxhash_list (Lisp_Object list, int depth)
4123 unsigned hash = 0;
4124 int i;
4126 if (depth < SXHASH_MAX_DEPTH)
4127 for (i = 0;
4128 CONSP (list) && i < SXHASH_MAX_LEN;
4129 list = XCDR (list), ++i)
4131 unsigned hash2 = sxhash (XCAR (list), depth + 1);
4132 hash = SXHASH_COMBINE (hash, hash2);
4135 if (!NILP (list))
4137 unsigned hash2 = sxhash (list, depth + 1);
4138 hash = SXHASH_COMBINE (hash, hash2);
4141 return hash;
4145 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4146 the Lisp structure. */
4148 static unsigned
4149 sxhash_vector (Lisp_Object vec, int depth)
4151 unsigned hash = ASIZE (vec);
4152 int i, n;
4154 n = min (SXHASH_MAX_LEN, ASIZE (vec));
4155 for (i = 0; i < n; ++i)
4157 unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
4158 hash = SXHASH_COMBINE (hash, hash2);
4161 return hash;
4165 /* Return a hash for bool-vector VECTOR. */
4167 static unsigned
4168 sxhash_bool_vector (Lisp_Object vec)
4170 unsigned hash = XBOOL_VECTOR (vec)->size;
4171 int i, n;
4173 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
4174 for (i = 0; i < n; ++i)
4175 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
4177 return hash;
4181 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4182 structure. Value is an unsigned integer clipped to INTMASK. */
4184 unsigned
4185 sxhash (Lisp_Object obj, int depth)
4187 unsigned hash;
4189 if (depth > SXHASH_MAX_DEPTH)
4190 return 0;
4192 switch (XTYPE (obj))
4194 case_Lisp_Int:
4195 hash = XUINT (obj);
4196 break;
4198 case Lisp_Misc:
4199 hash = XUINT (obj);
4200 break;
4202 case Lisp_Symbol:
4203 obj = SYMBOL_NAME (obj);
4204 /* Fall through. */
4206 case Lisp_String:
4207 hash = sxhash_string (SDATA (obj), SCHARS (obj));
4208 break;
4210 /* This can be everything from a vector to an overlay. */
4211 case Lisp_Vectorlike:
4212 if (VECTORP (obj))
4213 /* According to the CL HyperSpec, two arrays are equal only if
4214 they are `eq', except for strings and bit-vectors. In
4215 Emacs, this works differently. We have to compare element
4216 by element. */
4217 hash = sxhash_vector (obj, depth);
4218 else if (BOOL_VECTOR_P (obj))
4219 hash = sxhash_bool_vector (obj);
4220 else
4221 /* Others are `equal' if they are `eq', so let's take their
4222 address as hash. */
4223 hash = XUINT (obj);
4224 break;
4226 case Lisp_Cons:
4227 hash = sxhash_list (obj, depth);
4228 break;
4230 case Lisp_Float:
4232 double val = XFLOAT_DATA (obj);
4233 unsigned char *p = (unsigned char *) &val;
4234 unsigned char *e = p + sizeof val;
4235 for (hash = 0; p < e; ++p)
4236 hash = SXHASH_COMBINE (hash, *p);
4237 break;
4240 default:
4241 abort ();
4244 return hash & INTMASK;
4249 /***********************************************************************
4250 Lisp Interface
4251 ***********************************************************************/
4254 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
4255 doc: /* Compute a hash code for OBJ and return it as integer. */)
4256 (Lisp_Object obj)
4258 unsigned hash = sxhash (obj, 0);
4259 return make_number (hash);
4263 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4264 doc: /* Create and return a new hash table.
4266 Arguments are specified as keyword/argument pairs. The following
4267 arguments are defined:
4269 :test TEST -- TEST must be a symbol that specifies how to compare
4270 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4271 `equal'. User-supplied test and hash functions can be specified via
4272 `define-hash-table-test'.
4274 :size SIZE -- A hint as to how many elements will be put in the table.
4275 Default is 65.
4277 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4278 fills up. If REHASH-SIZE is an integer, increase the size by that
4279 amount. If it is a float, it must be > 1.0, and the new size is the
4280 old size multiplied by that factor. Default is 1.5.
4282 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4283 Resize the hash table when the ratio (number of entries / table size)
4284 is greater than or equal to THRESHOLD. Default is 0.8.
4286 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4287 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4288 returned is a weak table. Key/value pairs are removed from a weak
4289 hash table when there are no non-weak references pointing to their
4290 key, value, one of key or value, or both key and value, depending on
4291 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4292 is nil.
4294 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4295 (int nargs, Lisp_Object *args)
4297 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4298 Lisp_Object user_test, user_hash;
4299 char *used;
4300 int i;
4302 /* The vector `used' is used to keep track of arguments that
4303 have been consumed. */
4304 used = (char *) alloca (nargs * sizeof *used);
4305 memset (used, 0, nargs * sizeof *used);
4307 /* See if there's a `:test TEST' among the arguments. */
4308 i = get_key_arg (QCtest, nargs, args, used);
4309 test = i < 0 ? Qeql : args[i];
4310 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
4312 /* See if it is a user-defined test. */
4313 Lisp_Object prop;
4315 prop = Fget (test, Qhash_table_test);
4316 if (!CONSP (prop) || !CONSP (XCDR (prop)))
4317 signal_error ("Invalid hash table test", test);
4318 user_test = XCAR (prop);
4319 user_hash = XCAR (XCDR (prop));
4321 else
4322 user_test = user_hash = Qnil;
4324 /* See if there's a `:size SIZE' argument. */
4325 i = get_key_arg (QCsize, nargs, args, used);
4326 size = i < 0 ? Qnil : args[i];
4327 if (NILP (size))
4328 size = make_number (DEFAULT_HASH_SIZE);
4329 else if (!INTEGERP (size) || XINT (size) < 0)
4330 signal_error ("Invalid hash table size", size);
4332 /* Look for `:rehash-size SIZE'. */
4333 i = get_key_arg (QCrehash_size, nargs, args, used);
4334 rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i];
4335 if (!NUMBERP (rehash_size)
4336 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
4337 || XFLOATINT (rehash_size) <= 1.0)
4338 signal_error ("Invalid hash table rehash size", rehash_size);
4340 /* Look for `:rehash-threshold THRESHOLD'. */
4341 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4342 rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
4343 if (!FLOATP (rehash_threshold)
4344 || XFLOATINT (rehash_threshold) <= 0.0
4345 || XFLOATINT (rehash_threshold) > 1.0)
4346 signal_error ("Invalid hash table rehash threshold", rehash_threshold);
4348 /* Look for `:weakness WEAK'. */
4349 i = get_key_arg (QCweakness, nargs, args, used);
4350 weak = i < 0 ? Qnil : args[i];
4351 if (EQ (weak, Qt))
4352 weak = Qkey_and_value;
4353 if (!NILP (weak)
4354 && !EQ (weak, Qkey)
4355 && !EQ (weak, Qvalue)
4356 && !EQ (weak, Qkey_or_value)
4357 && !EQ (weak, Qkey_and_value))
4358 signal_error ("Invalid hash table weakness", weak);
4360 /* Now, all args should have been used up, or there's a problem. */
4361 for (i = 0; i < nargs; ++i)
4362 if (!used[i])
4363 signal_error ("Invalid argument list", args[i]);
4365 return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
4366 user_test, user_hash);
4370 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4371 doc: /* Return a copy of hash table TABLE. */)
4372 (Lisp_Object table)
4374 return copy_hash_table (check_hash_table (table));
4378 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4379 doc: /* Return the number of elements in TABLE. */)
4380 (Lisp_Object table)
4382 return make_number (check_hash_table (table)->count);
4386 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4387 Shash_table_rehash_size, 1, 1, 0,
4388 doc: /* Return the current rehash size of TABLE. */)
4389 (Lisp_Object table)
4391 return check_hash_table (table)->rehash_size;
4395 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4396 Shash_table_rehash_threshold, 1, 1, 0,
4397 doc: /* Return the current rehash threshold of TABLE. */)
4398 (Lisp_Object table)
4400 return check_hash_table (table)->rehash_threshold;
4404 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4405 doc: /* Return the size of TABLE.
4406 The size can be used as an argument to `make-hash-table' to create
4407 a hash table than can hold as many elements as TABLE holds
4408 without need for resizing. */)
4409 (Lisp_Object table)
4411 struct Lisp_Hash_Table *h = check_hash_table (table);
4412 return make_number (HASH_TABLE_SIZE (h));
4416 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4417 doc: /* Return the test TABLE uses. */)
4418 (Lisp_Object table)
4420 return check_hash_table (table)->test;
4424 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4425 1, 1, 0,
4426 doc: /* Return the weakness of TABLE. */)
4427 (Lisp_Object table)
4429 return check_hash_table (table)->weak;
4433 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4434 doc: /* Return t if OBJ is a Lisp hash table object. */)
4435 (Lisp_Object obj)
4437 return HASH_TABLE_P (obj) ? Qt : Qnil;
4441 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4442 doc: /* Clear hash table TABLE and return it. */)
4443 (Lisp_Object table)
4445 hash_clear (check_hash_table (table));
4446 /* Be compatible with XEmacs. */
4447 return table;
4451 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4452 doc: /* Look up KEY in TABLE and return its associated value.
4453 If KEY is not found, return DFLT which defaults to nil. */)
4454 (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
4456 struct Lisp_Hash_Table *h = check_hash_table (table);
4457 int i = hash_lookup (h, key, NULL);
4458 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4462 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4463 doc: /* Associate KEY with VALUE in hash table TABLE.
4464 If KEY is already present in table, replace its current value with
4465 VALUE. */)
4466 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4468 struct Lisp_Hash_Table *h = check_hash_table (table);
4469 int i;
4470 unsigned hash;
4472 i = hash_lookup (h, key, &hash);
4473 if (i >= 0)
4474 HASH_VALUE (h, i) = value;
4475 else
4476 hash_put (h, key, value, hash);
4478 return value;
4482 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4483 doc: /* Remove KEY from TABLE. */)
4484 (Lisp_Object key, Lisp_Object table)
4486 struct Lisp_Hash_Table *h = check_hash_table (table);
4487 hash_remove_from_table (h, key);
4488 return Qnil;
4492 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4493 doc: /* Call FUNCTION for all entries in hash table TABLE.
4494 FUNCTION is called with two arguments, KEY and VALUE. */)
4495 (Lisp_Object function, Lisp_Object table)
4497 struct Lisp_Hash_Table *h = check_hash_table (table);
4498 Lisp_Object args[3];
4499 int i;
4501 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
4502 if (!NILP (HASH_HASH (h, i)))
4504 args[0] = function;
4505 args[1] = HASH_KEY (h, i);
4506 args[2] = HASH_VALUE (h, i);
4507 Ffuncall (3, args);
4510 return Qnil;
4514 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4515 Sdefine_hash_table_test, 3, 3, 0,
4516 doc: /* Define a new hash table test with name NAME, a symbol.
4518 In hash tables created with NAME specified as test, use TEST to
4519 compare keys, and HASH for computing hash codes of keys.
4521 TEST must be a function taking two arguments and returning non-nil if
4522 both arguments are the same. HASH must be a function taking one
4523 argument and return an integer that is the hash code of the argument.
4524 Hash code computation should use the whole value range of integers,
4525 including negative integers. */)
4526 (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
4528 return Fput (name, Qhash_table_test, list2 (test, hash));
4533 /************************************************************************
4535 ************************************************************************/
4537 #include "md5.h"
4539 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4540 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
4542 A message digest is a cryptographic checksum of a document, and the
4543 algorithm to calculate it is defined in RFC 1321.
4545 The two optional arguments START and END are character positions
4546 specifying for which part of OBJECT the message digest should be
4547 computed. If nil or omitted, the digest is computed for the whole
4548 OBJECT.
4550 The MD5 message digest is computed from the result of encoding the
4551 text in a coding system, not directly from the internal Emacs form of
4552 the text. The optional fourth argument CODING-SYSTEM specifies which
4553 coding system to encode the text with. It should be the same coding
4554 system that you used or will use when actually writing the text into a
4555 file.
4557 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4558 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4559 system would be chosen by default for writing this text into a file.
4561 If OBJECT is a string, the most preferred coding system (see the
4562 command `prefer-coding-system') is used.
4564 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4565 guesswork fails. Normally, an error is signaled in such case. */)
4566 (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
4568 unsigned char digest[16];
4569 unsigned char value[33];
4570 int i;
4571 EMACS_INT size;
4572 EMACS_INT size_byte = 0;
4573 EMACS_INT start_char = 0, end_char = 0;
4574 EMACS_INT start_byte = 0, end_byte = 0;
4575 register EMACS_INT b, e;
4576 register struct buffer *bp;
4577 EMACS_INT temp;
4579 if (STRINGP (object))
4581 if (NILP (coding_system))
4583 /* Decide the coding-system to encode the data with. */
4585 if (STRING_MULTIBYTE (object))
4586 /* use default, we can't guess correct value */
4587 coding_system = preferred_coding_system ();
4588 else
4589 coding_system = Qraw_text;
4592 if (NILP (Fcoding_system_p (coding_system)))
4594 /* Invalid coding system. */
4596 if (!NILP (noerror))
4597 coding_system = Qraw_text;
4598 else
4599 xsignal1 (Qcoding_system_error, coding_system);
4602 if (STRING_MULTIBYTE (object))
4603 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4605 size = SCHARS (object);
4606 size_byte = SBYTES (object);
4608 if (!NILP (start))
4610 CHECK_NUMBER (start);
4612 start_char = XINT (start);
4614 if (start_char < 0)
4615 start_char += size;
4617 start_byte = string_char_to_byte (object, start_char);
4620 if (NILP (end))
4622 end_char = size;
4623 end_byte = size_byte;
4625 else
4627 CHECK_NUMBER (end);
4629 end_char = XINT (end);
4631 if (end_char < 0)
4632 end_char += size;
4634 end_byte = string_char_to_byte (object, end_char);
4637 if (!(0 <= start_char && start_char <= end_char && end_char <= size))
4638 args_out_of_range_3 (object, make_number (start_char),
4639 make_number (end_char));
4641 else
4643 struct buffer *prev = current_buffer;
4645 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4647 CHECK_BUFFER (object);
4649 bp = XBUFFER (object);
4650 if (bp != current_buffer)
4651 set_buffer_internal (bp);
4653 if (NILP (start))
4654 b = BEGV;
4655 else
4657 CHECK_NUMBER_COERCE_MARKER (start);
4658 b = XINT (start);
4661 if (NILP (end))
4662 e = ZV;
4663 else
4665 CHECK_NUMBER_COERCE_MARKER (end);
4666 e = XINT (end);
4669 if (b > e)
4670 temp = b, b = e, e = temp;
4672 if (!(BEGV <= b && e <= ZV))
4673 args_out_of_range (start, end);
4675 if (NILP (coding_system))
4677 /* Decide the coding-system to encode the data with.
4678 See fileio.c:Fwrite-region */
4680 if (!NILP (Vcoding_system_for_write))
4681 coding_system = Vcoding_system_for_write;
4682 else
4684 int force_raw_text = 0;
4686 coding_system = XBUFFER (object)->buffer_file_coding_system;
4687 if (NILP (coding_system)
4688 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4690 coding_system = Qnil;
4691 if (NILP (current_buffer->enable_multibyte_characters))
4692 force_raw_text = 1;
4695 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
4697 /* Check file-coding-system-alist. */
4698 Lisp_Object args[4], val;
4700 args[0] = Qwrite_region; args[1] = start; args[2] = end;
4701 args[3] = Fbuffer_file_name(object);
4702 val = Ffind_operation_coding_system (4, args);
4703 if (CONSP (val) && !NILP (XCDR (val)))
4704 coding_system = XCDR (val);
4707 if (NILP (coding_system)
4708 && !NILP (XBUFFER (object)->buffer_file_coding_system))
4710 /* If we still have not decided a coding system, use the
4711 default value of buffer-file-coding-system. */
4712 coding_system = XBUFFER (object)->buffer_file_coding_system;
4715 if (!force_raw_text
4716 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4717 /* Confirm that VAL can surely encode the current region. */
4718 coding_system = call4 (Vselect_safe_coding_system_function,
4719 make_number (b), make_number (e),
4720 coding_system, Qnil);
4722 if (force_raw_text)
4723 coding_system = Qraw_text;
4726 if (NILP (Fcoding_system_p (coding_system)))
4728 /* Invalid coding system. */
4730 if (!NILP (noerror))
4731 coding_system = Qraw_text;
4732 else
4733 xsignal1 (Qcoding_system_error, coding_system);
4737 object = make_buffer_string (b, e, 0);
4738 if (prev != current_buffer)
4739 set_buffer_internal (prev);
4740 /* Discard the unwind protect for recovering the current
4741 buffer. */
4742 specpdl_ptr--;
4744 if (STRING_MULTIBYTE (object))
4745 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
4748 md5_buffer (SSDATA (object) + start_byte,
4749 SBYTES (object) - (size_byte - end_byte),
4750 digest);
4752 for (i = 0; i < 16; i++)
4753 sprintf (&value[2 * i], "%02x", digest[i]);
4754 value[32] = '\0';
4756 return make_string (value, 32);
4760 void
4761 syms_of_fns (void)
4763 /* Hash table stuff. */
4764 Qhash_table_p = intern_c_string ("hash-table-p");
4765 staticpro (&Qhash_table_p);
4766 Qeq = intern_c_string ("eq");
4767 staticpro (&Qeq);
4768 Qeql = intern_c_string ("eql");
4769 staticpro (&Qeql);
4770 Qequal = intern_c_string ("equal");
4771 staticpro (&Qequal);
4772 QCtest = intern_c_string (":test");
4773 staticpro (&QCtest);
4774 QCsize = intern_c_string (":size");
4775 staticpro (&QCsize);
4776 QCrehash_size = intern_c_string (":rehash-size");
4777 staticpro (&QCrehash_size);
4778 QCrehash_threshold = intern_c_string (":rehash-threshold");
4779 staticpro (&QCrehash_threshold);
4780 QCweakness = intern_c_string (":weakness");
4781 staticpro (&QCweakness);
4782 Qkey = intern_c_string ("key");
4783 staticpro (&Qkey);
4784 Qvalue = intern_c_string ("value");
4785 staticpro (&Qvalue);
4786 Qhash_table_test = intern_c_string ("hash-table-test");
4787 staticpro (&Qhash_table_test);
4788 Qkey_or_value = intern_c_string ("key-or-value");
4789 staticpro (&Qkey_or_value);
4790 Qkey_and_value = intern_c_string ("key-and-value");
4791 staticpro (&Qkey_and_value);
4793 defsubr (&Ssxhash);
4794 defsubr (&Smake_hash_table);
4795 defsubr (&Scopy_hash_table);
4796 defsubr (&Shash_table_count);
4797 defsubr (&Shash_table_rehash_size);
4798 defsubr (&Shash_table_rehash_threshold);
4799 defsubr (&Shash_table_size);
4800 defsubr (&Shash_table_test);
4801 defsubr (&Shash_table_weakness);
4802 defsubr (&Shash_table_p);
4803 defsubr (&Sclrhash);
4804 defsubr (&Sgethash);
4805 defsubr (&Sputhash);
4806 defsubr (&Sremhash);
4807 defsubr (&Smaphash);
4808 defsubr (&Sdefine_hash_table_test);
4810 Qstring_lessp = intern_c_string ("string-lessp");
4811 staticpro (&Qstring_lessp);
4812 Qprovide = intern_c_string ("provide");
4813 staticpro (&Qprovide);
4814 Qrequire = intern_c_string ("require");
4815 staticpro (&Qrequire);
4816 Qyes_or_no_p_history = intern_c_string ("yes-or-no-p-history");
4817 staticpro (&Qyes_or_no_p_history);
4818 Qcursor_in_echo_area = intern_c_string ("cursor-in-echo-area");
4819 staticpro (&Qcursor_in_echo_area);
4820 Qwidget_type = intern_c_string ("widget-type");
4821 staticpro (&Qwidget_type);
4823 staticpro (&string_char_byte_cache_string);
4824 string_char_byte_cache_string = Qnil;
4826 require_nesting_list = Qnil;
4827 staticpro (&require_nesting_list);
4829 Fset (Qyes_or_no_p_history, Qnil);
4831 DEFVAR_LISP ("features", Vfeatures,
4832 doc: /* A list of symbols which are the features of the executing Emacs.
4833 Used by `featurep' and `require', and altered by `provide'. */);
4834 Vfeatures = Fcons (intern_c_string ("emacs"), Qnil);
4835 Qsubfeatures = intern_c_string ("subfeatures");
4836 staticpro (&Qsubfeatures);
4838 #ifdef HAVE_LANGINFO_CODESET
4839 Qcodeset = intern_c_string ("codeset");
4840 staticpro (&Qcodeset);
4841 Qdays = intern_c_string ("days");
4842 staticpro (&Qdays);
4843 Qmonths = intern_c_string ("months");
4844 staticpro (&Qmonths);
4845 Qpaper = intern_c_string ("paper");
4846 staticpro (&Qpaper);
4847 #endif /* HAVE_LANGINFO_CODESET */
4849 DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
4850 doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4851 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4852 invoked by mouse clicks and mouse menu items.
4854 On some platforms, file selection dialogs are also enabled if this is
4855 non-nil. */);
4856 use_dialog_box = 1;
4858 DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
4859 doc: /* *Non-nil means mouse commands use a file dialog to ask for files.
4860 This applies to commands from menus and tool bar buttons even when
4861 they are initiated from the keyboard. If `use-dialog-box' is nil,
4862 that disables the use of a file dialog, regardless of the value of
4863 this variable. */);
4864 use_file_dialog = 1;
4866 defsubr (&Sidentity);
4867 defsubr (&Srandom);
4868 defsubr (&Slength);
4869 defsubr (&Ssafe_length);
4870 defsubr (&Sstring_bytes);
4871 defsubr (&Sstring_equal);
4872 defsubr (&Scompare_strings);
4873 defsubr (&Sstring_lessp);
4874 defsubr (&Sappend);
4875 defsubr (&Sconcat);
4876 defsubr (&Svconcat);
4877 defsubr (&Scopy_sequence);
4878 defsubr (&Sstring_make_multibyte);
4879 defsubr (&Sstring_make_unibyte);
4880 defsubr (&Sstring_as_multibyte);
4881 defsubr (&Sstring_as_unibyte);
4882 defsubr (&Sstring_to_multibyte);
4883 defsubr (&Sstring_to_unibyte);
4884 defsubr (&Scopy_alist);
4885 defsubr (&Ssubstring);
4886 defsubr (&Ssubstring_no_properties);
4887 defsubr (&Snthcdr);
4888 defsubr (&Snth);
4889 defsubr (&Selt);
4890 defsubr (&Smember);
4891 defsubr (&Smemq);
4892 defsubr (&Smemql);
4893 defsubr (&Sassq);
4894 defsubr (&Sassoc);
4895 defsubr (&Srassq);
4896 defsubr (&Srassoc);
4897 defsubr (&Sdelq);
4898 defsubr (&Sdelete);
4899 defsubr (&Snreverse);
4900 defsubr (&Sreverse);
4901 defsubr (&Ssort);
4902 defsubr (&Splist_get);
4903 defsubr (&Sget);
4904 defsubr (&Splist_put);
4905 defsubr (&Sput);
4906 defsubr (&Slax_plist_get);
4907 defsubr (&Slax_plist_put);
4908 defsubr (&Seql);
4909 defsubr (&Sequal);
4910 defsubr (&Sequal_including_properties);
4911 defsubr (&Sfillarray);
4912 defsubr (&Sclear_string);
4913 defsubr (&Snconc);
4914 defsubr (&Smapcar);
4915 defsubr (&Smapc);
4916 defsubr (&Smapconcat);
4917 defsubr (&Syes_or_no_p);
4918 defsubr (&Sload_average);
4919 defsubr (&Sfeaturep);
4920 defsubr (&Srequire);
4921 defsubr (&Sprovide);
4922 defsubr (&Splist_member);
4923 defsubr (&Swidget_put);
4924 defsubr (&Swidget_get);
4925 defsubr (&Swidget_apply);
4926 defsubr (&Sbase64_encode_region);
4927 defsubr (&Sbase64_decode_region);
4928 defsubr (&Sbase64_encode_string);
4929 defsubr (&Sbase64_decode_string);
4930 defsubr (&Smd5);
4931 defsubr (&Slocale_info);
4935 void
4936 init_fns (void)