(Info-unescape-quotes, Info-split-parameter-string)
[emacs.git] / src / fns.c
blobfed948dc29f4c879e2cfede26a372574d7273966
1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #include <config.h>
24 #ifdef HAVE_UNISTD_H
25 #include <unistd.h>
26 #endif
27 #include <time.h>
29 #ifndef MAC_OSX
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
34 #undef vector
35 #define vector *****
37 #endif /* ! MAC_OSX */
39 #include "lisp.h"
40 #include "commands.h"
41 #include "charset.h"
42 #include "coding.h"
43 #include "buffer.h"
44 #include "keyboard.h"
45 #include "keymap.h"
46 #include "intervals.h"
47 #include "frame.h"
48 #include "window.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
51 #include "xterm.h"
52 #endif
54 #ifndef NULL
55 #define NULL ((POINTER_TYPE *)0)
56 #endif
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
60 int use_dialog_box;
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
64 int use_file_dialog;
66 extern int minibuffer_auto_raise;
67 extern Lisp_Object minibuf_window;
68 extern Lisp_Object Vlocale_coding_system;
70 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
71 Lisp_Object Qyes_or_no_p_history;
72 Lisp_Object Qcursor_in_echo_area;
73 Lisp_Object Qwidget_type;
74 Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
76 extern Lisp_Object Qinput_method_function;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
83 #ifndef HAVE_UNISTD_H
84 extern long time ();
85 #endif
87 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
88 doc: /* Return the argument unchanged. */)
89 (arg)
90 Lisp_Object arg;
92 return arg;
95 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
96 doc: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 28 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
102 Lisp_Object n;
104 EMACS_INT val;
105 Lisp_Object lispy_val;
106 unsigned long denominator;
108 if (EQ (n, Qt))
109 seed_random (getpid () + time (NULL));
110 if (NATNUMP (n) && XFASTINT (n) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
121 val = get_random () / denominator;
122 while (val >= XFASTINT (n));
124 else
125 val = get_random ();
126 XSETINT (lispy_val, val);
127 return lispy_val;
130 /* Random data-structure functions */
132 DEFUN ("length", Flength, Slength, 1, 1, 0,
133 doc: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
138 (sequence)
139 register Lisp_Object sequence;
141 register Lisp_Object val;
142 register int i;
144 retry:
145 if (STRINGP (sequence))
146 XSETFASTINT (val, SCHARS (sequence));
147 else if (VECTORP (sequence))
148 XSETFASTINT (val, XVECTOR (sequence)->size);
149 else if (SUB_CHAR_TABLE_P (sequence))
150 XSETFASTINT (val, SUB_CHAR_TABLE_ORDINARY_SLOTS);
151 else if (CHAR_TABLE_P (sequence))
152 XSETFASTINT (val, MAX_CHAR);
153 else if (BOOL_VECTOR_P (sequence))
154 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
155 else if (COMPILEDP (sequence))
156 XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
157 else if (CONSP (sequence))
159 i = 0;
160 while (CONSP (sequence))
162 sequence = XCDR (sequence);
163 ++i;
165 if (!CONSP (sequence))
166 break;
168 sequence = XCDR (sequence);
169 ++i;
170 QUIT;
173 if (!NILP (sequence))
174 wrong_type_argument (Qlistp, sequence);
176 val = make_number (i);
178 else if (NILP (sequence))
179 XSETFASTINT (val, 0);
180 else
182 sequence = wrong_type_argument (Qsequencep, sequence);
183 goto retry;
185 return val;
188 /* This does not check for quits. That is safe
189 since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
192 doc: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
196 (list)
197 Lisp_Object list;
199 Lisp_Object tail, halftail, length;
200 int len = 0;
202 /* halftail is used to detect circular lists. */
203 halftail = list;
204 for (tail = list; CONSP (tail); tail = XCDR (tail))
206 if (EQ (tail, halftail) && len != 0)
207 break;
208 len++;
209 if ((len & 1) == 0)
210 halftail = XCDR (halftail);
213 XSETINT (length, len);
214 return length;
217 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
218 doc: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
220 (string)
221 Lisp_Object string;
223 CHECK_STRING (string);
224 return make_number (SBYTES (string));
227 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
228 doc: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
231 (s1, s2)
232 register Lisp_Object s1, s2;
234 if (SYMBOLP (s1))
235 s1 = SYMBOL_NAME (s1);
236 if (SYMBOLP (s2))
237 s2 = SYMBOL_NAME (s2);
238 CHECK_STRING (s1);
239 CHECK_STRING (s2);
241 if (SCHARS (s1) != SCHARS (s2)
242 || SBYTES (s1) != SBYTES (s2)
243 || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
244 return Qnil;
245 return Qt;
248 DEFUN ("compare-strings", Fcompare_strings,
249 Scompare_strings, 6, 7, 0,
250 doc: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1, start1, end1, str2, start2, end2, ignore_case)
264 Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
266 register int end1_char, end2_char;
267 register int i1, i1_byte, i2, i2_byte;
269 CHECK_STRING (str1);
270 CHECK_STRING (str2);
271 if (NILP (start1))
272 start1 = make_number (0);
273 if (NILP (start2))
274 start2 = make_number (0);
275 CHECK_NATNUM (start1);
276 CHECK_NATNUM (start2);
277 if (! NILP (end1))
278 CHECK_NATNUM (end1);
279 if (! NILP (end2))
280 CHECK_NATNUM (end2);
282 i1 = XINT (start1);
283 i2 = XINT (start2);
285 i1_byte = string_char_to_byte (str1, i1);
286 i2_byte = string_char_to_byte (str2, i2);
288 end1_char = SCHARS (str1);
289 if (! NILP (end1) && end1_char > XINT (end1))
290 end1_char = XINT (end1);
292 end2_char = SCHARS (str2);
293 if (! NILP (end2) && end2_char > XINT (end2))
294 end2_char = XINT (end2);
296 while (i1 < end1_char && i2 < end2_char)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
300 int c1, c2;
302 if (STRING_MULTIBYTE (str1))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
304 else
306 c1 = SREF (str1, i1++);
307 c1 = unibyte_char_to_multibyte (c1);
310 if (STRING_MULTIBYTE (str2))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
312 else
314 c2 = SREF (str2, i2++);
315 c2 = unibyte_char_to_multibyte (c2);
318 if (c1 == c2)
319 continue;
321 if (! NILP (ignore_case))
323 Lisp_Object tem;
325 tem = Fupcase (make_number (c1));
326 c1 = XINT (tem);
327 tem = Fupcase (make_number (c2));
328 c2 = XINT (tem);
331 if (c1 == c2)
332 continue;
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
337 if (c1 < c2)
338 return make_number (- i1 + XINT (start1));
339 else
340 return make_number (i1 - XINT (start1));
343 if (i1 < end1_char)
344 return make_number (i1 - XINT (start1) + 1);
345 if (i2 < end2_char)
346 return make_number (- i1 + XINT (start1) - 1);
348 return Qt;
351 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
352 doc: /* Return t if first arg string is less than second in lexicographic order.
353 Case is significant.
354 Symbols are also allowed; their print names are used instead. */)
355 (s1, s2)
356 register Lisp_Object s1, s2;
358 register int end;
359 register int i1, i1_byte, i2, i2_byte;
361 if (SYMBOLP (s1))
362 s1 = SYMBOL_NAME (s1);
363 if (SYMBOLP (s2))
364 s2 = SYMBOL_NAME (s2);
365 CHECK_STRING (s1);
366 CHECK_STRING (s2);
368 i1 = i1_byte = i2 = i2_byte = 0;
370 end = SCHARS (s1);
371 if (end > SCHARS (s2))
372 end = SCHARS (s2);
374 while (i1 < end)
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
378 int c1, c2;
380 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
381 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
383 if (c1 != c2)
384 return c1 < c2 ? Qt : Qnil;
386 return i1 < SCHARS (s2) ? Qt : Qnil;
389 static Lisp_Object concat ();
391 /* ARGSUSED */
392 Lisp_Object
393 concat2 (s1, s2)
394 Lisp_Object s1, s2;
396 #ifdef NO_ARG_ARRAY
397 Lisp_Object args[2];
398 args[0] = s1;
399 args[1] = s2;
400 return concat (2, args, Lisp_String, 0);
401 #else
402 return concat (2, &s1, Lisp_String, 0);
403 #endif /* NO_ARG_ARRAY */
406 /* ARGSUSED */
407 Lisp_Object
408 concat3 (s1, s2, s3)
409 Lisp_Object s1, s2, s3;
411 #ifdef NO_ARG_ARRAY
412 Lisp_Object args[3];
413 args[0] = s1;
414 args[1] = s2;
415 args[2] = s3;
416 return concat (3, args, Lisp_String, 0);
417 #else
418 return concat (3, &s1, Lisp_String, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
423 doc: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
428 (nargs, args)
429 int nargs;
430 Lisp_Object *args;
432 return concat (nargs, args, Lisp_Cons, 1);
435 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
436 doc: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
440 (nargs, args)
441 int nargs;
442 Lisp_Object *args;
444 return concat (nargs, args, Lisp_String, 0);
447 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
448 doc: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
452 (nargs, args)
453 int nargs;
454 Lisp_Object *args;
456 return concat (nargs, args, Lisp_Vectorlike, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
461 static Lisp_Object
462 copy_sub_char_table (arg)
463 Lisp_Object arg;
465 Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
466 int i;
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
474 XCHAR_TABLE (copy)->contents[i]
475 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
477 return copy;
481 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
482 doc: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
485 (arg)
486 Lisp_Object arg;
488 if (NILP (arg)) return arg;
490 if (CHAR_TABLE_P (arg))
492 int i;
493 Lisp_Object copy;
495 copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
498 ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
499 * sizeof (Lisp_Object)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
504 i < CHAR_TABLE_ORDINARY_SLOTS; i++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
506 XCHAR_TABLE (copy)->contents[i]
507 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
509 return copy;
512 if (BOOL_VECTOR_P (arg))
514 Lisp_Object val;
515 int size_in_chars
516 = (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
518 val = Fmake_bool_vector (Flength (arg), Qnil);
519 bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
520 size_in_chars);
521 return val;
524 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
525 arg = wrong_type_argument (Qsequencep, arg);
526 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
529 /* In string STR of length LEN, see if bytes before STR[I] combine
530 with bytes after STR[I] to form a single character. If so, return
531 the number of bytes after STR[I] which combine in this way.
532 Otherwize, return 0. */
534 static int
535 count_combining (str, len, i)
536 unsigned char *str;
537 int len, i;
539 int j = i - 1, bytes;
541 if (i == 0 || i == len || CHAR_HEAD_P (str[i]))
542 return 0;
543 while (j >= 0 && !CHAR_HEAD_P (str[j])) j--;
544 if (j < 0 || ! BASE_LEADING_CODE_P (str[j]))
545 return 0;
546 PARSE_MULTIBYTE_SEQ (str + j, len - j, bytes);
547 return (bytes <= i - j ? 0 : bytes - (i - j));
550 /* This structure holds information of an argument of `concat' that is
551 a string and has text properties to be copied. */
552 struct textprop_rec
554 int argnum; /* refer to ARGS (arguments of `concat') */
555 int from; /* refer to ARGS[argnum] (argument string) */
556 int to; /* refer to VAL (the target string) */
559 static Lisp_Object
560 concat (nargs, args, target_type, last_special)
561 int nargs;
562 Lisp_Object *args;
563 enum Lisp_Type target_type;
564 int last_special;
566 Lisp_Object val;
567 register Lisp_Object tail;
568 register Lisp_Object this;
569 int toindex;
570 int toindex_byte = 0;
571 register int result_len;
572 register int result_len_byte;
573 register int argnum;
574 Lisp_Object last_tail;
575 Lisp_Object prev;
576 int some_multibyte;
577 /* When we make a multibyte string, we can't copy text properties
578 while concatinating each string because the length of resulting
579 string can't be decided until we finish the whole concatination.
580 So, we record strings that have text properties to be copied
581 here, and copy the text properties after the concatination. */
582 struct textprop_rec *textprops = NULL;
583 /* Number of elments in textprops. */
584 int num_textprops = 0;
586 tail = Qnil;
588 /* In append, the last arg isn't treated like the others */
589 if (last_special && nargs > 0)
591 nargs--;
592 last_tail = args[nargs];
594 else
595 last_tail = Qnil;
597 /* Canonicalize each argument. */
598 for (argnum = 0; argnum < nargs; argnum++)
600 this = args[argnum];
601 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
602 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
604 args[argnum] = wrong_type_argument (Qsequencep, this);
608 /* Compute total length in chars of arguments in RESULT_LEN.
609 If desired output is a string, also compute length in bytes
610 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
611 whether the result should be a multibyte string. */
612 result_len_byte = 0;
613 result_len = 0;
614 some_multibyte = 0;
615 for (argnum = 0; argnum < nargs; argnum++)
617 int len;
618 this = args[argnum];
619 len = XFASTINT (Flength (this));
620 if (target_type == Lisp_String)
622 /* We must count the number of bytes needed in the string
623 as well as the number of characters. */
624 int i;
625 Lisp_Object ch;
626 int this_len_byte;
628 if (VECTORP (this))
629 for (i = 0; i < len; i++)
631 ch = XVECTOR (this)->contents[i];
632 if (! INTEGERP (ch))
633 wrong_type_argument (Qintegerp, ch);
634 this_len_byte = CHAR_BYTES (XINT (ch));
635 result_len_byte += this_len_byte;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
637 some_multibyte = 1;
639 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
640 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
641 else if (CONSP (this))
642 for (; CONSP (this); this = XCDR (this))
644 ch = XCAR (this);
645 if (! INTEGERP (ch))
646 wrong_type_argument (Qintegerp, ch);
647 this_len_byte = CHAR_BYTES (XINT (ch));
648 result_len_byte += this_len_byte;
649 if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
650 some_multibyte = 1;
652 else if (STRINGP (this))
654 if (STRING_MULTIBYTE (this))
656 some_multibyte = 1;
657 result_len_byte += SBYTES (this);
659 else
660 result_len_byte += count_size_as_multibyte (SDATA (this),
661 SCHARS (this));
665 result_len += len;
668 if (! some_multibyte)
669 result_len_byte = result_len;
671 /* Create the output object. */
672 if (target_type == Lisp_Cons)
673 val = Fmake_list (make_number (result_len), Qnil);
674 else if (target_type == Lisp_Vectorlike)
675 val = Fmake_vector (make_number (result_len), Qnil);
676 else if (some_multibyte)
677 val = make_uninit_multibyte_string (result_len, result_len_byte);
678 else
679 val = make_uninit_string (result_len);
681 /* In `append', if all but last arg are nil, return last arg. */
682 if (target_type == Lisp_Cons && EQ (val, Qnil))
683 return last_tail;
685 /* Copy the contents of the args into the result. */
686 if (CONSP (val))
687 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
688 else
689 toindex = 0, toindex_byte = 0;
691 prev = Qnil;
692 if (STRINGP (val))
693 textprops
694 = (struct textprop_rec *) alloca (sizeof (struct textprop_rec) * nargs);
696 for (argnum = 0; argnum < nargs; argnum++)
698 Lisp_Object thislen;
699 int thisleni = 0;
700 register unsigned int thisindex = 0;
701 register unsigned int thisindex_byte = 0;
703 this = args[argnum];
704 if (!CONSP (this))
705 thislen = Flength (this), thisleni = XINT (thislen);
707 /* Between strings of the same kind, copy fast. */
708 if (STRINGP (this) && STRINGP (val)
709 && STRING_MULTIBYTE (this) == some_multibyte)
711 int thislen_byte = SBYTES (this);
712 int combined;
714 bcopy (SDATA (this), SDATA (val) + toindex_byte,
715 SBYTES (this));
716 combined = (some_multibyte && toindex_byte > 0
717 ? count_combining (SDATA (val),
718 toindex_byte + thislen_byte,
719 toindex_byte)
720 : 0);
721 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
723 textprops[num_textprops].argnum = argnum;
724 /* We ignore text properties on characters being combined. */
725 textprops[num_textprops].from = combined;
726 textprops[num_textprops++].to = toindex;
728 toindex_byte += thislen_byte;
729 toindex += thisleni - combined;
730 STRING_SET_CHARS (val, SCHARS (val) - combined);
732 /* Copy a single-byte string to a multibyte string. */
733 else if (STRINGP (this) && STRINGP (val))
735 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
737 textprops[num_textprops].argnum = argnum;
738 textprops[num_textprops].from = 0;
739 textprops[num_textprops++].to = toindex;
741 toindex_byte += copy_text (SDATA (this),
742 SDATA (val) + toindex_byte,
743 SCHARS (this), 0, 1);
744 toindex += thisleni;
746 else
747 /* Copy element by element. */
748 while (1)
750 register Lisp_Object elt;
752 /* Fetch next element of `this' arg into `elt', or break if
753 `this' is exhausted. */
754 if (NILP (this)) break;
755 if (CONSP (this))
756 elt = XCAR (this), this = XCDR (this);
757 else if (thisindex >= thisleni)
758 break;
759 else if (STRINGP (this))
761 int c;
762 if (STRING_MULTIBYTE (this))
764 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
765 thisindex,
766 thisindex_byte);
767 XSETFASTINT (elt, c);
769 else
771 XSETFASTINT (elt, SREF (this, thisindex++));
772 if (some_multibyte
773 && (XINT (elt) >= 0240
774 || (XINT (elt) >= 0200
775 && ! NILP (Vnonascii_translation_table)))
776 && XINT (elt) < 0400)
778 c = unibyte_char_to_multibyte (XINT (elt));
779 XSETINT (elt, c);
783 else if (BOOL_VECTOR_P (this))
785 int byte;
786 byte = XBOOL_VECTOR (this)->data[thisindex / BITS_PER_CHAR];
787 if (byte & (1 << (thisindex % BITS_PER_CHAR)))
788 elt = Qt;
789 else
790 elt = Qnil;
791 thisindex++;
793 else
794 elt = XVECTOR (this)->contents[thisindex++];
796 /* Store this element into the result. */
797 if (toindex < 0)
799 XSETCAR (tail, elt);
800 prev = tail;
801 tail = XCDR (tail);
803 else if (VECTORP (val))
804 XVECTOR (val)->contents[toindex++] = elt;
805 else
807 CHECK_NUMBER (elt);
808 if (SINGLE_BYTE_CHAR_P (XINT (elt)))
810 if (some_multibyte)
811 toindex_byte
812 += CHAR_STRING (XINT (elt),
813 SDATA (val) + toindex_byte);
814 else
815 SSET (val, toindex_byte++, XINT (elt));
816 if (some_multibyte
817 && toindex_byte > 0
818 && count_combining (SDATA (val),
819 toindex_byte, toindex_byte - 1))
820 STRING_SET_CHARS (val, SCHARS (val) - 1);
821 else
822 toindex++;
824 else
825 /* If we have any multibyte characters,
826 we already decided to make a multibyte string. */
828 int c = XINT (elt);
829 /* P exists as a variable
830 to avoid a bug on the Masscomp C compiler. */
831 unsigned char *p = SDATA (val) + toindex_byte;
833 toindex_byte += CHAR_STRING (c, p);
834 toindex++;
839 if (!NILP (prev))
840 XSETCDR (prev, last_tail);
842 if (num_textprops > 0)
844 Lisp_Object props;
845 int last_to_end = -1;
847 for (argnum = 0; argnum < num_textprops; argnum++)
849 this = args[textprops[argnum].argnum];
850 props = text_property_list (this,
851 make_number (0),
852 make_number (SCHARS (this)),
853 Qnil);
854 /* If successive arguments have properites, be sure that the
855 value of `composition' property be the copy. */
856 if (last_to_end == textprops[argnum].to)
857 make_composition_value_copy (props);
858 add_text_properties_from_list (val, props,
859 make_number (textprops[argnum].to));
860 last_to_end = textprops[argnum].to + SCHARS (this);
863 return val;
866 static Lisp_Object string_char_byte_cache_string;
867 static int string_char_byte_cache_charpos;
868 static int string_char_byte_cache_bytepos;
870 void
871 clear_string_char_byte_cache ()
873 string_char_byte_cache_string = Qnil;
876 /* Return the character index corresponding to CHAR_INDEX in STRING. */
879 string_char_to_byte (string, char_index)
880 Lisp_Object string;
881 int char_index;
883 int i, i_byte;
884 int best_below, best_below_byte;
885 int best_above, best_above_byte;
887 if (! STRING_MULTIBYTE (string))
888 return char_index;
890 best_below = best_below_byte = 0;
891 best_above = SCHARS (string);
892 best_above_byte = SBYTES (string);
894 if (EQ (string, string_char_byte_cache_string))
896 if (string_char_byte_cache_charpos < char_index)
898 best_below = string_char_byte_cache_charpos;
899 best_below_byte = string_char_byte_cache_bytepos;
901 else
903 best_above = string_char_byte_cache_charpos;
904 best_above_byte = string_char_byte_cache_bytepos;
908 if (char_index - best_below < best_above - char_index)
910 while (best_below < char_index)
912 int c;
913 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
914 best_below, best_below_byte);
916 i = best_below;
917 i_byte = best_below_byte;
919 else
921 while (best_above > char_index)
923 unsigned char *pend = SDATA (string) + best_above_byte;
924 unsigned char *pbeg = pend - best_above_byte;
925 unsigned char *p = pend - 1;
926 int bytes;
928 while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
929 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
930 if (bytes == pend - p)
931 best_above_byte -= bytes;
932 else if (bytes > pend - p)
933 best_above_byte -= (pend - p);
934 else
935 best_above_byte--;
936 best_above--;
938 i = best_above;
939 i_byte = best_above_byte;
942 string_char_byte_cache_bytepos = i_byte;
943 string_char_byte_cache_charpos = i;
944 string_char_byte_cache_string = string;
946 return i_byte;
949 /* Return the character index corresponding to BYTE_INDEX in STRING. */
952 string_byte_to_char (string, byte_index)
953 Lisp_Object string;
954 int byte_index;
956 int i, i_byte;
957 int best_below, best_below_byte;
958 int best_above, best_above_byte;
960 if (! STRING_MULTIBYTE (string))
961 return byte_index;
963 best_below = best_below_byte = 0;
964 best_above = SCHARS (string);
965 best_above_byte = SBYTES (string);
967 if (EQ (string, string_char_byte_cache_string))
969 if (string_char_byte_cache_bytepos < byte_index)
971 best_below = string_char_byte_cache_charpos;
972 best_below_byte = string_char_byte_cache_bytepos;
974 else
976 best_above = string_char_byte_cache_charpos;
977 best_above_byte = string_char_byte_cache_bytepos;
981 if (byte_index - best_below_byte < best_above_byte - byte_index)
983 while (best_below_byte < byte_index)
985 int c;
986 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
987 best_below, best_below_byte);
989 i = best_below;
990 i_byte = best_below_byte;
992 else
994 while (best_above_byte > byte_index)
996 unsigned char *pend = SDATA (string) + best_above_byte;
997 unsigned char *pbeg = pend - best_above_byte;
998 unsigned char *p = pend - 1;
999 int bytes;
1001 while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
1002 PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
1003 if (bytes == pend - p)
1004 best_above_byte -= bytes;
1005 else if (bytes > pend - p)
1006 best_above_byte -= (pend - p);
1007 else
1008 best_above_byte--;
1009 best_above--;
1011 i = best_above;
1012 i_byte = best_above_byte;
1015 string_char_byte_cache_bytepos = i_byte;
1016 string_char_byte_cache_charpos = i;
1017 string_char_byte_cache_string = string;
1019 return i;
1022 /* Convert STRING to a multibyte string.
1023 Single-byte characters 0240 through 0377 are converted
1024 by adding nonascii_insert_offset to each. */
1026 Lisp_Object
1027 string_make_multibyte (string)
1028 Lisp_Object string;
1030 unsigned char *buf;
1031 int nbytes;
1033 if (STRING_MULTIBYTE (string))
1034 return string;
1036 nbytes = count_size_as_multibyte (SDATA (string),
1037 SCHARS (string));
1038 /* If all the chars are ASCII, they won't need any more bytes
1039 once converted. In that case, we can return STRING itself. */
1040 if (nbytes == SBYTES (string))
1041 return string;
1043 buf = (unsigned char *) alloca (nbytes);
1044 copy_text (SDATA (string), buf, SBYTES (string),
1045 0, 1);
1047 return make_multibyte_string (buf, SCHARS (string), nbytes);
1051 /* Convert STRING to a multibyte string without changing each
1052 character codes. Thus, characters 0200 trough 0237 are converted
1053 to eight-bit-control characters, and characters 0240 through 0377
1054 are converted eight-bit-graphic characters. */
1056 Lisp_Object
1057 string_to_multibyte (string)
1058 Lisp_Object string;
1060 unsigned char *buf;
1061 int nbytes;
1063 if (STRING_MULTIBYTE (string))
1064 return string;
1066 nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
1067 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1068 any more bytes once converted. */
1069 if (nbytes == SBYTES (string))
1070 return make_multibyte_string (SDATA (string), nbytes, nbytes);
1072 buf = (unsigned char *) alloca (nbytes);
1073 bcopy (SDATA (string), buf, SBYTES (string));
1074 str_to_multibyte (buf, nbytes, SBYTES (string));
1076 return make_multibyte_string (buf, SCHARS (string), nbytes);
1080 /* Convert STRING to a single-byte string. */
1082 Lisp_Object
1083 string_make_unibyte (string)
1084 Lisp_Object string;
1086 unsigned char *buf;
1088 if (! STRING_MULTIBYTE (string))
1089 return string;
1091 buf = (unsigned char *) alloca (SCHARS (string));
1093 copy_text (SDATA (string), buf, SBYTES (string),
1094 1, 0);
1096 return make_unibyte_string (buf, SCHARS (string));
1099 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1100 1, 1, 0,
1101 doc: /* Return the multibyte equivalent of STRING.
1102 The function `unibyte-char-to-multibyte' is used to convert
1103 each unibyte character to a multibyte character. */)
1104 (string)
1105 Lisp_Object string;
1107 CHECK_STRING (string);
1109 return string_make_multibyte (string);
1112 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1113 1, 1, 0,
1114 doc: /* Return the unibyte equivalent of STRING.
1115 Multibyte character codes are converted to unibyte according to
1116 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1117 If the lookup in the translation table fails, this function takes just
1118 the low 8 bits of each character. */)
1119 (string)
1120 Lisp_Object string;
1122 CHECK_STRING (string);
1124 return string_make_unibyte (string);
1127 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1128 1, 1, 0,
1129 doc: /* Return a unibyte string with the same individual bytes as STRING.
1130 If STRING is unibyte, the result is STRING itself.
1131 Otherwise it is a newly created string, with no text properties.
1132 If STRING is multibyte and contains a character of charset
1133 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1134 corresponding single byte. */)
1135 (string)
1136 Lisp_Object string;
1138 CHECK_STRING (string);
1140 if (STRING_MULTIBYTE (string))
1142 int bytes = SBYTES (string);
1143 unsigned char *str = (unsigned char *) xmalloc (bytes);
1145 bcopy (SDATA (string), str, bytes);
1146 bytes = str_as_unibyte (str, bytes);
1147 string = make_unibyte_string (str, bytes);
1148 xfree (str);
1150 return string;
1153 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1154 1, 1, 0,
1155 doc: /* Return a multibyte string with the same individual bytes as STRING.
1156 If STRING is multibyte, the result is STRING itself.
1157 Otherwise it is a newly created string, with no text properties.
1158 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1159 part of a multibyte form), it is converted to the corresponding
1160 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1161 (string)
1162 Lisp_Object string;
1164 CHECK_STRING (string);
1166 if (! STRING_MULTIBYTE (string))
1168 Lisp_Object new_string;
1169 int nchars, nbytes;
1171 parse_str_as_multibyte (SDATA (string),
1172 SBYTES (string),
1173 &nchars, &nbytes);
1174 new_string = make_uninit_multibyte_string (nchars, nbytes);
1175 bcopy (SDATA (string), SDATA (new_string),
1176 SBYTES (string));
1177 if (nbytes != SBYTES (string))
1178 str_as_multibyte (SDATA (new_string), nbytes,
1179 SBYTES (string), NULL);
1180 string = new_string;
1181 STRING_SET_INTERVALS (string, NULL_INTERVAL);
1183 return string;
1186 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1187 1, 1, 0,
1188 doc: /* Return a multibyte string with the same individual chars as STRING.
1189 If STRING is multibyte, the result is STRING itself.
1190 Otherwise it is a newly created string, with no text properties.
1191 Characters 0200 through 0237 are converted to eight-bit-control
1192 characters of the same character code. Characters 0240 through 0377
1193 are converted to eight-bit-graphic characters of the same character
1194 codes. */)
1195 (string)
1196 Lisp_Object string;
1198 CHECK_STRING (string);
1200 return string_to_multibyte (string);
1204 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1205 doc: /* Return a copy of ALIST.
1206 This is an alist which represents the same mapping from objects to objects,
1207 but does not share the alist structure with ALIST.
1208 The objects mapped (cars and cdrs of elements of the alist)
1209 are shared, however.
1210 Elements of ALIST that are not conses are also shared. */)
1211 (alist)
1212 Lisp_Object alist;
1214 register Lisp_Object tem;
1216 CHECK_LIST (alist);
1217 if (NILP (alist))
1218 return alist;
1219 alist = concat (1, &alist, Lisp_Cons, 0);
1220 for (tem = alist; CONSP (tem); tem = XCDR (tem))
1222 register Lisp_Object car;
1223 car = XCAR (tem);
1225 if (CONSP (car))
1226 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1228 return alist;
1231 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
1232 doc: /* Return a substring of STRING, starting at index FROM and ending before TO.
1233 TO may be nil or omitted; then the substring runs to the end of STRING.
1234 FROM and TO start at 0. If either is negative, it counts from the end.
1236 This function allows vectors as well as strings. */)
1237 (string, from, to)
1238 Lisp_Object string;
1239 register Lisp_Object from, to;
1241 Lisp_Object res;
1242 int size;
1243 int size_byte = 0;
1244 int from_char, to_char;
1245 int from_byte = 0, to_byte = 0;
1247 if (! (STRINGP (string) || VECTORP (string)))
1248 wrong_type_argument (Qarrayp, string);
1250 CHECK_NUMBER (from);
1252 if (STRINGP (string))
1254 size = SCHARS (string);
1255 size_byte = SBYTES (string);
1257 else
1258 size = XVECTOR (string)->size;
1260 if (NILP (to))
1262 to_char = size;
1263 to_byte = size_byte;
1265 else
1267 CHECK_NUMBER (to);
1269 to_char = XINT (to);
1270 if (to_char < 0)
1271 to_char += size;
1273 if (STRINGP (string))
1274 to_byte = string_char_to_byte (string, to_char);
1277 from_char = XINT (from);
1278 if (from_char < 0)
1279 from_char += size;
1280 if (STRINGP (string))
1281 from_byte = string_char_to_byte (string, from_char);
1283 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1284 args_out_of_range_3 (string, make_number (from_char),
1285 make_number (to_char));
1287 if (STRINGP (string))
1289 res = make_specified_string (SDATA (string) + from_byte,
1290 to_char - from_char, to_byte - from_byte,
1291 STRING_MULTIBYTE (string));
1292 copy_text_properties (make_number (from_char), make_number (to_char),
1293 string, make_number (0), res, Qnil);
1295 else
1296 res = Fvector (to_char - from_char,
1297 XVECTOR (string)->contents + from_char);
1299 return res;
1303 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1304 doc: /* Return a substring of STRING, without text properties.
1305 It starts at index FROM and ending before TO.
1306 TO may be nil or omitted; then the substring runs to the end of STRING.
1307 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1308 If FROM or TO is negative, it counts from the end.
1310 With one argument, just copy STRING without its properties. */)
1311 (string, from, to)
1312 Lisp_Object string;
1313 register Lisp_Object from, to;
1315 int size, size_byte;
1316 int from_char, to_char;
1317 int from_byte, to_byte;
1319 CHECK_STRING (string);
1321 size = SCHARS (string);
1322 size_byte = SBYTES (string);
1324 if (NILP (from))
1325 from_char = from_byte = 0;
1326 else
1328 CHECK_NUMBER (from);
1329 from_char = XINT (from);
1330 if (from_char < 0)
1331 from_char += size;
1333 from_byte = string_char_to_byte (string, from_char);
1336 if (NILP (to))
1338 to_char = size;
1339 to_byte = size_byte;
1341 else
1343 CHECK_NUMBER (to);
1345 to_char = XINT (to);
1346 if (to_char < 0)
1347 to_char += size;
1349 to_byte = string_char_to_byte (string, to_char);
1352 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1353 args_out_of_range_3 (string, make_number (from_char),
1354 make_number (to_char));
1356 return make_specified_string (SDATA (string) + from_byte,
1357 to_char - from_char, to_byte - from_byte,
1358 STRING_MULTIBYTE (string));
1361 /* Extract a substring of STRING, giving start and end positions
1362 both in characters and in bytes. */
1364 Lisp_Object
1365 substring_both (string, from, from_byte, to, to_byte)
1366 Lisp_Object string;
1367 int from, from_byte, to, to_byte;
1369 Lisp_Object res;
1370 int size;
1371 int size_byte;
1373 if (! (STRINGP (string) || VECTORP (string)))
1374 wrong_type_argument (Qarrayp, string);
1376 if (STRINGP (string))
1378 size = SCHARS (string);
1379 size_byte = SBYTES (string);
1381 else
1382 size = XVECTOR (string)->size;
1384 if (!(0 <= from && from <= to && to <= size))
1385 args_out_of_range_3 (string, make_number (from), make_number (to));
1387 if (STRINGP (string))
1389 res = make_specified_string (SDATA (string) + from_byte,
1390 to - from, to_byte - from_byte,
1391 STRING_MULTIBYTE (string));
1392 copy_text_properties (make_number (from), make_number (to),
1393 string, make_number (0), res, Qnil);
1395 else
1396 res = Fvector (to - from,
1397 XVECTOR (string)->contents + from);
1399 return res;
1402 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1403 doc: /* Take cdr N times on LIST, returns the result. */)
1404 (n, list)
1405 Lisp_Object n;
1406 register Lisp_Object list;
1408 register int i, num;
1409 CHECK_NUMBER (n);
1410 num = XINT (n);
1411 for (i = 0; i < num && !NILP (list); i++)
1413 QUIT;
1414 if (! CONSP (list))
1415 wrong_type_argument (Qlistp, list);
1416 list = XCDR (list);
1418 return list;
1421 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1422 doc: /* Return the Nth element of LIST.
1423 N counts from zero. If LIST is not that long, nil is returned. */)
1424 (n, list)
1425 Lisp_Object n, list;
1427 return Fcar (Fnthcdr (n, list));
1430 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1431 doc: /* Return element of SEQUENCE at index N. */)
1432 (sequence, n)
1433 register Lisp_Object sequence, n;
1435 CHECK_NUMBER (n);
1436 while (1)
1438 if (CONSP (sequence) || NILP (sequence))
1439 return Fcar (Fnthcdr (n, sequence));
1440 else if (STRINGP (sequence) || VECTORP (sequence)
1441 || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
1442 return Faref (sequence, n);
1443 else
1444 sequence = wrong_type_argument (Qsequencep, sequence);
1448 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1449 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1450 The value is actually the tail of LIST whose car is ELT. */)
1451 (elt, list)
1452 register Lisp_Object elt;
1453 Lisp_Object list;
1455 register Lisp_Object tail;
1456 for (tail = list; !NILP (tail); tail = XCDR (tail))
1458 register Lisp_Object tem;
1459 if (! CONSP (tail))
1460 wrong_type_argument (Qlistp, list);
1461 tem = XCAR (tail);
1462 if (! NILP (Fequal (elt, tem)))
1463 return tail;
1464 QUIT;
1466 return Qnil;
1469 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1470 doc: /* Return non-nil if ELT is an element of LIST.
1471 Comparison done with EQ. The value is actually the tail of LIST
1472 whose car is ELT. */)
1473 (elt, list)
1474 Lisp_Object elt, list;
1476 while (1)
1478 if (!CONSP (list) || EQ (XCAR (list), elt))
1479 break;
1481 list = XCDR (list);
1482 if (!CONSP (list) || EQ (XCAR (list), elt))
1483 break;
1485 list = XCDR (list);
1486 if (!CONSP (list) || EQ (XCAR (list), elt))
1487 break;
1489 list = XCDR (list);
1490 QUIT;
1493 if (!CONSP (list) && !NILP (list))
1494 list = wrong_type_argument (Qlistp, list);
1496 return list;
1499 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1500 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1501 The value is actually the first element of LIST whose car is KEY.
1502 Elements of LIST that are not conses are ignored. */)
1503 (key, list)
1504 Lisp_Object key, list;
1506 Lisp_Object result;
1508 while (1)
1510 if (!CONSP (list)
1511 || (CONSP (XCAR (list))
1512 && EQ (XCAR (XCAR (list)), key)))
1513 break;
1515 list = XCDR (list);
1516 if (!CONSP (list)
1517 || (CONSP (XCAR (list))
1518 && EQ (XCAR (XCAR (list)), key)))
1519 break;
1521 list = XCDR (list);
1522 if (!CONSP (list)
1523 || (CONSP (XCAR (list))
1524 && EQ (XCAR (XCAR (list)), key)))
1525 break;
1527 list = XCDR (list);
1528 QUIT;
1531 if (CONSP (list))
1532 result = XCAR (list);
1533 else if (NILP (list))
1534 result = Qnil;
1535 else
1536 result = wrong_type_argument (Qlistp, list);
1538 return result;
1541 /* Like Fassq but never report an error and do not allow quits.
1542 Use only on lists known never to be circular. */
1544 Lisp_Object
1545 assq_no_quit (key, list)
1546 Lisp_Object key, list;
1548 while (CONSP (list)
1549 && (!CONSP (XCAR (list))
1550 || !EQ (XCAR (XCAR (list)), key)))
1551 list = XCDR (list);
1553 return CONSP (list) ? XCAR (list) : Qnil;
1556 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1557 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1558 The value is actually the first element of LIST whose car equals KEY. */)
1559 (key, list)
1560 Lisp_Object key, list;
1562 Lisp_Object result, car;
1564 while (1)
1566 if (!CONSP (list)
1567 || (CONSP (XCAR (list))
1568 && (car = XCAR (XCAR (list)),
1569 EQ (car, key) || !NILP (Fequal (car, key)))))
1570 break;
1572 list = XCDR (list);
1573 if (!CONSP (list)
1574 || (CONSP (XCAR (list))
1575 && (car = XCAR (XCAR (list)),
1576 EQ (car, key) || !NILP (Fequal (car, key)))))
1577 break;
1579 list = XCDR (list);
1580 if (!CONSP (list)
1581 || (CONSP (XCAR (list))
1582 && (car = XCAR (XCAR (list)),
1583 EQ (car, key) || !NILP (Fequal (car, key)))))
1584 break;
1586 list = XCDR (list);
1587 QUIT;
1590 if (CONSP (list))
1591 result = XCAR (list);
1592 else if (NILP (list))
1593 result = Qnil;
1594 else
1595 result = wrong_type_argument (Qlistp, list);
1597 return result;
1600 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1601 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1602 The value is actually the first element of LIST whose cdr is KEY. */)
1603 (key, list)
1604 register Lisp_Object key;
1605 Lisp_Object list;
1607 Lisp_Object result;
1609 while (1)
1611 if (!CONSP (list)
1612 || (CONSP (XCAR (list))
1613 && EQ (XCDR (XCAR (list)), key)))
1614 break;
1616 list = XCDR (list);
1617 if (!CONSP (list)
1618 || (CONSP (XCAR (list))
1619 && EQ (XCDR (XCAR (list)), key)))
1620 break;
1622 list = XCDR (list);
1623 if (!CONSP (list)
1624 || (CONSP (XCAR (list))
1625 && EQ (XCDR (XCAR (list)), key)))
1626 break;
1628 list = XCDR (list);
1629 QUIT;
1632 if (NILP (list))
1633 result = Qnil;
1634 else if (CONSP (list))
1635 result = XCAR (list);
1636 else
1637 result = wrong_type_argument (Qlistp, list);
1639 return result;
1642 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1643 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1644 The value is actually the first element of LIST whose cdr equals KEY. */)
1645 (key, list)
1646 Lisp_Object key, list;
1648 Lisp_Object result, cdr;
1650 while (1)
1652 if (!CONSP (list)
1653 || (CONSP (XCAR (list))
1654 && (cdr = XCDR (XCAR (list)),
1655 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1656 break;
1658 list = XCDR (list);
1659 if (!CONSP (list)
1660 || (CONSP (XCAR (list))
1661 && (cdr = XCDR (XCAR (list)),
1662 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1663 break;
1665 list = XCDR (list);
1666 if (!CONSP (list)
1667 || (CONSP (XCAR (list))
1668 && (cdr = XCDR (XCAR (list)),
1669 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1670 break;
1672 list = XCDR (list);
1673 QUIT;
1676 if (CONSP (list))
1677 result = XCAR (list);
1678 else if (NILP (list))
1679 result = Qnil;
1680 else
1681 result = wrong_type_argument (Qlistp, list);
1683 return result;
1686 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1687 doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
1688 The modified LIST is returned. Comparison is done with `eq'.
1689 If the first member of LIST is ELT, there is no way to remove it by side effect;
1690 therefore, write `(setq foo (delq element foo))'
1691 to be sure of changing the value of `foo'. */)
1692 (elt, list)
1693 register Lisp_Object elt;
1694 Lisp_Object list;
1696 register Lisp_Object tail, prev;
1697 register Lisp_Object tem;
1699 tail = list;
1700 prev = Qnil;
1701 while (!NILP (tail))
1703 if (! CONSP (tail))
1704 wrong_type_argument (Qlistp, list);
1705 tem = XCAR (tail);
1706 if (EQ (elt, tem))
1708 if (NILP (prev))
1709 list = XCDR (tail);
1710 else
1711 Fsetcdr (prev, XCDR (tail));
1713 else
1714 prev = tail;
1715 tail = XCDR (tail);
1716 QUIT;
1718 return list;
1721 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1722 doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1723 SEQ must be a list, a vector, or a string.
1724 The modified SEQ is returned. Comparison is done with `equal'.
1725 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1726 is not a side effect; it is simply using a different sequence.
1727 Therefore, write `(setq foo (delete element foo))'
1728 to be sure of changing the value of `foo'. */)
1729 (elt, seq)
1730 Lisp_Object elt, seq;
1732 if (VECTORP (seq))
1734 EMACS_INT i, n;
1736 for (i = n = 0; i < ASIZE (seq); ++i)
1737 if (NILP (Fequal (AREF (seq, i), elt)))
1738 ++n;
1740 if (n != ASIZE (seq))
1742 struct Lisp_Vector *p = allocate_vector (n);
1744 for (i = n = 0; i < ASIZE (seq); ++i)
1745 if (NILP (Fequal (AREF (seq, i), elt)))
1746 p->contents[n++] = AREF (seq, i);
1748 XSETVECTOR (seq, p);
1751 else if (STRINGP (seq))
1753 EMACS_INT i, ibyte, nchars, nbytes, cbytes;
1754 int c;
1756 for (i = nchars = nbytes = ibyte = 0;
1757 i < SCHARS (seq);
1758 ++i, ibyte += cbytes)
1760 if (STRING_MULTIBYTE (seq))
1762 c = STRING_CHAR (SDATA (seq) + ibyte,
1763 SBYTES (seq) - ibyte);
1764 cbytes = CHAR_BYTES (c);
1766 else
1768 c = SREF (seq, i);
1769 cbytes = 1;
1772 if (!INTEGERP (elt) || c != XINT (elt))
1774 ++nchars;
1775 nbytes += cbytes;
1779 if (nchars != SCHARS (seq))
1781 Lisp_Object tem;
1783 tem = make_uninit_multibyte_string (nchars, nbytes);
1784 if (!STRING_MULTIBYTE (seq))
1785 STRING_SET_UNIBYTE (tem);
1787 for (i = nchars = nbytes = ibyte = 0;
1788 i < SCHARS (seq);
1789 ++i, ibyte += cbytes)
1791 if (STRING_MULTIBYTE (seq))
1793 c = STRING_CHAR (SDATA (seq) + ibyte,
1794 SBYTES (seq) - ibyte);
1795 cbytes = CHAR_BYTES (c);
1797 else
1799 c = SREF (seq, i);
1800 cbytes = 1;
1803 if (!INTEGERP (elt) || c != XINT (elt))
1805 unsigned char *from = SDATA (seq) + ibyte;
1806 unsigned char *to = SDATA (tem) + nbytes;
1807 EMACS_INT n;
1809 ++nchars;
1810 nbytes += cbytes;
1812 for (n = cbytes; n--; )
1813 *to++ = *from++;
1817 seq = tem;
1820 else
1822 Lisp_Object tail, prev;
1824 for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
1826 if (!CONSP (tail))
1827 wrong_type_argument (Qlistp, seq);
1829 if (!NILP (Fequal (elt, XCAR (tail))))
1831 if (NILP (prev))
1832 seq = XCDR (tail);
1833 else
1834 Fsetcdr (prev, XCDR (tail));
1836 else
1837 prev = tail;
1838 QUIT;
1842 return seq;
1845 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1846 doc: /* Reverse LIST by modifying cdr pointers.
1847 Return the reversed list. */)
1848 (list)
1849 Lisp_Object list;
1851 register Lisp_Object prev, tail, next;
1853 if (NILP (list)) return list;
1854 prev = Qnil;
1855 tail = list;
1856 while (!NILP (tail))
1858 QUIT;
1859 if (! CONSP (tail))
1860 wrong_type_argument (Qlistp, list);
1861 next = XCDR (tail);
1862 Fsetcdr (tail, prev);
1863 prev = tail;
1864 tail = next;
1866 return prev;
1869 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1870 doc: /* Reverse LIST, copying. Return the reversed list.
1871 See also the function `nreverse', which is used more often. */)
1872 (list)
1873 Lisp_Object list;
1875 Lisp_Object new;
1877 for (new = Qnil; CONSP (list); list = XCDR (list))
1879 QUIT;
1880 new = Fcons (XCAR (list), new);
1882 if (!NILP (list))
1883 wrong_type_argument (Qconsp, list);
1884 return new;
1887 Lisp_Object merge ();
1889 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1890 doc: /* Sort LIST, stably, comparing elements using PREDICATE.
1891 Returns the sorted list. LIST is modified by side effects.
1892 PREDICATE is called with two elements of LIST, and should return t
1893 if the first element is "less" than the second. */)
1894 (list, predicate)
1895 Lisp_Object list, predicate;
1897 Lisp_Object front, back;
1898 register Lisp_Object len, tem;
1899 struct gcpro gcpro1, gcpro2;
1900 register int length;
1902 front = list;
1903 len = Flength (list);
1904 length = XINT (len);
1905 if (length < 2)
1906 return list;
1908 XSETINT (len, (length / 2) - 1);
1909 tem = Fnthcdr (len, list);
1910 back = Fcdr (tem);
1911 Fsetcdr (tem, Qnil);
1913 GCPRO2 (front, back);
1914 front = Fsort (front, predicate);
1915 back = Fsort (back, predicate);
1916 UNGCPRO;
1917 return merge (front, back, predicate);
1920 Lisp_Object
1921 merge (org_l1, org_l2, pred)
1922 Lisp_Object org_l1, org_l2;
1923 Lisp_Object pred;
1925 Lisp_Object value;
1926 register Lisp_Object tail;
1927 Lisp_Object tem;
1928 register Lisp_Object l1, l2;
1929 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1931 l1 = org_l1;
1932 l2 = org_l2;
1933 tail = Qnil;
1934 value = Qnil;
1936 /* It is sufficient to protect org_l1 and org_l2.
1937 When l1 and l2 are updated, we copy the new values
1938 back into the org_ vars. */
1939 GCPRO4 (org_l1, org_l2, pred, value);
1941 while (1)
1943 if (NILP (l1))
1945 UNGCPRO;
1946 if (NILP (tail))
1947 return l2;
1948 Fsetcdr (tail, l2);
1949 return value;
1951 if (NILP (l2))
1953 UNGCPRO;
1954 if (NILP (tail))
1955 return l1;
1956 Fsetcdr (tail, l1);
1957 return value;
1959 tem = call2 (pred, Fcar (l2), Fcar (l1));
1960 if (NILP (tem))
1962 tem = l1;
1963 l1 = Fcdr (l1);
1964 org_l1 = l1;
1966 else
1968 tem = l2;
1969 l2 = Fcdr (l2);
1970 org_l2 = l2;
1972 if (NILP (tail))
1973 value = tem;
1974 else
1975 Fsetcdr (tail, tem);
1976 tail = tem;
1981 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1982 doc: /* Extract a value from a property list.
1983 PLIST is a property list, which is a list of the form
1984 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1985 corresponding to the given PROP, or nil if PROP is not
1986 one of the properties on the list. */)
1987 (plist, prop)
1988 Lisp_Object plist;
1989 Lisp_Object prop;
1991 Lisp_Object tail;
1993 for (tail = plist;
1994 CONSP (tail) && CONSP (XCDR (tail));
1995 tail = XCDR (XCDR (tail)))
1997 if (EQ (prop, XCAR (tail)))
1998 return XCAR (XCDR (tail));
2000 /* This function can be called asynchronously
2001 (setup_coding_system). Don't QUIT in that case. */
2002 if (!interrupt_input_blocked)
2003 QUIT;
2006 if (!NILP (tail))
2007 wrong_type_argument (Qlistp, prop);
2009 return Qnil;
2012 DEFUN ("get", Fget, Sget, 2, 2, 0,
2013 doc: /* Return the value of SYMBOL's PROPNAME property.
2014 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2015 (symbol, propname)
2016 Lisp_Object symbol, propname;
2018 CHECK_SYMBOL (symbol);
2019 return Fplist_get (XSYMBOL (symbol)->plist, propname);
2022 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
2023 doc: /* Change value in PLIST of PROP to VAL.
2024 PLIST is a property list, which is a list of the form
2025 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2026 If PROP is already a property on the list, its value is set to VAL,
2027 otherwise the new PROP VAL pair is added. The new plist is returned;
2028 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2029 The PLIST is modified by side effects. */)
2030 (plist, prop, val)
2031 Lisp_Object plist;
2032 register Lisp_Object prop;
2033 Lisp_Object val;
2035 register Lisp_Object tail, prev;
2036 Lisp_Object newcell;
2037 prev = Qnil;
2038 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2039 tail = XCDR (XCDR (tail)))
2041 if (EQ (prop, XCAR (tail)))
2043 Fsetcar (XCDR (tail), val);
2044 return plist;
2047 prev = tail;
2048 QUIT;
2050 newcell = Fcons (prop, Fcons (val, Qnil));
2051 if (NILP (prev))
2052 return newcell;
2053 else
2054 Fsetcdr (XCDR (prev), newcell);
2055 return plist;
2058 DEFUN ("put", Fput, Sput, 3, 3, 0,
2059 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
2060 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2061 (symbol, propname, value)
2062 Lisp_Object symbol, propname, value;
2064 CHECK_SYMBOL (symbol);
2065 XSYMBOL (symbol)->plist
2066 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
2067 return value;
2070 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
2071 doc: /* Extract a value from a property list, comparing with `equal'.
2072 PLIST is a property list, which is a list of the form
2073 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2074 corresponding to the given PROP, or nil if PROP is not
2075 one of the properties on the list. */)
2076 (plist, prop)
2077 Lisp_Object plist;
2078 Lisp_Object prop;
2080 Lisp_Object tail;
2082 for (tail = plist;
2083 CONSP (tail) && CONSP (XCDR (tail));
2084 tail = XCDR (XCDR (tail)))
2086 if (! NILP (Fequal (prop, XCAR (tail))))
2087 return XCAR (XCDR (tail));
2089 QUIT;
2092 if (!NILP (tail))
2093 wrong_type_argument (Qlistp, prop);
2095 return Qnil;
2098 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
2099 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2100 PLIST is a property list, which is a list of the form
2101 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2102 If PROP is already a property on the list, its value is set to VAL,
2103 otherwise the new PROP VAL pair is added. The new plist is returned;
2104 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2105 The PLIST is modified by side effects. */)
2106 (plist, prop, val)
2107 Lisp_Object plist;
2108 register Lisp_Object prop;
2109 Lisp_Object val;
2111 register Lisp_Object tail, prev;
2112 Lisp_Object newcell;
2113 prev = Qnil;
2114 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2115 tail = XCDR (XCDR (tail)))
2117 if (! NILP (Fequal (prop, XCAR (tail))))
2119 Fsetcar (XCDR (tail), val);
2120 return plist;
2123 prev = tail;
2124 QUIT;
2126 newcell = Fcons (prop, Fcons (val, Qnil));
2127 if (NILP (prev))
2128 return newcell;
2129 else
2130 Fsetcdr (XCDR (prev), newcell);
2131 return plist;
2134 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
2135 doc: /* Return t if two Lisp objects have similar structure and contents.
2136 They must have the same data type.
2137 Conses are compared by comparing the cars and the cdrs.
2138 Vectors and strings are compared element by element.
2139 Numbers are compared by value, but integers cannot equal floats.
2140 (Use `=' if you want integers and floats to be able to be equal.)
2141 Symbols must match exactly. */)
2142 (o1, o2)
2143 register Lisp_Object o1, o2;
2145 return internal_equal (o1, o2, 0) ? Qt : Qnil;
2148 static int
2149 internal_equal (o1, o2, depth)
2150 register Lisp_Object o1, o2;
2151 int depth;
2153 if (depth > 200)
2154 error ("Stack overflow in equal");
2156 tail_recurse:
2157 QUIT;
2158 if (EQ (o1, o2))
2159 return 1;
2160 if (XTYPE (o1) != XTYPE (o2))
2161 return 0;
2163 switch (XTYPE (o1))
2165 case Lisp_Float:
2166 return (extract_float (o1) == extract_float (o2));
2168 case Lisp_Cons:
2169 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
2170 return 0;
2171 o1 = XCDR (o1);
2172 o2 = XCDR (o2);
2173 goto tail_recurse;
2175 case Lisp_Misc:
2176 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2177 return 0;
2178 if (OVERLAYP (o1))
2180 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2181 depth + 1)
2182 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2183 depth + 1))
2184 return 0;
2185 o1 = XOVERLAY (o1)->plist;
2186 o2 = XOVERLAY (o2)->plist;
2187 goto tail_recurse;
2189 if (MARKERP (o1))
2191 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2192 && (XMARKER (o1)->buffer == 0
2193 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2195 break;
2197 case Lisp_Vectorlike:
2199 register int i;
2200 EMACS_INT size = XVECTOR (o1)->size;
2201 /* Pseudovectors have the type encoded in the size field, so this test
2202 actually checks that the objects have the same type as well as the
2203 same size. */
2204 if (XVECTOR (o2)->size != size)
2205 return 0;
2206 /* Boolvectors are compared much like strings. */
2207 if (BOOL_VECTOR_P (o1))
2209 int size_in_chars
2210 = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
2212 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
2213 return 0;
2214 if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
2215 size_in_chars))
2216 return 0;
2217 return 1;
2219 if (WINDOW_CONFIGURATIONP (o1))
2220 return compare_window_configurations (o1, o2, 0);
2222 /* Aside from them, only true vectors, char-tables, and compiled
2223 functions are sensible to compare, so eliminate the others now. */
2224 if (size & PSEUDOVECTOR_FLAG)
2226 if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
2227 return 0;
2228 size &= PSEUDOVECTOR_SIZE_MASK;
2230 for (i = 0; i < size; i++)
2232 Lisp_Object v1, v2;
2233 v1 = XVECTOR (o1)->contents [i];
2234 v2 = XVECTOR (o2)->contents [i];
2235 if (!internal_equal (v1, v2, depth + 1))
2236 return 0;
2238 return 1;
2240 break;
2242 case Lisp_String:
2243 if (SCHARS (o1) != SCHARS (o2))
2244 return 0;
2245 if (SBYTES (o1) != SBYTES (o2))
2246 return 0;
2247 if (bcmp (SDATA (o1), SDATA (o2),
2248 SBYTES (o1)))
2249 return 0;
2250 return 1;
2252 case Lisp_Int:
2253 case Lisp_Symbol:
2254 case Lisp_Type_Limit:
2255 break;
2258 return 0;
2261 extern Lisp_Object Fmake_char_internal ();
2263 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2264 doc: /* Store each element of ARRAY with ITEM.
2265 ARRAY is a vector, string, char-table, or bool-vector. */)
2266 (array, item)
2267 Lisp_Object array, item;
2269 register int size, index, charval;
2270 retry:
2271 if (VECTORP (array))
2273 register Lisp_Object *p = XVECTOR (array)->contents;
2274 size = XVECTOR (array)->size;
2275 for (index = 0; index < size; index++)
2276 p[index] = item;
2278 else if (CHAR_TABLE_P (array))
2280 register Lisp_Object *p = XCHAR_TABLE (array)->contents;
2281 size = CHAR_TABLE_ORDINARY_SLOTS;
2282 for (index = 0; index < size; index++)
2283 p[index] = item;
2284 XCHAR_TABLE (array)->defalt = Qnil;
2286 else if (STRINGP (array))
2288 register unsigned char *p = SDATA (array);
2289 CHECK_NUMBER (item);
2290 charval = XINT (item);
2291 size = SCHARS (array);
2292 if (STRING_MULTIBYTE (array))
2294 unsigned char str[MAX_MULTIBYTE_LENGTH];
2295 int len = CHAR_STRING (charval, str);
2296 int size_byte = SBYTES (array);
2297 unsigned char *p1 = p, *endp = p + size_byte;
2298 int i;
2300 if (size != size_byte)
2301 while (p1 < endp)
2303 int this_len = MULTIBYTE_FORM_LENGTH (p1, endp - p1);
2304 if (len != this_len)
2305 error ("Attempt to change byte length of a string");
2306 p1 += this_len;
2308 for (i = 0; i < size_byte; i++)
2309 *p++ = str[i % len];
2311 else
2312 for (index = 0; index < size; index++)
2313 p[index] = charval;
2315 else if (BOOL_VECTOR_P (array))
2317 register unsigned char *p = XBOOL_VECTOR (array)->data;
2318 int size_in_chars
2319 = (XBOOL_VECTOR (array)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
2321 charval = (! NILP (item) ? -1 : 0);
2322 for (index = 0; index < size_in_chars - 1; index++)
2323 p[index] = charval;
2324 if (index < size_in_chars)
2326 /* Mask out bits beyond the vector size. */
2327 if (XBOOL_VECTOR (array)->size % BITS_PER_CHAR)
2328 charval &= (1 << (XBOOL_VECTOR (array)->size % BITS_PER_CHAR)) - 1;
2329 p[index] = charval;
2332 else
2334 array = wrong_type_argument (Qarrayp, array);
2335 goto retry;
2337 return array;
2340 DEFUN ("clear-string", Fclear_string, Sclear_string,
2341 1, 1, 0,
2342 doc: /* Clear the contents of STRING.
2343 This makes STRING unibyte and may change its length. */)
2344 (string)
2345 Lisp_Object string;
2347 int len = SBYTES (string);
2348 bzero (SDATA (string), len);
2349 STRING_SET_CHARS (string, len);
2350 STRING_SET_UNIBYTE (string);
2351 return Qnil;
2354 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
2355 1, 1, 0,
2356 doc: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2357 (char_table)
2358 Lisp_Object char_table;
2360 CHECK_CHAR_TABLE (char_table);
2362 return XCHAR_TABLE (char_table)->purpose;
2365 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
2366 1, 1, 0,
2367 doc: /* Return the parent char-table of CHAR-TABLE.
2368 The value is either nil or another char-table.
2369 If CHAR-TABLE holds nil for a given character,
2370 then the actual applicable value is inherited from the parent char-table
2371 \(or from its parents, if necessary). */)
2372 (char_table)
2373 Lisp_Object char_table;
2375 CHECK_CHAR_TABLE (char_table);
2377 return XCHAR_TABLE (char_table)->parent;
2380 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
2381 2, 2, 0,
2382 doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
2383 Return PARENT. PARENT must be either nil or another char-table. */)
2384 (char_table, parent)
2385 Lisp_Object char_table, parent;
2387 Lisp_Object temp;
2389 CHECK_CHAR_TABLE (char_table);
2391 if (!NILP (parent))
2393 CHECK_CHAR_TABLE (parent);
2395 for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
2396 if (EQ (temp, char_table))
2397 error ("Attempt to make a chartable be its own parent");
2400 XCHAR_TABLE (char_table)->parent = parent;
2402 return parent;
2405 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
2406 2, 2, 0,
2407 doc: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2408 (char_table, n)
2409 Lisp_Object char_table, n;
2411 CHECK_CHAR_TABLE (char_table);
2412 CHECK_NUMBER (n);
2413 if (XINT (n) < 0
2414 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
2415 args_out_of_range (char_table, n);
2417 return XCHAR_TABLE (char_table)->extras[XINT (n)];
2420 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
2421 Sset_char_table_extra_slot,
2422 3, 3, 0,
2423 doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2424 (char_table, n, value)
2425 Lisp_Object char_table, n, value;
2427 CHECK_CHAR_TABLE (char_table);
2428 CHECK_NUMBER (n);
2429 if (XINT (n) < 0
2430 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
2431 args_out_of_range (char_table, n);
2433 return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
2436 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
2437 2, 2, 0,
2438 doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2439 RANGE should be nil (for the default value)
2440 a vector which identifies a character set or a row of a character set,
2441 a character set name, or a character code. */)
2442 (char_table, range)
2443 Lisp_Object char_table, range;
2445 CHECK_CHAR_TABLE (char_table);
2447 if (EQ (range, Qnil))
2448 return XCHAR_TABLE (char_table)->defalt;
2449 else if (INTEGERP (range))
2450 return Faref (char_table, range);
2451 else if (SYMBOLP (range))
2453 Lisp_Object charset_info;
2455 charset_info = Fget (range, Qcharset);
2456 CHECK_VECTOR (charset_info);
2458 return Faref (char_table,
2459 make_number (XINT (XVECTOR (charset_info)->contents[0])
2460 + 128));
2462 else if (VECTORP (range))
2464 if (XVECTOR (range)->size == 1)
2465 return Faref (char_table,
2466 make_number (XINT (XVECTOR (range)->contents[0]) + 128));
2467 else
2469 int size = XVECTOR (range)->size;
2470 Lisp_Object *val = XVECTOR (range)->contents;
2471 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
2472 size <= 1 ? Qnil : val[1],
2473 size <= 2 ? Qnil : val[2]);
2474 return Faref (char_table, ch);
2477 else
2478 error ("Invalid RANGE argument to `char-table-range'");
2479 return Qt;
2482 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
2483 3, 3, 0,
2484 doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2485 RANGE should be t (for all characters), nil (for the default value)
2486 a vector which identifies a character set or a row of a character set,
2487 a coding system, or a character code. */)
2488 (char_table, range, value)
2489 Lisp_Object char_table, range, value;
2491 int i;
2493 CHECK_CHAR_TABLE (char_table);
2495 if (EQ (range, Qt))
2496 for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
2497 XCHAR_TABLE (char_table)->contents[i] = value;
2498 else if (EQ (range, Qnil))
2499 XCHAR_TABLE (char_table)->defalt = value;
2500 else if (SYMBOLP (range))
2502 Lisp_Object charset_info;
2504 charset_info = Fget (range, Qcharset);
2505 CHECK_VECTOR (charset_info);
2507 return Faset (char_table,
2508 make_number (XINT (XVECTOR (charset_info)->contents[0])
2509 + 128),
2510 value);
2512 else if (INTEGERP (range))
2513 Faset (char_table, range, value);
2514 else if (VECTORP (range))
2516 if (XVECTOR (range)->size == 1)
2517 return Faset (char_table,
2518 make_number (XINT (XVECTOR (range)->contents[0]) + 128),
2519 value);
2520 else
2522 int size = XVECTOR (range)->size;
2523 Lisp_Object *val = XVECTOR (range)->contents;
2524 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
2525 size <= 1 ? Qnil : val[1],
2526 size <= 2 ? Qnil : val[2]);
2527 return Faset (char_table, ch, value);
2530 else
2531 error ("Invalid RANGE argument to `set-char-table-range'");
2533 return value;
2536 DEFUN ("set-char-table-default", Fset_char_table_default,
2537 Sset_char_table_default, 3, 3, 0,
2538 doc: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2539 The generic character specifies the group of characters.
2540 See also the documentation of `make-char'. */)
2541 (char_table, ch, value)
2542 Lisp_Object char_table, ch, value;
2544 int c, charset, code1, code2;
2545 Lisp_Object temp;
2547 CHECK_CHAR_TABLE (char_table);
2548 CHECK_NUMBER (ch);
2550 c = XINT (ch);
2551 SPLIT_CHAR (c, charset, code1, code2);
2553 /* Since we may want to set the default value for a character set
2554 not yet defined, we check only if the character set is in the
2555 valid range or not, instead of it is already defined or not. */
2556 if (! CHARSET_VALID_P (charset))
2557 invalid_character (c);
2559 if (charset == CHARSET_ASCII)
2560 return (XCHAR_TABLE (char_table)->defalt = value);
2562 /* Even if C is not a generic char, we had better behave as if a
2563 generic char is specified. */
2564 if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1)
2565 code1 = 0;
2566 temp = XCHAR_TABLE (char_table)->contents[charset + 128];
2567 if (!code1)
2569 if (SUB_CHAR_TABLE_P (temp))
2570 XCHAR_TABLE (temp)->defalt = value;
2571 else
2572 XCHAR_TABLE (char_table)->contents[charset + 128] = value;
2573 return value;
2575 if (SUB_CHAR_TABLE_P (temp))
2576 char_table = temp;
2577 else
2578 char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
2579 = make_sub_char_table (temp));
2580 temp = XCHAR_TABLE (char_table)->contents[code1];
2581 if (SUB_CHAR_TABLE_P (temp))
2582 XCHAR_TABLE (temp)->defalt = value;
2583 else
2584 XCHAR_TABLE (char_table)->contents[code1] = value;
2585 return value;
2588 /* Look up the element in TABLE at index CH,
2589 and return it as an integer.
2590 If the element is nil, return CH itself.
2591 (Actually we do that for any non-integer.) */
2594 char_table_translate (table, ch)
2595 Lisp_Object table;
2596 int ch;
2598 Lisp_Object value;
2599 value = Faref (table, make_number (ch));
2600 if (! INTEGERP (value))
2601 return ch;
2602 return XINT (value);
2605 static void
2606 optimize_sub_char_table (table, chars)
2607 Lisp_Object *table;
2608 int chars;
2610 Lisp_Object elt;
2611 int from, to;
2613 if (chars == 94)
2614 from = 33, to = 127;
2615 else
2616 from = 32, to = 128;
2618 if (!SUB_CHAR_TABLE_P (*table))
2619 return;
2620 elt = XCHAR_TABLE (*table)->contents[from++];
2621 for (; from < to; from++)
2622 if (NILP (Fequal (elt, XCHAR_TABLE (*table)->contents[from])))
2623 return;
2624 *table = elt;
2627 DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
2628 1, 1, 0, doc: /* Optimize char table TABLE. */)
2629 (table)
2630 Lisp_Object table;
2632 Lisp_Object elt;
2633 int dim;
2634 int i, j;
2636 CHECK_CHAR_TABLE (table);
2638 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
2640 elt = XCHAR_TABLE (table)->contents[i];
2641 if (!SUB_CHAR_TABLE_P (elt))
2642 continue;
2643 dim = CHARSET_DIMENSION (i - 128);
2644 if (dim == 2)
2645 for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++)
2646 optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, dim);
2647 optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, dim);
2649 return Qnil;
2653 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2654 character or group of characters that share a value.
2655 DEPTH is the current depth in the originally specified
2656 chartable, and INDICES contains the vector indices
2657 for the levels our callers have descended.
2659 ARG is passed to C_FUNCTION when that is called. */
2661 void
2662 map_char_table (c_function, function, table, subtable, arg, depth, indices)
2663 void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
2664 Lisp_Object function, table, subtable, arg, *indices;
2665 int depth;
2667 int i, to;
2669 if (depth == 0)
2671 /* At first, handle ASCII and 8-bit European characters. */
2672 for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
2674 Lisp_Object elt= XCHAR_TABLE (subtable)->contents[i];
2675 if (NILP (elt))
2676 elt = XCHAR_TABLE (subtable)->defalt;
2677 if (NILP (elt))
2678 elt = Faref (subtable, make_number (i));
2679 if (c_function)
2680 (*c_function) (arg, make_number (i), elt);
2681 else
2682 call2 (function, make_number (i), elt);
2684 #if 0 /* If the char table has entries for higher characters,
2685 we should report them. */
2686 if (NILP (current_buffer->enable_multibyte_characters))
2687 return;
2688 #endif
2689 to = CHAR_TABLE_ORDINARY_SLOTS;
2691 else
2693 int charset = XFASTINT (indices[0]) - 128;
2695 i = 32;
2696 to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
2697 if (CHARSET_CHARS (charset) == 94)
2698 i++, to--;
2701 for (; i < to; i++)
2703 Lisp_Object elt;
2704 int charset;
2706 elt = XCHAR_TABLE (subtable)->contents[i];
2707 XSETFASTINT (indices[depth], i);
2708 charset = XFASTINT (indices[0]) - 128;
2709 if (depth == 0
2710 && (!CHARSET_DEFINED_P (charset)
2711 || charset == CHARSET_8_BIT_CONTROL
2712 || charset == CHARSET_8_BIT_GRAPHIC))
2713 continue;
2715 if (SUB_CHAR_TABLE_P (elt))
2717 if (depth >= 3)
2718 error ("Too deep char table");
2719 map_char_table (c_function, function, table, elt, arg, depth + 1, indices);
2721 else
2723 int c1, c2, c;
2725 c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
2726 c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
2727 c = MAKE_CHAR (charset, c1, c2);
2729 if (NILP (elt))
2730 elt = XCHAR_TABLE (subtable)->defalt;
2731 if (NILP (elt))
2732 elt = Faref (table, make_number (c));
2734 if (c_function)
2735 (*c_function) (arg, make_number (c), elt);
2736 else
2737 call2 (function, make_number (c), elt);
2742 static void void_call2 P_ ((Lisp_Object a, Lisp_Object b, Lisp_Object c));
2743 static void
2744 void_call2 (a, b, c)
2745 Lisp_Object a, b, c;
2747 call2 (a, b, c);
2750 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
2751 2, 2, 0,
2752 doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2753 FUNCTION is called with two arguments--a key and a value.
2754 The key is always a possible IDX argument to `aref'. */)
2755 (function, char_table)
2756 Lisp_Object function, char_table;
2758 /* The depth of char table is at most 3. */
2759 Lisp_Object indices[3];
2761 CHECK_CHAR_TABLE (char_table);
2763 /* When Lisp_Object is represented as a union, `call2' cannot directly
2764 be passed to map_char_table because it returns a Lisp_Object rather
2765 than returning nothing.
2766 Casting leads to crashes on some architectures. -stef */
2767 map_char_table (void_call2, Qnil, char_table, char_table, function, 0, indices);
2768 return Qnil;
2771 /* Return a value for character C in char-table TABLE. Store the
2772 actual index for that value in *IDX. Ignore the default value of
2773 TABLE. */
2775 Lisp_Object
2776 char_table_ref_and_index (table, c, idx)
2777 Lisp_Object table;
2778 int c, *idx;
2780 int charset, c1, c2;
2781 Lisp_Object elt;
2783 if (SINGLE_BYTE_CHAR_P (c))
2785 *idx = c;
2786 return XCHAR_TABLE (table)->contents[c];
2788 SPLIT_CHAR (c, charset, c1, c2);
2789 elt = XCHAR_TABLE (table)->contents[charset + 128];
2790 *idx = MAKE_CHAR (charset, 0, 0);
2791 if (!SUB_CHAR_TABLE_P (elt))
2792 return elt;
2793 if (c1 < 32 || NILP (XCHAR_TABLE (elt)->contents[c1]))
2794 return XCHAR_TABLE (elt)->defalt;
2795 elt = XCHAR_TABLE (elt)->contents[c1];
2796 *idx = MAKE_CHAR (charset, c1, 0);
2797 if (!SUB_CHAR_TABLE_P (elt))
2798 return elt;
2799 if (c2 < 32 || NILP (XCHAR_TABLE (elt)->contents[c2]))
2800 return XCHAR_TABLE (elt)->defalt;
2801 *idx = c;
2802 return XCHAR_TABLE (elt)->contents[c2];
2806 /* ARGSUSED */
2807 Lisp_Object
2808 nconc2 (s1, s2)
2809 Lisp_Object s1, s2;
2811 #ifdef NO_ARG_ARRAY
2812 Lisp_Object args[2];
2813 args[0] = s1;
2814 args[1] = s2;
2815 return Fnconc (2, args);
2816 #else
2817 return Fnconc (2, &s1);
2818 #endif /* NO_ARG_ARRAY */
2821 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2822 doc: /* Concatenate any number of lists by altering them.
2823 Only the last argument is not altered, and need not be a list.
2824 usage: (nconc &rest LISTS) */)
2825 (nargs, args)
2826 int nargs;
2827 Lisp_Object *args;
2829 register int argnum;
2830 register Lisp_Object tail, tem, val;
2832 val = tail = Qnil;
2834 for (argnum = 0; argnum < nargs; argnum++)
2836 tem = args[argnum];
2837 if (NILP (tem)) continue;
2839 if (NILP (val))
2840 val = tem;
2842 if (argnum + 1 == nargs) break;
2844 if (!CONSP (tem))
2845 tem = wrong_type_argument (Qlistp, tem);
2847 while (CONSP (tem))
2849 tail = tem;
2850 tem = XCDR (tail);
2851 QUIT;
2854 tem = args[argnum + 1];
2855 Fsetcdr (tail, tem);
2856 if (NILP (tem))
2857 args[argnum + 1] = tail;
2860 return val;
2863 /* This is the guts of all mapping functions.
2864 Apply FN to each element of SEQ, one by one,
2865 storing the results into elements of VALS, a C vector of Lisp_Objects.
2866 LENI is the length of VALS, which should also be the length of SEQ. */
2868 static void
2869 mapcar1 (leni, vals, fn, seq)
2870 int leni;
2871 Lisp_Object *vals;
2872 Lisp_Object fn, seq;
2874 register Lisp_Object tail;
2875 Lisp_Object dummy;
2876 register int i;
2877 struct gcpro gcpro1, gcpro2, gcpro3;
2879 if (vals)
2881 /* Don't let vals contain any garbage when GC happens. */
2882 for (i = 0; i < leni; i++)
2883 vals[i] = Qnil;
2885 GCPRO3 (dummy, fn, seq);
2886 gcpro1.var = vals;
2887 gcpro1.nvars = leni;
2889 else
2890 GCPRO2 (fn, seq);
2891 /* We need not explicitly protect `tail' because it is used only on lists, and
2892 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2894 if (VECTORP (seq))
2896 for (i = 0; i < leni; i++)
2898 dummy = XVECTOR (seq)->contents[i];
2899 dummy = call1 (fn, dummy);
2900 if (vals)
2901 vals[i] = dummy;
2904 else if (BOOL_VECTOR_P (seq))
2906 for (i = 0; i < leni; i++)
2908 int byte;
2909 byte = XBOOL_VECTOR (seq)->data[i / BITS_PER_CHAR];
2910 if (byte & (1 << (i % BITS_PER_CHAR)))
2911 dummy = Qt;
2912 else
2913 dummy = Qnil;
2915 dummy = call1 (fn, dummy);
2916 if (vals)
2917 vals[i] = dummy;
2920 else if (STRINGP (seq))
2922 int i_byte;
2924 for (i = 0, i_byte = 0; i < leni;)
2926 int c;
2927 int i_before = i;
2929 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2930 XSETFASTINT (dummy, c);
2931 dummy = call1 (fn, dummy);
2932 if (vals)
2933 vals[i_before] = dummy;
2936 else /* Must be a list, since Flength did not get an error */
2938 tail = seq;
2939 for (i = 0; i < leni; i++)
2941 dummy = call1 (fn, Fcar (tail));
2942 if (vals)
2943 vals[i] = dummy;
2944 tail = XCDR (tail);
2948 UNGCPRO;
2951 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2952 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2953 In between each pair of results, stick in SEPARATOR. Thus, " " as
2954 SEPARATOR results in spaces between the values returned by FUNCTION.
2955 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2956 (function, sequence, separator)
2957 Lisp_Object function, sequence, separator;
2959 Lisp_Object len;
2960 register int leni;
2961 int nargs;
2962 register Lisp_Object *args;
2963 register int i;
2964 struct gcpro gcpro1;
2966 len = Flength (sequence);
2967 leni = XINT (len);
2968 nargs = leni + leni - 1;
2969 if (nargs < 0) return build_string ("");
2971 args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
2973 GCPRO1 (separator);
2974 mapcar1 (leni, args, function, sequence);
2975 UNGCPRO;
2977 for (i = leni - 1; i >= 0; i--)
2978 args[i + i] = args[i];
2980 for (i = 1; i < nargs; i += 2)
2981 args[i] = separator;
2983 return Fconcat (nargs, args);
2986 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2987 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2988 The result is a list just as long as SEQUENCE.
2989 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2990 (function, sequence)
2991 Lisp_Object function, sequence;
2993 register Lisp_Object len;
2994 register int leni;
2995 register Lisp_Object *args;
2997 len = Flength (sequence);
2998 leni = XFASTINT (len);
2999 args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
3001 mapcar1 (leni, args, function, sequence);
3003 return Flist (leni, args);
3006 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
3007 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3008 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3009 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3010 (function, sequence)
3011 Lisp_Object function, sequence;
3013 register int leni;
3015 leni = XFASTINT (Flength (sequence));
3016 mapcar1 (leni, 0, function, sequence);
3018 return sequence;
3021 /* Anything that calls this function must protect from GC! */
3023 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
3024 doc: /* Ask user a "y or n" question. Return t if answer is "y".
3025 Takes one argument, which is the string to display to ask the question.
3026 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3027 No confirmation of the answer is requested; a single character is enough.
3028 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3029 the bindings in `query-replace-map'; see the documentation of that variable
3030 for more information. In this case, the useful bindings are `act', `skip',
3031 `recenter', and `quit'.\)
3033 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3034 is nil and `use-dialog-box' is non-nil. */)
3035 (prompt)
3036 Lisp_Object prompt;
3038 register Lisp_Object obj, key, def, map;
3039 register int answer;
3040 Lisp_Object xprompt;
3041 Lisp_Object args[2];
3042 struct gcpro gcpro1, gcpro2;
3043 int count = SPECPDL_INDEX ();
3045 specbind (Qcursor_in_echo_area, Qt);
3047 map = Fsymbol_value (intern ("query-replace-map"));
3049 CHECK_STRING (prompt);
3050 xprompt = prompt;
3051 GCPRO2 (prompt, xprompt);
3053 #ifdef HAVE_X_WINDOWS
3054 if (display_hourglass_p)
3055 cancel_hourglass ();
3056 #endif
3058 while (1)
3061 #ifdef HAVE_MENUS
3062 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3063 && use_dialog_box
3064 && have_menus_p ())
3066 Lisp_Object pane, menu;
3067 redisplay_preserve_echo_area (3);
3068 pane = Fcons (Fcons (build_string ("Yes"), Qt),
3069 Fcons (Fcons (build_string ("No"), Qnil),
3070 Qnil));
3071 menu = Fcons (prompt, pane);
3072 obj = Fx_popup_dialog (Qt, menu);
3073 answer = !NILP (obj);
3074 break;
3076 #endif /* HAVE_MENUS */
3077 cursor_in_echo_area = 1;
3078 choose_minibuf_frame ();
3081 Lisp_Object pargs[3];
3083 /* Colorize prompt according to `minibuffer-prompt' face. */
3084 pargs[0] = build_string ("%s(y or n) ");
3085 pargs[1] = intern ("face");
3086 pargs[2] = intern ("minibuffer-prompt");
3087 args[0] = Fpropertize (3, pargs);
3088 args[1] = xprompt;
3089 Fmessage (2, args);
3092 if (minibuffer_auto_raise)
3094 Lisp_Object mini_frame;
3096 mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
3098 Fraise_frame (mini_frame);
3101 obj = read_filtered_event (1, 0, 0, 0);
3102 cursor_in_echo_area = 0;
3103 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3104 QUIT;
3106 key = Fmake_vector (make_number (1), obj);
3107 def = Flookup_key (map, key, Qt);
3109 if (EQ (def, intern ("skip")))
3111 answer = 0;
3112 break;
3114 else if (EQ (def, intern ("act")))
3116 answer = 1;
3117 break;
3119 else if (EQ (def, intern ("recenter")))
3121 Frecenter (Qnil);
3122 xprompt = prompt;
3123 continue;
3125 else if (EQ (def, intern ("quit")))
3126 Vquit_flag = Qt;
3127 /* We want to exit this command for exit-prefix,
3128 and this is the only way to do it. */
3129 else if (EQ (def, intern ("exit-prefix")))
3130 Vquit_flag = Qt;
3132 QUIT;
3134 /* If we don't clear this, then the next call to read_char will
3135 return quit_char again, and we'll enter an infinite loop. */
3136 Vquit_flag = Qnil;
3138 Fding (Qnil);
3139 Fdiscard_input ();
3140 if (EQ (xprompt, prompt))
3142 args[0] = build_string ("Please answer y or n. ");
3143 args[1] = prompt;
3144 xprompt = Fconcat (2, args);
3147 UNGCPRO;
3149 if (! noninteractive)
3151 cursor_in_echo_area = -1;
3152 message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n",
3153 xprompt, 0);
3156 unbind_to (count, Qnil);
3157 return answer ? Qt : Qnil;
3160 /* This is how C code calls `yes-or-no-p' and allows the user
3161 to redefined it.
3163 Anything that calls this function must protect from GC! */
3165 Lisp_Object
3166 do_yes_or_no_p (prompt)
3167 Lisp_Object prompt;
3169 return call1 (intern ("yes-or-no-p"), prompt);
3172 /* Anything that calls this function must protect from GC! */
3174 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
3175 doc: /* Ask user a yes-or-no question. Return t if answer is yes.
3176 Takes one argument, which is the string to display to ask the question.
3177 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3178 The user must confirm the answer with RET,
3179 and can edit it until it has been confirmed.
3181 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3182 is nil, and `use-dialog-box' is non-nil. */)
3183 (prompt)
3184 Lisp_Object prompt;
3186 register Lisp_Object ans;
3187 Lisp_Object args[2];
3188 struct gcpro gcpro1;
3190 CHECK_STRING (prompt);
3192 #ifdef HAVE_MENUS
3193 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3194 && use_dialog_box
3195 && have_menus_p ())
3197 Lisp_Object pane, menu, obj;
3198 redisplay_preserve_echo_area (4);
3199 pane = Fcons (Fcons (build_string ("Yes"), Qt),
3200 Fcons (Fcons (build_string ("No"), Qnil),
3201 Qnil));
3202 GCPRO1 (pane);
3203 menu = Fcons (prompt, pane);
3204 obj = Fx_popup_dialog (Qt, menu);
3205 UNGCPRO;
3206 return obj;
3208 #endif /* HAVE_MENUS */
3210 args[0] = prompt;
3211 args[1] = build_string ("(yes or no) ");
3212 prompt = Fconcat (2, args);
3214 GCPRO1 (prompt);
3216 while (1)
3218 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
3219 Qyes_or_no_p_history, Qnil,
3220 Qnil));
3221 if (SCHARS (ans) == 3 && !strcmp (SDATA (ans), "yes"))
3223 UNGCPRO;
3224 return Qt;
3226 if (SCHARS (ans) == 2 && !strcmp (SDATA (ans), "no"))
3228 UNGCPRO;
3229 return Qnil;
3232 Fding (Qnil);
3233 Fdiscard_input ();
3234 message ("Please answer yes or no.");
3235 Fsleep_for (make_number (2), Qnil);
3239 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
3240 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3242 Each of the three load averages is multiplied by 100, then converted
3243 to integer.
3245 When USE-FLOATS is non-nil, floats will be used instead of integers.
3246 These floats are not multiplied by 100.
3248 If the 5-minute or 15-minute load averages are not available, return a
3249 shortened list, containing only those averages which are available.
3251 An error is thrown if the load average can't be obtained. In some
3252 cases making it work would require Emacs being installed setuid or
3253 setgid so that it can read kernel information, and that usually isn't
3254 advisable. */)
3255 (use_floats)
3256 Lisp_Object use_floats;
3258 double load_ave[3];
3259 int loads = getloadavg (load_ave, 3);
3260 Lisp_Object ret = Qnil;
3262 if (loads < 0)
3263 error ("load-average not implemented for this operating system");
3265 while (loads-- > 0)
3267 Lisp_Object load = (NILP (use_floats) ?
3268 make_number ((int) (100.0 * load_ave[loads]))
3269 : make_float (load_ave[loads]));
3270 ret = Fcons (load, ret);
3273 return ret;
3276 Lisp_Object Vfeatures, Qsubfeatures;
3277 extern Lisp_Object Vafter_load_alist;
3279 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
3280 doc: /* Returns t if FEATURE is present in this Emacs.
3282 Use this to conditionalize execution of lisp code based on the
3283 presence or absence of emacs or environment extensions.
3284 Use `provide' to declare that a feature is available. This function
3285 looks at the value of the variable `features'. The optional argument
3286 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3287 (feature, subfeature)
3288 Lisp_Object feature, subfeature;
3290 register Lisp_Object tem;
3291 CHECK_SYMBOL (feature);
3292 tem = Fmemq (feature, Vfeatures);
3293 if (!NILP (tem) && !NILP (subfeature))
3294 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
3295 return (NILP (tem)) ? Qnil : Qt;
3298 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
3299 doc: /* Announce that FEATURE is a feature of the current Emacs.
3300 The optional argument SUBFEATURES should be a list of symbols listing
3301 particular subfeatures supported in this version of FEATURE. */)
3302 (feature, subfeatures)
3303 Lisp_Object feature, subfeatures;
3305 register Lisp_Object tem;
3306 CHECK_SYMBOL (feature);
3307 CHECK_LIST (subfeatures);
3308 if (!NILP (Vautoload_queue))
3309 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3310 tem = Fmemq (feature, Vfeatures);
3311 if (NILP (tem))
3312 Vfeatures = Fcons (feature, Vfeatures);
3313 if (!NILP (subfeatures))
3314 Fput (feature, Qsubfeatures, subfeatures);
3315 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3317 /* Run any load-hooks for this file. */
3318 tem = Fassq (feature, Vafter_load_alist);
3319 if (CONSP (tem))
3320 Fprogn (XCDR (tem));
3322 return feature;
3325 /* `require' and its subroutines. */
3327 /* List of features currently being require'd, innermost first. */
3329 Lisp_Object require_nesting_list;
3331 Lisp_Object
3332 require_unwind (old_value)
3333 Lisp_Object old_value;
3335 return require_nesting_list = old_value;
3338 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
3339 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
3340 If FEATURE is not a member of the list `features', then the feature
3341 is not loaded; so load the file FILENAME.
3342 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3343 and `load' will try to load this name appended with the suffix `.elc' or
3344 `.el', in that order. The name without appended suffix will not be used.
3345 If the optional third argument NOERROR is non-nil,
3346 then return nil if the file is not found instead of signaling an error.
3347 Normally the return value is FEATURE.
3348 The normal messages at start and end of loading FILENAME are suppressed. */)
3349 (feature, filename, noerror)
3350 Lisp_Object feature, filename, noerror;
3352 register Lisp_Object tem;
3353 struct gcpro gcpro1, gcpro2;
3355 CHECK_SYMBOL (feature);
3357 tem = Fmemq (feature, Vfeatures);
3359 if (NILP (tem))
3361 int count = SPECPDL_INDEX ();
3362 int nesting = 0;
3364 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3366 /* This is to make sure that loadup.el gives a clear picture
3367 of what files are preloaded and when. */
3368 if (! NILP (Vpurify_flag))
3369 error ("(require %s) while preparing to dump",
3370 SDATA (SYMBOL_NAME (feature)));
3372 /* A certain amount of recursive `require' is legitimate,
3373 but if we require the same feature recursively 3 times,
3374 signal an error. */
3375 tem = require_nesting_list;
3376 while (! NILP (tem))
3378 if (! NILP (Fequal (feature, XCAR (tem))))
3379 nesting++;
3380 tem = XCDR (tem);
3382 if (nesting > 3)
3383 error ("Recursive `require' for feature `%s'",
3384 SDATA (SYMBOL_NAME (feature)));
3386 /* Update the list for any nested `require's that occur. */
3387 record_unwind_protect (require_unwind, require_nesting_list);
3388 require_nesting_list = Fcons (feature, require_nesting_list);
3390 /* Value saved here is to be restored into Vautoload_queue */
3391 record_unwind_protect (un_autoload, Vautoload_queue);
3392 Vautoload_queue = Qt;
3394 /* Load the file. */
3395 GCPRO2 (feature, filename);
3396 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
3397 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
3398 UNGCPRO;
3400 /* If load failed entirely, return nil. */
3401 if (NILP (tem))
3402 return unbind_to (count, Qnil);
3404 tem = Fmemq (feature, Vfeatures);
3405 if (NILP (tem))
3406 error ("Required feature `%s' was not provided",
3407 SDATA (SYMBOL_NAME (feature)));
3409 /* Once loading finishes, don't undo it. */
3410 Vautoload_queue = Qt;
3411 feature = unbind_to (count, feature);
3414 return feature;
3417 /* Primitives for work of the "widget" library.
3418 In an ideal world, this section would not have been necessary.
3419 However, lisp function calls being as slow as they are, it turns
3420 out that some functions in the widget library (wid-edit.el) are the
3421 bottleneck of Widget operation. Here is their translation to C,
3422 for the sole reason of efficiency. */
3424 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
3425 doc: /* Return non-nil if PLIST has the property PROP.
3426 PLIST is a property list, which is a list of the form
3427 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3428 Unlike `plist-get', this allows you to distinguish between a missing
3429 property and a property with the value nil.
3430 The value is actually the tail of PLIST whose car is PROP. */)
3431 (plist, prop)
3432 Lisp_Object plist, prop;
3434 while (CONSP (plist) && !EQ (XCAR (plist), prop))
3436 QUIT;
3437 plist = XCDR (plist);
3438 plist = CDR (plist);
3440 return plist;
3443 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
3444 doc: /* In WIDGET, set PROPERTY to VALUE.
3445 The value can later be retrieved with `widget-get'. */)
3446 (widget, property, value)
3447 Lisp_Object widget, property, value;
3449 CHECK_CONS (widget);
3450 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
3451 return value;
3454 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
3455 doc: /* In WIDGET, get the value of PROPERTY.
3456 The value could either be specified when the widget was created, or
3457 later with `widget-put'. */)
3458 (widget, property)
3459 Lisp_Object widget, property;
3461 Lisp_Object tmp;
3463 while (1)
3465 if (NILP (widget))
3466 return Qnil;
3467 CHECK_CONS (widget);
3468 tmp = Fplist_member (XCDR (widget), property);
3469 if (CONSP (tmp))
3471 tmp = XCDR (tmp);
3472 return CAR (tmp);
3474 tmp = XCAR (widget);
3475 if (NILP (tmp))
3476 return Qnil;
3477 widget = Fget (tmp, Qwidget_type);
3481 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
3482 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3483 ARGS are passed as extra arguments to the function.
3484 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3485 (nargs, args)
3486 int nargs;
3487 Lisp_Object *args;
3489 /* This function can GC. */
3490 Lisp_Object newargs[3];
3491 struct gcpro gcpro1, gcpro2;
3492 Lisp_Object result;
3494 newargs[0] = Fwidget_get (args[0], args[1]);
3495 newargs[1] = args[0];
3496 newargs[2] = Flist (nargs - 2, args + 2);
3497 GCPRO2 (newargs[0], newargs[2]);
3498 result = Fapply (3, newargs);
3499 UNGCPRO;
3500 return result;
3503 #ifdef HAVE_LANGINFO_CODESET
3504 #include <langinfo.h>
3505 #endif
3507 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
3508 doc: /* Access locale data ITEM for the current C locale, if available.
3509 ITEM should be one of the following:
3511 `codeset', returning the character set as a string (locale item CODESET);
3513 `days', returning a 7-element vector of day names (locale items DAY_n);
3515 `months', returning a 12-element vector of month names (locale items MON_n);
3517 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3518 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3520 If the system can't provide such information through a call to
3521 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3523 See also Info node `(libc)Locales'.
3525 The data read from the system are decoded using `locale-coding-system'. */)
3526 (item)
3527 Lisp_Object item;
3529 char *str = NULL;
3530 #ifdef HAVE_LANGINFO_CODESET
3531 Lisp_Object val;
3532 if (EQ (item, Qcodeset))
3534 str = nl_langinfo (CODESET);
3535 return build_string (str);
3537 #ifdef DAY_1
3538 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
3540 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
3541 int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
3542 int i;
3543 synchronize_system_time_locale ();
3544 for (i = 0; i < 7; i++)
3546 str = nl_langinfo (days[i]);
3547 val = make_unibyte_string (str, strlen (str));
3548 /* Fixme: Is this coding system necessarily right, even if
3549 it is consistent with CODESET? If not, what to do? */
3550 Faset (v, make_number (i),
3551 code_convert_string_norecord (val, Vlocale_coding_system,
3552 0));
3554 return v;
3556 #endif /* DAY_1 */
3557 #ifdef MON_1
3558 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
3560 struct Lisp_Vector *p = allocate_vector (12);
3561 int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
3562 MON_8, MON_9, MON_10, MON_11, MON_12};
3563 int i;
3564 synchronize_system_time_locale ();
3565 for (i = 0; i < 12; i++)
3567 str = nl_langinfo (months[i]);
3568 val = make_unibyte_string (str, strlen (str));
3569 p->contents[i] =
3570 code_convert_string_norecord (val, Vlocale_coding_system, 0);
3572 XSETVECTOR (val, p);
3573 return val;
3575 #endif /* MON_1 */
3576 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3577 but is in the locale files. This could be used by ps-print. */
3578 #ifdef PAPER_WIDTH
3579 else if (EQ (item, Qpaper))
3581 return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
3582 make_number (nl_langinfo (PAPER_HEIGHT)));
3584 #endif /* PAPER_WIDTH */
3585 #endif /* HAVE_LANGINFO_CODESET*/
3586 return Qnil;
3589 /* base64 encode/decode functions (RFC 2045).
3590 Based on code from GNU recode. */
3592 #define MIME_LINE_LENGTH 76
3594 #define IS_ASCII(Character) \
3595 ((Character) < 128)
3596 #define IS_BASE64(Character) \
3597 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3598 #define IS_BASE64_IGNORABLE(Character) \
3599 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3600 || (Character) == '\f' || (Character) == '\r')
3602 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3603 character or return retval if there are no characters left to
3604 process. */
3605 #define READ_QUADRUPLET_BYTE(retval) \
3606 do \
3608 if (i == length) \
3610 if (nchars_return) \
3611 *nchars_return = nchars; \
3612 return (retval); \
3614 c = from[i++]; \
3616 while (IS_BASE64_IGNORABLE (c))
3618 /* Don't use alloca for regions larger than this, lest we overflow
3619 their stack. */
3620 #define MAX_ALLOCA 16*1024
3622 /* Table of characters coding the 64 values. */
3623 static char base64_value_to_char[64] =
3625 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3626 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3627 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3628 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3629 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3630 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3631 '8', '9', '+', '/' /* 60-63 */
3634 /* Table of base64 values for first 128 characters. */
3635 static short base64_char_to_value[128] =
3637 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3638 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3639 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3640 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3641 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3642 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3643 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3644 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3645 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3646 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3647 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3648 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3649 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3652 /* The following diagram shows the logical steps by which three octets
3653 get transformed into four base64 characters.
3655 .--------. .--------. .--------.
3656 |aaaaaabb| |bbbbcccc| |ccdddddd|
3657 `--------' `--------' `--------'
3658 6 2 4 4 2 6
3659 .--------+--------+--------+--------.
3660 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3661 `--------+--------+--------+--------'
3663 .--------+--------+--------+--------.
3664 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3665 `--------+--------+--------+--------'
3667 The octets are divided into 6 bit chunks, which are then encoded into
3668 base64 characters. */
3671 static int base64_encode_1 P_ ((const char *, char *, int, int, int));
3672 static int base64_decode_1 P_ ((const char *, char *, int, int, int *));
3674 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3675 2, 3, "r",
3676 doc: /* Base64-encode the region between BEG and END.
3677 Return the length of the encoded text.
3678 Optional third argument NO-LINE-BREAK means do not break long lines
3679 into shorter lines. */)
3680 (beg, end, no_line_break)
3681 Lisp_Object beg, end, no_line_break;
3683 char *encoded;
3684 int allength, length;
3685 int ibeg, iend, encoded_length;
3686 int old_pos = PT;
3688 validate_region (&beg, &end);
3690 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3691 iend = CHAR_TO_BYTE (XFASTINT (end));
3692 move_gap_both (XFASTINT (beg), ibeg);
3694 /* We need to allocate enough room for encoding the text.
3695 We need 33 1/3% more space, plus a newline every 76
3696 characters, and then we round up. */
3697 length = iend - ibeg;
3698 allength = length + length/3 + 1;
3699 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3701 if (allength <= MAX_ALLOCA)
3702 encoded = (char *) alloca (allength);
3703 else
3704 encoded = (char *) xmalloc (allength);
3705 encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
3706 NILP (no_line_break),
3707 !NILP (current_buffer->enable_multibyte_characters));
3708 if (encoded_length > allength)
3709 abort ();
3711 if (encoded_length < 0)
3713 /* The encoding wasn't possible. */
3714 if (length > MAX_ALLOCA)
3715 xfree (encoded);
3716 error ("Multibyte character in data for base64 encoding");
3719 /* Now we have encoded the region, so we insert the new contents
3720 and delete the old. (Insert first in order to preserve markers.) */
3721 SET_PT_BOTH (XFASTINT (beg), ibeg);
3722 insert (encoded, encoded_length);
3723 if (allength > MAX_ALLOCA)
3724 xfree (encoded);
3725 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3727 /* If point was outside of the region, restore it exactly; else just
3728 move to the beginning of the region. */
3729 if (old_pos >= XFASTINT (end))
3730 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3731 else if (old_pos > XFASTINT (beg))
3732 old_pos = XFASTINT (beg);
3733 SET_PT (old_pos);
3735 /* We return the length of the encoded text. */
3736 return make_number (encoded_length);
3739 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3740 1, 2, 0,
3741 doc: /* Base64-encode STRING and return the result.
3742 Optional second argument NO-LINE-BREAK means do not break long lines
3743 into shorter lines. */)
3744 (string, no_line_break)
3745 Lisp_Object string, no_line_break;
3747 int allength, length, encoded_length;
3748 char *encoded;
3749 Lisp_Object encoded_string;
3751 CHECK_STRING (string);
3753 /* We need to allocate enough room for encoding the text.
3754 We need 33 1/3% more space, plus a newline every 76
3755 characters, and then we round up. */
3756 length = SBYTES (string);
3757 allength = length + length/3 + 1;
3758 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3760 /* We need to allocate enough room for decoding the text. */
3761 if (allength <= MAX_ALLOCA)
3762 encoded = (char *) alloca (allength);
3763 else
3764 encoded = (char *) xmalloc (allength);
3766 encoded_length = base64_encode_1 (SDATA (string),
3767 encoded, length, NILP (no_line_break),
3768 STRING_MULTIBYTE (string));
3769 if (encoded_length > allength)
3770 abort ();
3772 if (encoded_length < 0)
3774 /* The encoding wasn't possible. */
3775 if (length > MAX_ALLOCA)
3776 xfree (encoded);
3777 error ("Multibyte character in data for base64 encoding");
3780 encoded_string = make_unibyte_string (encoded, encoded_length);
3781 if (allength > MAX_ALLOCA)
3782 xfree (encoded);
3784 return encoded_string;
3787 static int
3788 base64_encode_1 (from, to, length, line_break, multibyte)
3789 const char *from;
3790 char *to;
3791 int length;
3792 int line_break;
3793 int multibyte;
3795 int counter = 0, i = 0;
3796 char *e = to;
3797 int c;
3798 unsigned int value;
3799 int bytes;
3801 while (i < length)
3803 if (multibyte)
3805 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3806 if (c >= 256)
3807 return -1;
3808 i += bytes;
3810 else
3811 c = from[i++];
3813 /* Wrap line every 76 characters. */
3815 if (line_break)
3817 if (counter < MIME_LINE_LENGTH / 4)
3818 counter++;
3819 else
3821 *e++ = '\n';
3822 counter = 1;
3826 /* Process first byte of a triplet. */
3828 *e++ = base64_value_to_char[0x3f & c >> 2];
3829 value = (0x03 & c) << 4;
3831 /* Process second byte of a triplet. */
3833 if (i == length)
3835 *e++ = base64_value_to_char[value];
3836 *e++ = '=';
3837 *e++ = '=';
3838 break;
3841 if (multibyte)
3843 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3844 if (c >= 256)
3845 return -1;
3846 i += bytes;
3848 else
3849 c = from[i++];
3851 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3852 value = (0x0f & c) << 2;
3854 /* Process third byte of a triplet. */
3856 if (i == length)
3858 *e++ = base64_value_to_char[value];
3859 *e++ = '=';
3860 break;
3863 if (multibyte)
3865 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
3866 if (c >= 256)
3867 return -1;
3868 i += bytes;
3870 else
3871 c = from[i++];
3873 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3874 *e++ = base64_value_to_char[0x3f & c];
3877 return e - to;
3881 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3882 2, 2, "r",
3883 doc: /* Base64-decode the region between BEG and END.
3884 Return the length of the decoded text.
3885 If the region can't be decoded, signal an error and don't modify the buffer. */)
3886 (beg, end)
3887 Lisp_Object beg, end;
3889 int ibeg, iend, length, allength;
3890 char *decoded;
3891 int old_pos = PT;
3892 int decoded_length;
3893 int inserted_chars;
3894 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
3896 validate_region (&beg, &end);
3898 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3899 iend = CHAR_TO_BYTE (XFASTINT (end));
3901 length = iend - ibeg;
3903 /* We need to allocate enough room for decoding the text. If we are
3904 working on a multibyte buffer, each decoded code may occupy at
3905 most two bytes. */
3906 allength = multibyte ? length * 2 : length;
3907 if (allength <= MAX_ALLOCA)
3908 decoded = (char *) alloca (allength);
3909 else
3910 decoded = (char *) xmalloc (allength);
3912 move_gap_both (XFASTINT (beg), ibeg);
3913 decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
3914 multibyte, &inserted_chars);
3915 if (decoded_length > allength)
3916 abort ();
3918 if (decoded_length < 0)
3920 /* The decoding wasn't possible. */
3921 if (allength > MAX_ALLOCA)
3922 xfree (decoded);
3923 error ("Invalid base64 data");
3926 /* Now we have decoded the region, so we insert the new contents
3927 and delete the old. (Insert first in order to preserve markers.) */
3928 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3929 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3930 if (allength > MAX_ALLOCA)
3931 xfree (decoded);
3932 /* Delete the original text. */
3933 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3934 iend + decoded_length, 1);
3936 /* If point was outside of the region, restore it exactly; else just
3937 move to the beginning of the region. */
3938 if (old_pos >= XFASTINT (end))
3939 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3940 else if (old_pos > XFASTINT (beg))
3941 old_pos = XFASTINT (beg);
3942 SET_PT (old_pos > ZV ? ZV : old_pos);
3944 return make_number (inserted_chars);
3947 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3948 1, 1, 0,
3949 doc: /* Base64-decode STRING and return the result. */)
3950 (string)
3951 Lisp_Object string;
3953 char *decoded;
3954 int length, decoded_length;
3955 Lisp_Object decoded_string;
3957 CHECK_STRING (string);
3959 length = SBYTES (string);
3960 /* We need to allocate enough room for decoding the text. */
3961 if (length <= MAX_ALLOCA)
3962 decoded = (char *) alloca (length);
3963 else
3964 decoded = (char *) xmalloc (length);
3966 /* The decoded result should be unibyte. */
3967 decoded_length = base64_decode_1 (SDATA (string), decoded, length,
3968 0, NULL);
3969 if (decoded_length > length)
3970 abort ();
3971 else if (decoded_length >= 0)
3972 decoded_string = make_unibyte_string (decoded, decoded_length);
3973 else
3974 decoded_string = Qnil;
3976 if (length > MAX_ALLOCA)
3977 xfree (decoded);
3978 if (!STRINGP (decoded_string))
3979 error ("Invalid base64 data");
3981 return decoded_string;
3984 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3985 MULTIBYTE is nonzero, the decoded result should be in multibyte
3986 form. If NCHARS_RETRUN is not NULL, store the number of produced
3987 characters in *NCHARS_RETURN. */
3989 static int
3990 base64_decode_1 (from, to, length, multibyte, nchars_return)
3991 const char *from;
3992 char *to;
3993 int length;
3994 int multibyte;
3995 int *nchars_return;
3997 int i = 0;
3998 char *e = to;
3999 unsigned char c;
4000 unsigned long value;
4001 int nchars = 0;
4003 while (1)
4005 /* Process first byte of a quadruplet. */
4007 READ_QUADRUPLET_BYTE (e-to);
4009 if (!IS_BASE64 (c))
4010 return -1;
4011 value = base64_char_to_value[c] << 18;
4013 /* Process second byte of a quadruplet. */
4015 READ_QUADRUPLET_BYTE (-1);
4017 if (!IS_BASE64 (c))
4018 return -1;
4019 value |= base64_char_to_value[c] << 12;
4021 c = (unsigned char) (value >> 16);
4022 if (multibyte)
4023 e += CHAR_STRING (c, e);
4024 else
4025 *e++ = c;
4026 nchars++;
4028 /* Process third byte of a quadruplet. */
4030 READ_QUADRUPLET_BYTE (-1);
4032 if (c == '=')
4034 READ_QUADRUPLET_BYTE (-1);
4036 if (c != '=')
4037 return -1;
4038 continue;
4041 if (!IS_BASE64 (c))
4042 return -1;
4043 value |= base64_char_to_value[c] << 6;
4045 c = (unsigned char) (0xff & value >> 8);
4046 if (multibyte)
4047 e += CHAR_STRING (c, e);
4048 else
4049 *e++ = c;
4050 nchars++;
4052 /* Process fourth byte of a quadruplet. */
4054 READ_QUADRUPLET_BYTE (-1);
4056 if (c == '=')
4057 continue;
4059 if (!IS_BASE64 (c))
4060 return -1;
4061 value |= base64_char_to_value[c];
4063 c = (unsigned char) (0xff & value);
4064 if (multibyte)
4065 e += CHAR_STRING (c, e);
4066 else
4067 *e++ = c;
4068 nchars++;
4074 /***********************************************************************
4075 ***** *****
4076 ***** Hash Tables *****
4077 ***** *****
4078 ***********************************************************************/
4080 /* Implemented by gerd@gnu.org. This hash table implementation was
4081 inspired by CMUCL hash tables. */
4083 /* Ideas:
4085 1. For small tables, association lists are probably faster than
4086 hash tables because they have lower overhead.
4088 For uses of hash tables where the O(1) behavior of table
4089 operations is not a requirement, it might therefore be a good idea
4090 not to hash. Instead, we could just do a linear search in the
4091 key_and_value vector of the hash table. This could be done
4092 if a `:linear-search t' argument is given to make-hash-table. */
4095 /* The list of all weak hash tables. Don't staticpro this one. */
4097 Lisp_Object Vweak_hash_tables;
4099 /* Various symbols. */
4101 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
4102 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
4103 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
4105 /* Function prototypes. */
4107 static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object));
4108 static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *));
4109 static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *));
4110 static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
4111 Lisp_Object, unsigned));
4112 static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
4113 Lisp_Object, unsigned));
4114 static int cmpfn_user_defined P_ ((struct Lisp_Hash_Table *, Lisp_Object,
4115 unsigned, Lisp_Object, unsigned));
4116 static unsigned hashfn_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object));
4117 static unsigned hashfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object));
4118 static unsigned hashfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object));
4119 static unsigned hashfn_user_defined P_ ((struct Lisp_Hash_Table *,
4120 Lisp_Object));
4121 static unsigned sxhash_string P_ ((unsigned char *, int));
4122 static unsigned sxhash_list P_ ((Lisp_Object, int));
4123 static unsigned sxhash_vector P_ ((Lisp_Object, int));
4124 static unsigned sxhash_bool_vector P_ ((Lisp_Object));
4125 static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int));
4129 /***********************************************************************
4130 Utilities
4131 ***********************************************************************/
4133 /* If OBJ is a Lisp hash table, return a pointer to its struct
4134 Lisp_Hash_Table. Otherwise, signal an error. */
4136 static struct Lisp_Hash_Table *
4137 check_hash_table (obj)
4138 Lisp_Object obj;
4140 CHECK_HASH_TABLE (obj);
4141 return XHASH_TABLE (obj);
4145 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4146 number. */
4149 next_almost_prime (n)
4150 int n;
4152 if (n % 2 == 0)
4153 n += 1;
4154 if (n % 3 == 0)
4155 n += 2;
4156 if (n % 7 == 0)
4157 n += 4;
4158 return n;
4162 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4163 which USED[I] is non-zero. If found at index I in ARGS, set
4164 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4165 -1. This function is used to extract a keyword/argument pair from
4166 a DEFUN parameter list. */
4168 static int
4169 get_key_arg (key, nargs, args, used)
4170 Lisp_Object key;
4171 int nargs;
4172 Lisp_Object *args;
4173 char *used;
4175 int i;
4177 for (i = 0; i < nargs - 1; ++i)
4178 if (!used[i] && EQ (args[i], key))
4179 break;
4181 if (i >= nargs - 1)
4182 i = -1;
4183 else
4185 used[i++] = 1;
4186 used[i] = 1;
4189 return i;
4193 /* Return a Lisp vector which has the same contents as VEC but has
4194 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4195 vector that are not copied from VEC are set to INIT. */
4197 Lisp_Object
4198 larger_vector (vec, new_size, init)
4199 Lisp_Object vec;
4200 int new_size;
4201 Lisp_Object init;
4203 struct Lisp_Vector *v;
4204 int i, old_size;
4206 xassert (VECTORP (vec));
4207 old_size = XVECTOR (vec)->size;
4208 xassert (new_size >= old_size);
4210 v = allocate_vector (new_size);
4211 bcopy (XVECTOR (vec)->contents, v->contents,
4212 old_size * sizeof *v->contents);
4213 for (i = old_size; i < new_size; ++i)
4214 v->contents[i] = init;
4215 XSETVECTOR (vec, v);
4216 return vec;
4220 /***********************************************************************
4221 Low-level Functions
4222 ***********************************************************************/
4224 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4225 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4226 KEY2 are the same. */
4228 static int
4229 cmpfn_eql (h, key1, hash1, key2, hash2)
4230 struct Lisp_Hash_Table *h;
4231 Lisp_Object key1, key2;
4232 unsigned hash1, hash2;
4234 return (FLOATP (key1)
4235 && FLOATP (key2)
4236 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
4240 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4241 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4242 KEY2 are the same. */
4244 static int
4245 cmpfn_equal (h, key1, hash1, key2, hash2)
4246 struct Lisp_Hash_Table *h;
4247 Lisp_Object key1, key2;
4248 unsigned hash1, hash2;
4250 return hash1 == hash2 && !NILP (Fequal (key1, key2));
4254 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4255 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4256 if KEY1 and KEY2 are the same. */
4258 static int
4259 cmpfn_user_defined (h, key1, hash1, key2, hash2)
4260 struct Lisp_Hash_Table *h;
4261 Lisp_Object key1, key2;
4262 unsigned hash1, hash2;
4264 if (hash1 == hash2)
4266 Lisp_Object args[3];
4268 args[0] = h->user_cmp_function;
4269 args[1] = key1;
4270 args[2] = key2;
4271 return !NILP (Ffuncall (3, args));
4273 else
4274 return 0;
4278 /* Value is a hash code for KEY for use in hash table H which uses
4279 `eq' to compare keys. The hash code returned is guaranteed to fit
4280 in a Lisp integer. */
4282 static unsigned
4283 hashfn_eq (h, key)
4284 struct Lisp_Hash_Table *h;
4285 Lisp_Object key;
4287 unsigned hash = XUINT (key) ^ XGCTYPE (key);
4288 xassert ((hash & ~INTMASK) == 0);
4289 return hash;
4293 /* Value is a hash code for KEY for use in hash table H which uses
4294 `eql' to compare keys. The hash code returned is guaranteed to fit
4295 in a Lisp integer. */
4297 static unsigned
4298 hashfn_eql (h, key)
4299 struct Lisp_Hash_Table *h;
4300 Lisp_Object key;
4302 unsigned hash;
4303 if (FLOATP (key))
4304 hash = sxhash (key, 0);
4305 else
4306 hash = XUINT (key) ^ XGCTYPE (key);
4307 xassert ((hash & ~INTMASK) == 0);
4308 return hash;
4312 /* Value is a hash code for KEY for use in hash table H which uses
4313 `equal' to compare keys. The hash code returned is guaranteed to fit
4314 in a Lisp integer. */
4316 static unsigned
4317 hashfn_equal (h, key)
4318 struct Lisp_Hash_Table *h;
4319 Lisp_Object key;
4321 unsigned hash = sxhash (key, 0);
4322 xassert ((hash & ~INTMASK) == 0);
4323 return hash;
4327 /* Value is a hash code for KEY for use in hash table H which uses as
4328 user-defined function to compare keys. The hash code returned is
4329 guaranteed to fit in a Lisp integer. */
4331 static unsigned
4332 hashfn_user_defined (h, key)
4333 struct Lisp_Hash_Table *h;
4334 Lisp_Object key;
4336 Lisp_Object args[2], hash;
4338 args[0] = h->user_hash_function;
4339 args[1] = key;
4340 hash = Ffuncall (2, args);
4341 if (!INTEGERP (hash))
4342 Fsignal (Qerror,
4343 list2 (build_string ("Invalid hash code returned from \
4344 user-supplied hash function"),
4345 hash));
4346 return XUINT (hash);
4350 /* Create and initialize a new hash table.
4352 TEST specifies the test the hash table will use to compare keys.
4353 It must be either one of the predefined tests `eq', `eql' or
4354 `equal' or a symbol denoting a user-defined test named TEST with
4355 test and hash functions USER_TEST and USER_HASH.
4357 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4359 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4360 new size when it becomes full is computed by adding REHASH_SIZE to
4361 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4362 table's new size is computed by multiplying its old size with
4363 REHASH_SIZE.
4365 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4366 be resized when the ratio of (number of entries in the table) /
4367 (table size) is >= REHASH_THRESHOLD.
4369 WEAK specifies the weakness of the table. If non-nil, it must be
4370 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4372 Lisp_Object
4373 make_hash_table (test, size, rehash_size, rehash_threshold, weak,
4374 user_test, user_hash)
4375 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4376 Lisp_Object user_test, user_hash;
4378 struct Lisp_Hash_Table *h;
4379 Lisp_Object table;
4380 int index_size, i, sz;
4382 /* Preconditions. */
4383 xassert (SYMBOLP (test));
4384 xassert (INTEGERP (size) && XINT (size) >= 0);
4385 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
4386 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
4387 xassert (FLOATP (rehash_threshold)
4388 && XFLOATINT (rehash_threshold) > 0
4389 && XFLOATINT (rehash_threshold) <= 1.0);
4391 if (XFASTINT (size) == 0)
4392 size = make_number (1);
4394 /* Allocate a table and initialize it. */
4395 h = allocate_hash_table ();
4397 /* Initialize hash table slots. */
4398 sz = XFASTINT (size);
4400 h->test = test;
4401 if (EQ (test, Qeql))
4403 h->cmpfn = cmpfn_eql;
4404 h->hashfn = hashfn_eql;
4406 else if (EQ (test, Qeq))
4408 h->cmpfn = NULL;
4409 h->hashfn = hashfn_eq;
4411 else if (EQ (test, Qequal))
4413 h->cmpfn = cmpfn_equal;
4414 h->hashfn = hashfn_equal;
4416 else
4418 h->user_cmp_function = user_test;
4419 h->user_hash_function = user_hash;
4420 h->cmpfn = cmpfn_user_defined;
4421 h->hashfn = hashfn_user_defined;
4424 h->weak = weak;
4425 h->rehash_threshold = rehash_threshold;
4426 h->rehash_size = rehash_size;
4427 h->count = make_number (0);
4428 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
4429 h->hash = Fmake_vector (size, Qnil);
4430 h->next = Fmake_vector (size, Qnil);
4431 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4432 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
4433 h->index = Fmake_vector (make_number (index_size), Qnil);
4435 /* Set up the free list. */
4436 for (i = 0; i < sz - 1; ++i)
4437 HASH_NEXT (h, i) = make_number (i + 1);
4438 h->next_free = make_number (0);
4440 XSET_HASH_TABLE (table, h);
4441 xassert (HASH_TABLE_P (table));
4442 xassert (XHASH_TABLE (table) == h);
4444 /* Maybe add this hash table to the list of all weak hash tables. */
4445 if (NILP (h->weak))
4446 h->next_weak = Qnil;
4447 else
4449 h->next_weak = Vweak_hash_tables;
4450 Vweak_hash_tables = table;
4453 return table;
4457 /* Return a copy of hash table H1. Keys and values are not copied,
4458 only the table itself is. */
4460 Lisp_Object
4461 copy_hash_table (h1)
4462 struct Lisp_Hash_Table *h1;
4464 Lisp_Object table;
4465 struct Lisp_Hash_Table *h2;
4466 struct Lisp_Vector *next;
4468 h2 = allocate_hash_table ();
4469 next = h2->vec_next;
4470 bcopy (h1, h2, sizeof *h2);
4471 h2->vec_next = next;
4472 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
4473 h2->hash = Fcopy_sequence (h1->hash);
4474 h2->next = Fcopy_sequence (h1->next);
4475 h2->index = Fcopy_sequence (h1->index);
4476 XSET_HASH_TABLE (table, h2);
4478 /* Maybe add this hash table to the list of all weak hash tables. */
4479 if (!NILP (h2->weak))
4481 h2->next_weak = Vweak_hash_tables;
4482 Vweak_hash_tables = table;
4485 return table;
4489 /* Resize hash table H if it's too full. If H cannot be resized
4490 because it's already too large, throw an error. */
4492 static INLINE void
4493 maybe_resize_hash_table (h)
4494 struct Lisp_Hash_Table *h;
4496 if (NILP (h->next_free))
4498 int old_size = HASH_TABLE_SIZE (h);
4499 int i, new_size, index_size;
4501 if (INTEGERP (h->rehash_size))
4502 new_size = old_size + XFASTINT (h->rehash_size);
4503 else
4504 new_size = old_size * XFLOATINT (h->rehash_size);
4505 new_size = max (old_size + 1, new_size);
4506 index_size = next_almost_prime ((int)
4507 (new_size
4508 / XFLOATINT (h->rehash_threshold)));
4509 if (max (index_size, 2 * new_size) > MOST_POSITIVE_FIXNUM)
4510 error ("Hash table too large to resize");
4512 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
4513 h->next = larger_vector (h->next, new_size, Qnil);
4514 h->hash = larger_vector (h->hash, new_size, Qnil);
4515 h->index = Fmake_vector (make_number (index_size), Qnil);
4517 /* Update the free list. Do it so that new entries are added at
4518 the end of the free list. This makes some operations like
4519 maphash faster. */
4520 for (i = old_size; i < new_size - 1; ++i)
4521 HASH_NEXT (h, i) = make_number (i + 1);
4523 if (!NILP (h->next_free))
4525 Lisp_Object last, next;
4527 last = h->next_free;
4528 while (next = HASH_NEXT (h, XFASTINT (last)),
4529 !NILP (next))
4530 last = next;
4532 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
4534 else
4535 XSETFASTINT (h->next_free, old_size);
4537 /* Rehash. */
4538 for (i = 0; i < old_size; ++i)
4539 if (!NILP (HASH_HASH (h, i)))
4541 unsigned hash_code = XUINT (HASH_HASH (h, i));
4542 int start_of_bucket = hash_code % XVECTOR (h->index)->size;
4543 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4544 HASH_INDEX (h, start_of_bucket) = make_number (i);
4550 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4551 the hash code of KEY. Value is the index of the entry in H
4552 matching KEY, or -1 if not found. */
4555 hash_lookup (h, key, hash)
4556 struct Lisp_Hash_Table *h;
4557 Lisp_Object key;
4558 unsigned *hash;
4560 unsigned hash_code;
4561 int start_of_bucket;
4562 Lisp_Object idx;
4564 hash_code = h->hashfn (h, key);
4565 if (hash)
4566 *hash = hash_code;
4568 start_of_bucket = hash_code % XVECTOR (h->index)->size;
4569 idx = HASH_INDEX (h, start_of_bucket);
4571 /* We need not gcpro idx since it's either an integer or nil. */
4572 while (!NILP (idx))
4574 int i = XFASTINT (idx);
4575 if (EQ (key, HASH_KEY (h, i))
4576 || (h->cmpfn
4577 && h->cmpfn (h, key, hash_code,
4578 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4579 break;
4580 idx = HASH_NEXT (h, i);
4583 return NILP (idx) ? -1 : XFASTINT (idx);
4587 /* Put an entry into hash table H that associates KEY with VALUE.
4588 HASH is a previously computed hash code of KEY.
4589 Value is the index of the entry in H matching KEY. */
4592 hash_put (h, key, value, hash)
4593 struct Lisp_Hash_Table *h;
4594 Lisp_Object key, value;
4595 unsigned hash;
4597 int start_of_bucket, i;
4599 xassert ((hash & ~INTMASK) == 0);
4601 /* Increment count after resizing because resizing may fail. */
4602 maybe_resize_hash_table (h);
4603 h->count = make_number (XFASTINT (h->count) + 1);
4605 /* Store key/value in the key_and_value vector. */
4606 i = XFASTINT (h->next_free);
4607 h->next_free = HASH_NEXT (h, i);
4608 HASH_KEY (h, i) = key;
4609 HASH_VALUE (h, i) = value;
4611 /* Remember its hash code. */
4612 HASH_HASH (h, i) = make_number (hash);
4614 /* Add new entry to its collision chain. */
4615 start_of_bucket = hash % XVECTOR (h->index)->size;
4616 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4617 HASH_INDEX (h, start_of_bucket) = make_number (i);
4618 return i;
4622 /* Remove the entry matching KEY from hash table H, if there is one. */
4624 void
4625 hash_remove (h, key)
4626 struct Lisp_Hash_Table *h;
4627 Lisp_Object key;
4629 unsigned hash_code;
4630 int start_of_bucket;
4631 Lisp_Object idx, prev;
4633 hash_code = h->hashfn (h, key);
4634 start_of_bucket = hash_code % XVECTOR (h->index)->size;
4635 idx = HASH_INDEX (h, start_of_bucket);
4636 prev = Qnil;
4638 /* We need not gcpro idx, prev since they're either integers or nil. */
4639 while (!NILP (idx))
4641 int i = XFASTINT (idx);
4643 if (EQ (key, HASH_KEY (h, i))
4644 || (h->cmpfn
4645 && h->cmpfn (h, key, hash_code,
4646 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4648 /* Take entry out of collision chain. */
4649 if (NILP (prev))
4650 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
4651 else
4652 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
4654 /* Clear slots in key_and_value and add the slots to
4655 the free list. */
4656 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
4657 HASH_NEXT (h, i) = h->next_free;
4658 h->next_free = make_number (i);
4659 h->count = make_number (XFASTINT (h->count) - 1);
4660 xassert (XINT (h->count) >= 0);
4661 break;
4663 else
4665 prev = idx;
4666 idx = HASH_NEXT (h, i);
4672 /* Clear hash table H. */
4674 void
4675 hash_clear (h)
4676 struct Lisp_Hash_Table *h;
4678 if (XFASTINT (h->count) > 0)
4680 int i, size = HASH_TABLE_SIZE (h);
4682 for (i = 0; i < size; ++i)
4684 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
4685 HASH_KEY (h, i) = Qnil;
4686 HASH_VALUE (h, i) = Qnil;
4687 HASH_HASH (h, i) = Qnil;
4690 for (i = 0; i < XVECTOR (h->index)->size; ++i)
4691 XVECTOR (h->index)->contents[i] = Qnil;
4693 h->next_free = make_number (0);
4694 h->count = make_number (0);
4700 /************************************************************************
4701 Weak Hash Tables
4702 ************************************************************************/
4704 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4705 entries from the table that don't survive the current GC.
4706 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4707 non-zero if anything was marked. */
4709 static int
4710 sweep_weak_table (h, remove_entries_p)
4711 struct Lisp_Hash_Table *h;
4712 int remove_entries_p;
4714 int bucket, n, marked;
4716 n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
4717 marked = 0;
4719 for (bucket = 0; bucket < n; ++bucket)
4721 Lisp_Object idx, next, prev;
4723 /* Follow collision chain, removing entries that
4724 don't survive this garbage collection. */
4725 prev = Qnil;
4726 for (idx = HASH_INDEX (h, bucket); !GC_NILP (idx); idx = next)
4728 int i = XFASTINT (idx);
4729 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4730 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4731 int remove_p;
4733 if (EQ (h->weak, Qkey))
4734 remove_p = !key_known_to_survive_p;
4735 else if (EQ (h->weak, Qvalue))
4736 remove_p = !value_known_to_survive_p;
4737 else if (EQ (h->weak, Qkey_or_value))
4738 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4739 else if (EQ (h->weak, Qkey_and_value))
4740 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4741 else
4742 abort ();
4744 next = HASH_NEXT (h, i);
4746 if (remove_entries_p)
4748 if (remove_p)
4750 /* Take out of collision chain. */
4751 if (GC_NILP (prev))
4752 HASH_INDEX (h, bucket) = next;
4753 else
4754 HASH_NEXT (h, XFASTINT (prev)) = next;
4756 /* Add to free list. */
4757 HASH_NEXT (h, i) = h->next_free;
4758 h->next_free = idx;
4760 /* Clear key, value, and hash. */
4761 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
4762 HASH_HASH (h, i) = Qnil;
4764 h->count = make_number (XFASTINT (h->count) - 1);
4767 else
4769 if (!remove_p)
4771 /* Make sure key and value survive. */
4772 if (!key_known_to_survive_p)
4774 mark_object (HASH_KEY (h, i));
4775 marked = 1;
4778 if (!value_known_to_survive_p)
4780 mark_object (HASH_VALUE (h, i));
4781 marked = 1;
4788 return marked;
4791 /* Remove elements from weak hash tables that don't survive the
4792 current garbage collection. Remove weak tables that don't survive
4793 from Vweak_hash_tables. Called from gc_sweep. */
4795 void
4796 sweep_weak_hash_tables ()
4798 Lisp_Object table, used, next;
4799 struct Lisp_Hash_Table *h;
4800 int marked;
4802 /* Mark all keys and values that are in use. Keep on marking until
4803 there is no more change. This is necessary for cases like
4804 value-weak table A containing an entry X -> Y, where Y is used in a
4805 key-weak table B, Z -> Y. If B comes after A in the list of weak
4806 tables, X -> Y might be removed from A, although when looking at B
4807 one finds that it shouldn't. */
4810 marked = 0;
4811 for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak)
4813 h = XHASH_TABLE (table);
4814 if (h->size & ARRAY_MARK_FLAG)
4815 marked |= sweep_weak_table (h, 0);
4818 while (marked);
4820 /* Remove tables and entries that aren't used. */
4821 for (table = Vweak_hash_tables, used = Qnil; !GC_NILP (table); table = next)
4823 h = XHASH_TABLE (table);
4824 next = h->next_weak;
4826 if (h->size & ARRAY_MARK_FLAG)
4828 /* TABLE is marked as used. Sweep its contents. */
4829 if (XFASTINT (h->count) > 0)
4830 sweep_weak_table (h, 1);
4832 /* Add table to the list of used weak hash tables. */
4833 h->next_weak = used;
4834 used = table;
4838 Vweak_hash_tables = used;
4843 /***********************************************************************
4844 Hash Code Computation
4845 ***********************************************************************/
4847 /* Maximum depth up to which to dive into Lisp structures. */
4849 #define SXHASH_MAX_DEPTH 3
4851 /* Maximum length up to which to take list and vector elements into
4852 account. */
4854 #define SXHASH_MAX_LEN 7
4856 /* Combine two integers X and Y for hashing. */
4858 #define SXHASH_COMBINE(X, Y) \
4859 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4860 + (unsigned)(Y))
4863 /* Return a hash for string PTR which has length LEN. The hash
4864 code returned is guaranteed to fit in a Lisp integer. */
4866 static unsigned
4867 sxhash_string (ptr, len)
4868 unsigned char *ptr;
4869 int len;
4871 unsigned char *p = ptr;
4872 unsigned char *end = p + len;
4873 unsigned char c;
4874 unsigned hash = 0;
4876 while (p != end)
4878 c = *p++;
4879 if (c >= 0140)
4880 c -= 40;
4881 hash = ((hash << 3) + (hash >> 28) + c);
4884 return hash & INTMASK;
4888 /* Return a hash for list LIST. DEPTH is the current depth in the
4889 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4891 static unsigned
4892 sxhash_list (list, depth)
4893 Lisp_Object list;
4894 int depth;
4896 unsigned hash = 0;
4897 int i;
4899 if (depth < SXHASH_MAX_DEPTH)
4900 for (i = 0;
4901 CONSP (list) && i < SXHASH_MAX_LEN;
4902 list = XCDR (list), ++i)
4904 unsigned hash2 = sxhash (XCAR (list), depth + 1);
4905 hash = SXHASH_COMBINE (hash, hash2);
4908 return hash;
4912 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4913 the Lisp structure. */
4915 static unsigned
4916 sxhash_vector (vec, depth)
4917 Lisp_Object vec;
4918 int depth;
4920 unsigned hash = XVECTOR (vec)->size;
4921 int i, n;
4923 n = min (SXHASH_MAX_LEN, XVECTOR (vec)->size);
4924 for (i = 0; i < n; ++i)
4926 unsigned hash2 = sxhash (XVECTOR (vec)->contents[i], depth + 1);
4927 hash = SXHASH_COMBINE (hash, hash2);
4930 return hash;
4934 /* Return a hash for bool-vector VECTOR. */
4936 static unsigned
4937 sxhash_bool_vector (vec)
4938 Lisp_Object vec;
4940 unsigned hash = XBOOL_VECTOR (vec)->size;
4941 int i, n;
4943 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
4944 for (i = 0; i < n; ++i)
4945 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
4947 return hash;
4951 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4952 structure. Value is an unsigned integer clipped to INTMASK. */
4954 unsigned
4955 sxhash (obj, depth)
4956 Lisp_Object obj;
4957 int depth;
4959 unsigned hash;
4961 if (depth > SXHASH_MAX_DEPTH)
4962 return 0;
4964 switch (XTYPE (obj))
4966 case Lisp_Int:
4967 hash = XUINT (obj);
4968 break;
4970 case Lisp_Symbol:
4971 hash = sxhash_string (SDATA (SYMBOL_NAME (obj)),
4972 SCHARS (SYMBOL_NAME (obj)));
4973 break;
4975 case Lisp_Misc:
4976 hash = XUINT (obj);
4977 break;
4979 case Lisp_String:
4980 hash = sxhash_string (SDATA (obj), SCHARS (obj));
4981 break;
4983 /* This can be everything from a vector to an overlay. */
4984 case Lisp_Vectorlike:
4985 if (VECTORP (obj))
4986 /* According to the CL HyperSpec, two arrays are equal only if
4987 they are `eq', except for strings and bit-vectors. In
4988 Emacs, this works differently. We have to compare element
4989 by element. */
4990 hash = sxhash_vector (obj, depth);
4991 else if (BOOL_VECTOR_P (obj))
4992 hash = sxhash_bool_vector (obj);
4993 else
4994 /* Others are `equal' if they are `eq', so let's take their
4995 address as hash. */
4996 hash = XUINT (obj);
4997 break;
4999 case Lisp_Cons:
5000 hash = sxhash_list (obj, depth);
5001 break;
5003 case Lisp_Float:
5005 unsigned char *p = (unsigned char *) &XFLOAT_DATA (obj);
5006 unsigned char *e = p + sizeof XFLOAT_DATA (obj);
5007 for (hash = 0; p < e; ++p)
5008 hash = SXHASH_COMBINE (hash, *p);
5009 break;
5012 default:
5013 abort ();
5016 return hash & INTMASK;
5021 /***********************************************************************
5022 Lisp Interface
5023 ***********************************************************************/
5026 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
5027 doc: /* Compute a hash code for OBJ and return it as integer. */)
5028 (obj)
5029 Lisp_Object obj;
5031 unsigned hash = sxhash (obj, 0);;
5032 return make_number (hash);
5036 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
5037 doc: /* Create and return a new hash table.
5039 Arguments are specified as keyword/argument pairs. The following
5040 arguments are defined:
5042 :test TEST -- TEST must be a symbol that specifies how to compare
5043 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5044 `equal'. User-supplied test and hash functions can be specified via
5045 `define-hash-table-test'.
5047 :size SIZE -- A hint as to how many elements will be put in the table.
5048 Default is 65.
5050 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5051 fills up. If REHASH-SIZE is an integer, add that many space. If it
5052 is a float, it must be > 1.0, and the new size is computed by
5053 multiplying the old size with that factor. Default is 1.5.
5055 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5056 Resize the hash table when ratio of the number of entries in the
5057 table. Default is 0.8.
5059 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5060 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5061 returned is a weak table. Key/value pairs are removed from a weak
5062 hash table when there are no non-weak references pointing to their
5063 key, value, one of key or value, or both key and value, depending on
5064 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5065 is nil.
5067 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5068 (nargs, args)
5069 int nargs;
5070 Lisp_Object *args;
5072 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
5073 Lisp_Object user_test, user_hash;
5074 char *used;
5075 int i;
5077 /* The vector `used' is used to keep track of arguments that
5078 have been consumed. */
5079 used = (char *) alloca (nargs * sizeof *used);
5080 bzero (used, nargs * sizeof *used);
5082 /* See if there's a `:test TEST' among the arguments. */
5083 i = get_key_arg (QCtest, nargs, args, used);
5084 test = i < 0 ? Qeql : args[i];
5085 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
5087 /* See if it is a user-defined test. */
5088 Lisp_Object prop;
5090 prop = Fget (test, Qhash_table_test);
5091 if (!CONSP (prop) || !CONSP (XCDR (prop)))
5092 Fsignal (Qerror, list2 (build_string ("Invalid hash table test"),
5093 test));
5094 user_test = XCAR (prop);
5095 user_hash = XCAR (XCDR (prop));
5097 else
5098 user_test = user_hash = Qnil;
5100 /* See if there's a `:size SIZE' argument. */
5101 i = get_key_arg (QCsize, nargs, args, used);
5102 size = i < 0 ? Qnil : args[i];
5103 if (NILP (size))
5104 size = make_number (DEFAULT_HASH_SIZE);
5105 else if (!INTEGERP (size) || XINT (size) < 0)
5106 Fsignal (Qerror,
5107 list2 (build_string ("Invalid hash table size"),
5108 size));
5110 /* Look for `:rehash-size SIZE'. */
5111 i = get_key_arg (QCrehash_size, nargs, args, used);
5112 rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i];
5113 if (!NUMBERP (rehash_size)
5114 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
5115 || XFLOATINT (rehash_size) <= 1.0)
5116 Fsignal (Qerror,
5117 list2 (build_string ("Invalid hash table rehash size"),
5118 rehash_size));
5120 /* Look for `:rehash-threshold THRESHOLD'. */
5121 i = get_key_arg (QCrehash_threshold, nargs, args, used);
5122 rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
5123 if (!FLOATP (rehash_threshold)
5124 || XFLOATINT (rehash_threshold) <= 0.0
5125 || XFLOATINT (rehash_threshold) > 1.0)
5126 Fsignal (Qerror,
5127 list2 (build_string ("Invalid hash table rehash threshold"),
5128 rehash_threshold));
5130 /* Look for `:weakness WEAK'. */
5131 i = get_key_arg (QCweakness, nargs, args, used);
5132 weak = i < 0 ? Qnil : args[i];
5133 if (EQ (weak, Qt))
5134 weak = Qkey_and_value;
5135 if (!NILP (weak)
5136 && !EQ (weak, Qkey)
5137 && !EQ (weak, Qvalue)
5138 && !EQ (weak, Qkey_or_value)
5139 && !EQ (weak, Qkey_and_value))
5140 Fsignal (Qerror, list2 (build_string ("Invalid hash table weakness"),
5141 weak));
5143 /* Now, all args should have been used up, or there's a problem. */
5144 for (i = 0; i < nargs; ++i)
5145 if (!used[i])
5146 Fsignal (Qerror,
5147 list2 (build_string ("Invalid argument list"), args[i]));
5149 return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
5150 user_test, user_hash);
5154 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
5155 doc: /* Return a copy of hash table TABLE. */)
5156 (table)
5157 Lisp_Object table;
5159 return copy_hash_table (check_hash_table (table));
5163 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
5164 doc: /* Return the number of elements in TABLE. */)
5165 (table)
5166 Lisp_Object table;
5168 return check_hash_table (table)->count;
5172 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
5173 Shash_table_rehash_size, 1, 1, 0,
5174 doc: /* Return the current rehash size of TABLE. */)
5175 (table)
5176 Lisp_Object table;
5178 return check_hash_table (table)->rehash_size;
5182 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
5183 Shash_table_rehash_threshold, 1, 1, 0,
5184 doc: /* Return the current rehash threshold of TABLE. */)
5185 (table)
5186 Lisp_Object table;
5188 return check_hash_table (table)->rehash_threshold;
5192 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
5193 doc: /* Return the size of TABLE.
5194 The size can be used as an argument to `make-hash-table' to create
5195 a hash table than can hold as many elements of TABLE holds
5196 without need for resizing. */)
5197 (table)
5198 Lisp_Object table;
5200 struct Lisp_Hash_Table *h = check_hash_table (table);
5201 return make_number (HASH_TABLE_SIZE (h));
5205 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
5206 doc: /* Return the test TABLE uses. */)
5207 (table)
5208 Lisp_Object table;
5210 return check_hash_table (table)->test;
5214 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
5215 1, 1, 0,
5216 doc: /* Return the weakness of TABLE. */)
5217 (table)
5218 Lisp_Object table;
5220 return check_hash_table (table)->weak;
5224 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
5225 doc: /* Return t if OBJ is a Lisp hash table object. */)
5226 (obj)
5227 Lisp_Object obj;
5229 return HASH_TABLE_P (obj) ? Qt : Qnil;
5233 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
5234 doc: /* Clear hash table TABLE. */)
5235 (table)
5236 Lisp_Object table;
5238 hash_clear (check_hash_table (table));
5239 return Qnil;
5243 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
5244 doc: /* Look up KEY in TABLE and return its associated value.
5245 If KEY is not found, return DFLT which defaults to nil. */)
5246 (key, table, dflt)
5247 Lisp_Object key, table, dflt;
5249 struct Lisp_Hash_Table *h = check_hash_table (table);
5250 int i = hash_lookup (h, key, NULL);
5251 return i >= 0 ? HASH_VALUE (h, i) : dflt;
5255 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
5256 doc: /* Associate KEY with VALUE in hash table TABLE.
5257 If KEY is already present in table, replace its current value with
5258 VALUE. */)
5259 (key, value, table)
5260 Lisp_Object key, value, table;
5262 struct Lisp_Hash_Table *h = check_hash_table (table);
5263 int i;
5264 unsigned hash;
5266 i = hash_lookup (h, key, &hash);
5267 if (i >= 0)
5268 HASH_VALUE (h, i) = value;
5269 else
5270 hash_put (h, key, value, hash);
5272 return value;
5276 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
5277 doc: /* Remove KEY from TABLE. */)
5278 (key, table)
5279 Lisp_Object key, table;
5281 struct Lisp_Hash_Table *h = check_hash_table (table);
5282 hash_remove (h, key);
5283 return Qnil;
5287 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
5288 doc: /* Call FUNCTION for all entries in hash table TABLE.
5289 FUNCTION is called with 2 arguments KEY and VALUE. */)
5290 (function, table)
5291 Lisp_Object function, table;
5293 struct Lisp_Hash_Table *h = check_hash_table (table);
5294 Lisp_Object args[3];
5295 int i;
5297 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
5298 if (!NILP (HASH_HASH (h, i)))
5300 args[0] = function;
5301 args[1] = HASH_KEY (h, i);
5302 args[2] = HASH_VALUE (h, i);
5303 Ffuncall (3, args);
5306 return Qnil;
5310 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
5311 Sdefine_hash_table_test, 3, 3, 0,
5312 doc: /* Define a new hash table test with name NAME, a symbol.
5314 In hash tables created with NAME specified as test, use TEST to
5315 compare keys, and HASH for computing hash codes of keys.
5317 TEST must be a function taking two arguments and returning non-nil if
5318 both arguments are the same. HASH must be a function taking one
5319 argument and return an integer that is the hash code of the argument.
5320 Hash code computation should use the whole value range of integers,
5321 including negative integers. */)
5322 (name, test, hash)
5323 Lisp_Object name, test, hash;
5325 return Fput (name, Qhash_table_test, list2 (test, hash));
5330 /************************************************************************
5332 ************************************************************************/
5334 #include "md5.h"
5335 #include "coding.h"
5337 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
5338 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
5340 A message digest is a cryptographic checksum of a document, and the
5341 algorithm to calculate it is defined in RFC 1321.
5343 The two optional arguments START and END are character positions
5344 specifying for which part of OBJECT the message digest should be
5345 computed. If nil or omitted, the digest is computed for the whole
5346 OBJECT.
5348 The MD5 message digest is computed from the result of encoding the
5349 text in a coding system, not directly from the internal Emacs form of
5350 the text. The optional fourth argument CODING-SYSTEM specifies which
5351 coding system to encode the text with. It should be the same coding
5352 system that you used or will use when actually writing the text into a
5353 file.
5355 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5356 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5357 system would be chosen by default for writing this text into a file.
5359 If OBJECT is a string, the most preferred coding system (see the
5360 command `prefer-coding-system') is used.
5362 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5363 guesswork fails. Normally, an error is signaled in such case. */)
5364 (object, start, end, coding_system, noerror)
5365 Lisp_Object object, start, end, coding_system, noerror;
5367 unsigned char digest[16];
5368 unsigned char value[33];
5369 int i;
5370 int size;
5371 int size_byte = 0;
5372 int start_char = 0, end_char = 0;
5373 int start_byte = 0, end_byte = 0;
5374 register int b, e;
5375 register struct buffer *bp;
5376 int temp;
5378 if (STRINGP (object))
5380 if (NILP (coding_system))
5382 /* Decide the coding-system to encode the data with. */
5384 if (STRING_MULTIBYTE (object))
5385 /* use default, we can't guess correct value */
5386 coding_system = SYMBOL_VALUE (XCAR (Vcoding_category_list));
5387 else
5388 coding_system = Qraw_text;
5391 if (NILP (Fcoding_system_p (coding_system)))
5393 /* Invalid coding system. */
5395 if (!NILP (noerror))
5396 coding_system = Qraw_text;
5397 else
5398 while (1)
5399 Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
5402 if (STRING_MULTIBYTE (object))
5403 object = code_convert_string1 (object, coding_system, Qnil, 1);
5405 size = SCHARS (object);
5406 size_byte = SBYTES (object);
5408 if (!NILP (start))
5410 CHECK_NUMBER (start);
5412 start_char = XINT (start);
5414 if (start_char < 0)
5415 start_char += size;
5417 start_byte = string_char_to_byte (object, start_char);
5420 if (NILP (end))
5422 end_char = size;
5423 end_byte = size_byte;
5425 else
5427 CHECK_NUMBER (end);
5429 end_char = XINT (end);
5431 if (end_char < 0)
5432 end_char += size;
5434 end_byte = string_char_to_byte (object, end_char);
5437 if (!(0 <= start_char && start_char <= end_char && end_char <= size))
5438 args_out_of_range_3 (object, make_number (start_char),
5439 make_number (end_char));
5441 else
5443 CHECK_BUFFER (object);
5445 bp = XBUFFER (object);
5447 if (NILP (start))
5448 b = BUF_BEGV (bp);
5449 else
5451 CHECK_NUMBER_COERCE_MARKER (start);
5452 b = XINT (start);
5455 if (NILP (end))
5456 e = BUF_ZV (bp);
5457 else
5459 CHECK_NUMBER_COERCE_MARKER (end);
5460 e = XINT (end);
5463 if (b > e)
5464 temp = b, b = e, e = temp;
5466 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
5467 args_out_of_range (start, end);
5469 if (NILP (coding_system))
5471 /* Decide the coding-system to encode the data with.
5472 See fileio.c:Fwrite-region */
5474 if (!NILP (Vcoding_system_for_write))
5475 coding_system = Vcoding_system_for_write;
5476 else
5478 int force_raw_text = 0;
5480 coding_system = XBUFFER (object)->buffer_file_coding_system;
5481 if (NILP (coding_system)
5482 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
5484 coding_system = Qnil;
5485 if (NILP (current_buffer->enable_multibyte_characters))
5486 force_raw_text = 1;
5489 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
5491 /* Check file-coding-system-alist. */
5492 Lisp_Object args[4], val;
5494 args[0] = Qwrite_region; args[1] = start; args[2] = end;
5495 args[3] = Fbuffer_file_name(object);
5496 val = Ffind_operation_coding_system (4, args);
5497 if (CONSP (val) && !NILP (XCDR (val)))
5498 coding_system = XCDR (val);
5501 if (NILP (coding_system)
5502 && !NILP (XBUFFER (object)->buffer_file_coding_system))
5504 /* If we still have not decided a coding system, use the
5505 default value of buffer-file-coding-system. */
5506 coding_system = XBUFFER (object)->buffer_file_coding_system;
5509 if (!force_raw_text
5510 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
5511 /* Confirm that VAL can surely encode the current region. */
5512 coding_system = call4 (Vselect_safe_coding_system_function,
5513 make_number (b), make_number (e),
5514 coding_system, Qnil);
5516 if (force_raw_text)
5517 coding_system = Qraw_text;
5520 if (NILP (Fcoding_system_p (coding_system)))
5522 /* Invalid coding system. */
5524 if (!NILP (noerror))
5525 coding_system = Qraw_text;
5526 else
5527 while (1)
5528 Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
5532 object = make_buffer_string (b, e, 0);
5534 if (STRING_MULTIBYTE (object))
5535 object = code_convert_string1 (object, coding_system, Qnil, 1);
5538 md5_buffer (SDATA (object) + start_byte,
5539 SBYTES (object) - (size_byte - end_byte),
5540 digest);
5542 for (i = 0; i < 16; i++)
5543 sprintf (&value[2 * i], "%02x", digest[i]);
5544 value[32] = '\0';
5546 return make_string (value, 32);
5550 void
5551 syms_of_fns ()
5553 /* Hash table stuff. */
5554 Qhash_table_p = intern ("hash-table-p");
5555 staticpro (&Qhash_table_p);
5556 Qeq = intern ("eq");
5557 staticpro (&Qeq);
5558 Qeql = intern ("eql");
5559 staticpro (&Qeql);
5560 Qequal = intern ("equal");
5561 staticpro (&Qequal);
5562 QCtest = intern (":test");
5563 staticpro (&QCtest);
5564 QCsize = intern (":size");
5565 staticpro (&QCsize);
5566 QCrehash_size = intern (":rehash-size");
5567 staticpro (&QCrehash_size);
5568 QCrehash_threshold = intern (":rehash-threshold");
5569 staticpro (&QCrehash_threshold);
5570 QCweakness = intern (":weakness");
5571 staticpro (&QCweakness);
5572 Qkey = intern ("key");
5573 staticpro (&Qkey);
5574 Qvalue = intern ("value");
5575 staticpro (&Qvalue);
5576 Qhash_table_test = intern ("hash-table-test");
5577 staticpro (&Qhash_table_test);
5578 Qkey_or_value = intern ("key-or-value");
5579 staticpro (&Qkey_or_value);
5580 Qkey_and_value = intern ("key-and-value");
5581 staticpro (&Qkey_and_value);
5583 defsubr (&Ssxhash);
5584 defsubr (&Smake_hash_table);
5585 defsubr (&Scopy_hash_table);
5586 defsubr (&Shash_table_count);
5587 defsubr (&Shash_table_rehash_size);
5588 defsubr (&Shash_table_rehash_threshold);
5589 defsubr (&Shash_table_size);
5590 defsubr (&Shash_table_test);
5591 defsubr (&Shash_table_weakness);
5592 defsubr (&Shash_table_p);
5593 defsubr (&Sclrhash);
5594 defsubr (&Sgethash);
5595 defsubr (&Sputhash);
5596 defsubr (&Sremhash);
5597 defsubr (&Smaphash);
5598 defsubr (&Sdefine_hash_table_test);
5600 Qstring_lessp = intern ("string-lessp");
5601 staticpro (&Qstring_lessp);
5602 Qprovide = intern ("provide");
5603 staticpro (&Qprovide);
5604 Qrequire = intern ("require");
5605 staticpro (&Qrequire);
5606 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
5607 staticpro (&Qyes_or_no_p_history);
5608 Qcursor_in_echo_area = intern ("cursor-in-echo-area");
5609 staticpro (&Qcursor_in_echo_area);
5610 Qwidget_type = intern ("widget-type");
5611 staticpro (&Qwidget_type);
5613 staticpro (&string_char_byte_cache_string);
5614 string_char_byte_cache_string = Qnil;
5616 require_nesting_list = Qnil;
5617 staticpro (&require_nesting_list);
5619 Fset (Qyes_or_no_p_history, Qnil);
5621 DEFVAR_LISP ("features", &Vfeatures,
5622 doc: /* A list of symbols which are the features of the executing emacs.
5623 Used by `featurep' and `require', and altered by `provide'. */);
5624 Vfeatures = Qnil;
5625 Qsubfeatures = intern ("subfeatures");
5626 staticpro (&Qsubfeatures);
5628 #ifdef HAVE_LANGINFO_CODESET
5629 Qcodeset = intern ("codeset");
5630 staticpro (&Qcodeset);
5631 Qdays = intern ("days");
5632 staticpro (&Qdays);
5633 Qmonths = intern ("months");
5634 staticpro (&Qmonths);
5635 Qpaper = intern ("paper");
5636 staticpro (&Qpaper);
5637 #endif /* HAVE_LANGINFO_CODESET */
5639 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
5640 doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5641 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5642 invoked by mouse clicks and mouse menu items. */);
5643 use_dialog_box = 1;
5645 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog,
5646 doc: /* *Non-nil means mouse commands use a file dialog to ask for files.
5647 This applies to commands from menus and tool bar buttons. The value of
5648 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5649 used if both `use-dialog-box' and this variable are non-nil. */);
5650 use_file_dialog = 1;
5652 defsubr (&Sidentity);
5653 defsubr (&Srandom);
5654 defsubr (&Slength);
5655 defsubr (&Ssafe_length);
5656 defsubr (&Sstring_bytes);
5657 defsubr (&Sstring_equal);
5658 defsubr (&Scompare_strings);
5659 defsubr (&Sstring_lessp);
5660 defsubr (&Sappend);
5661 defsubr (&Sconcat);
5662 defsubr (&Svconcat);
5663 defsubr (&Scopy_sequence);
5664 defsubr (&Sstring_make_multibyte);
5665 defsubr (&Sstring_make_unibyte);
5666 defsubr (&Sstring_as_multibyte);
5667 defsubr (&Sstring_as_unibyte);
5668 defsubr (&Sstring_to_multibyte);
5669 defsubr (&Scopy_alist);
5670 defsubr (&Ssubstring);
5671 defsubr (&Ssubstring_no_properties);
5672 defsubr (&Snthcdr);
5673 defsubr (&Snth);
5674 defsubr (&Selt);
5675 defsubr (&Smember);
5676 defsubr (&Smemq);
5677 defsubr (&Sassq);
5678 defsubr (&Sassoc);
5679 defsubr (&Srassq);
5680 defsubr (&Srassoc);
5681 defsubr (&Sdelq);
5682 defsubr (&Sdelete);
5683 defsubr (&Snreverse);
5684 defsubr (&Sreverse);
5685 defsubr (&Ssort);
5686 defsubr (&Splist_get);
5687 defsubr (&Sget);
5688 defsubr (&Splist_put);
5689 defsubr (&Sput);
5690 defsubr (&Slax_plist_get);
5691 defsubr (&Slax_plist_put);
5692 defsubr (&Sequal);
5693 defsubr (&Sfillarray);
5694 defsubr (&Sclear_string);
5695 defsubr (&Schar_table_subtype);
5696 defsubr (&Schar_table_parent);
5697 defsubr (&Sset_char_table_parent);
5698 defsubr (&Schar_table_extra_slot);
5699 defsubr (&Sset_char_table_extra_slot);
5700 defsubr (&Schar_table_range);
5701 defsubr (&Sset_char_table_range);
5702 defsubr (&Sset_char_table_default);
5703 defsubr (&Soptimize_char_table);
5704 defsubr (&Smap_char_table);
5705 defsubr (&Snconc);
5706 defsubr (&Smapcar);
5707 defsubr (&Smapc);
5708 defsubr (&Smapconcat);
5709 defsubr (&Sy_or_n_p);
5710 defsubr (&Syes_or_no_p);
5711 defsubr (&Sload_average);
5712 defsubr (&Sfeaturep);
5713 defsubr (&Srequire);
5714 defsubr (&Sprovide);
5715 defsubr (&Splist_member);
5716 defsubr (&Swidget_put);
5717 defsubr (&Swidget_get);
5718 defsubr (&Swidget_apply);
5719 defsubr (&Sbase64_encode_region);
5720 defsubr (&Sbase64_decode_region);
5721 defsubr (&Sbase64_encode_string);
5722 defsubr (&Sbase64_decode_string);
5723 defsubr (&Smd5);
5724 defsubr (&Slocale_info);
5728 void
5729 init_fns ()
5731 Vweak_hash_tables = Qnil;
5734 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5735 (do not change this comment) */