1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 1999 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
52 #define min(a, b) ((a) < (b) ? (a) : (b))
53 #define max(a, b) ((a) > (b) ? (a) : (b))
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 extern int minibuffer_auto_raise
;
61 extern Lisp_Object minibuf_window
;
63 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
64 Lisp_Object Qyes_or_no_p_history
;
65 Lisp_Object Qcursor_in_echo_area
;
66 Lisp_Object Qwidget_type
;
68 extern Lisp_Object Qinput_method_function
;
70 static int internal_equal ();
72 extern long get_random ();
73 extern void seed_random ();
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 "Return the argument unchanged.")
87 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
88 "Return a pseudo-random number.\n\
89 All integers representable in Lisp are equally likely.\n\
90 On most systems, this is 28 bits' worth.\n\
91 With positive integer argument N, return random number in interval [0,N).\n\
92 With argument t, set the random number seed from the current time and pid.")
97 Lisp_Object lispy_val
;
98 unsigned long denominator
;
101 seed_random (getpid () + time (NULL
));
102 if (NATNUMP (n
) && XFASTINT (n
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. We do this by using the
107 quotient rather than the remainder. At the high end of the RNG
108 it's possible to get a quotient larger than n; discarding
109 these values eliminates the bias that would otherwise appear
110 when using a large n. */
111 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
113 val
= get_random () / denominator
;
114 while (val
>= XFASTINT (n
));
118 XSETINT (lispy_val
, val
);
122 /* Random data-structure functions */
124 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
125 "Return the length of vector, list or string SEQUENCE.\n\
126 A byte-code function object is also allowed.\n\
127 If the string contains multibyte characters, this is not the necessarily\n\
128 the number of bytes in the string; it is the number of characters.\n\
129 To get the number of bytes, use `string-bytes'")
131 register Lisp_Object sequence
;
133 register Lisp_Object tail
, val
;
137 if (STRINGP (sequence
))
138 XSETFASTINT (val
, XSTRING (sequence
)->size
);
139 else if (VECTORP (sequence
))
140 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
141 else if (CHAR_TABLE_P (sequence
))
142 XSETFASTINT (val
, (MIN_CHAR_COMPOSITION
143 + (CHAR_FIELD2_MASK
| CHAR_FIELD3_MASK
)
145 else if (BOOL_VECTOR_P (sequence
))
146 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
147 else if (COMPILEDP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
149 else if (CONSP (sequence
))
151 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
157 XSETFASTINT (val
, i
);
159 else if (NILP (sequence
))
160 XSETFASTINT (val
, 0);
163 sequence
= wrong_type_argument (Qsequencep
, sequence
);
169 /* This does not check for quits. That is safe
170 since it must terminate. */
172 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
173 "Return the length of a list, but avoid error or infinite loop.\n\
174 This function never gets an error. If LIST is not really a list,\n\
175 it returns 0. If LIST is circular, it returns a finite value\n\
176 which is at least the number of distinct elements.")
180 Lisp_Object tail
, halftail
, length
;
183 /* halftail is used to detect circular lists. */
185 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
187 if (EQ (tail
, halftail
) && len
!= 0)
191 halftail
= XCONS (halftail
)->cdr
;
194 XSETINT (length
, len
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 "Return the number of bytes in STRING.\n\
200 If STRING is a multibyte string, this is greater than the length of STRING.")
204 CHECK_STRING (string
, 1);
205 return make_number (STRING_BYTES (XSTRING (string
)));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 "Return t if two strings have identical contents.\n\
210 Case is significant, but text properties are ignored.\n\
211 Symbols are also allowed; their print names are used instead.")
213 register Lisp_Object s1
, s2
;
216 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
218 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
219 CHECK_STRING (s1
, 0);
220 CHECK_STRING (s2
, 1);
222 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
223 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
224 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
229 DEFUN ("compare-strings", Fcompare_strings
,
230 Scompare_strings
, 6, 7, 0,
231 "Compare the contents of two strings, converting to multibyte if needed.\n\
232 In string STR1, skip the first START1 characters and stop at END1.\n\
233 In string STR2, skip the first START2 characters and stop at END2.\n\
234 END1 and END2 default to the full lengths of the respective strings.\n\
236 Case is significant in this comparison if IGNORE-CASE is nil.\n\
237 Unibyte strings are converted to multibyte for comparison.\n\
239 The value is t if the strings (or specified portions) match.\n\
240 If string STR1 is less, the value is a negative number N;\n\
241 - 1 - N is the number of characters that match at the beginning.\n\
242 If string STR1 is greater, the value is a positive number N;\n\
243 N - 1 is the number of characters that match at the beginning.")
244 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
245 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
247 register int end1_char
, end2_char
;
248 register int i1
, i1_byte
, i2
, i2_byte
;
250 CHECK_STRING (str1
, 0);
251 CHECK_STRING (str2
, 1);
253 start1
= make_number (0);
255 start2
= make_number (0);
256 CHECK_NATNUM (start1
, 2);
257 CHECK_NATNUM (start2
, 3);
259 CHECK_NATNUM (end1
, 4);
261 CHECK_NATNUM (end2
, 4);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 end1_char
= XSTRING (str1
)->size
;
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
273 end2_char
= XSTRING (str2
)->size
;
274 if (! NILP (end2
) && end2_char
> XINT (end2
))
275 end2_char
= XINT (end2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
287 c1
= XSTRING (str1
)->data
[i1
++];
288 c1
= unibyte_char_to_multibyte (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
295 c2
= XSTRING (str2
)->data
[i2
++];
296 c2
= unibyte_char_to_multibyte (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
);
321 return make_number (i1
);
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 "Return t if first arg string is less than second in lexicographic order.\n\
334 Case is significant.\n\
335 Symbols are also allowed; their print names are used instead.")
337 register Lisp_Object s1
, s2
;
340 register int i1
, i1_byte
, i2
, i2_byte
;
343 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
345 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
346 CHECK_STRING (s1
, 0);
347 CHECK_STRING (s2
, 1);
349 i1
= i1_byte
= i2
= i2_byte
= 0;
351 end
= XSTRING (s1
)->size
;
352 if (end
> XSTRING (s2
)->size
)
353 end
= XSTRING (s2
)->size
;
357 /* When we find a mismatch, we must compare the
358 characters, not just the bytes. */
361 if (STRING_MULTIBYTE (s1
))
362 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
364 c1
= XSTRING (s1
)->data
[i1
++];
366 if (STRING_MULTIBYTE (s2
))
367 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
369 c2
= XSTRING (s2
)->data
[i2
++];
372 return c1
< c2
? Qt
: Qnil
;
374 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
377 static Lisp_Object
concat ();
388 return concat (2, args
, Lisp_String
, 0);
390 return concat (2, &s1
, Lisp_String
, 0);
391 #endif /* NO_ARG_ARRAY */
397 Lisp_Object s1
, s2
, s3
;
404 return concat (3, args
, Lisp_String
, 0);
406 return concat (3, &s1
, Lisp_String
, 0);
407 #endif /* NO_ARG_ARRAY */
410 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
411 "Concatenate all the arguments and make the result a list.\n\
412 The result is a list whose elements are the elements of all the arguments.\n\
413 Each argument may be a list, vector or string.\n\
414 The last argument is not copied, just used as the tail of the new list.")
419 return concat (nargs
, args
, Lisp_Cons
, 1);
422 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
423 "Concatenate all the arguments and make the result a string.\n\
424 The result is a string whose elements are the elements of all the arguments.\n\
425 Each argument may be a string or a list or vector of characters (integers).\n\
427 Do not use individual integers as arguments!\n\
428 The behavior of `concat' in that case will be changed later!\n\
429 If your program passes an integer as an argument to `concat',\n\
430 you should change it right away not to do so.")
435 return concat (nargs
, args
, Lisp_String
, 0);
438 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
439 "Concatenate all the arguments and make the result a vector.\n\
440 The result is a vector whose elements are the elements of all the arguments.\n\
441 Each argument may be a list, vector or string.")
446 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
449 /* Retrun a copy of a sub char table ARG. The elements except for a
450 nested sub char table are not copied. */
452 copy_sub_char_table (arg
)
455 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
458 /* Copy all the contents. */
459 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
460 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
461 /* Recursively copy any sub char-tables in the ordinary slots. */
462 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
463 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
464 XCHAR_TABLE (copy
)->contents
[i
]
465 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
471 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
472 "Return a copy of a list, vector or string.\n\
473 The elements of a list or vector are not copied; they are shared\n\
478 if (NILP (arg
)) return arg
;
480 if (CHAR_TABLE_P (arg
))
485 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
486 /* Copy all the slots, including the extra ones. */
487 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
488 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
489 * sizeof (Lisp_Object
)));
491 /* Recursively copy any sub char tables in the ordinary slots
492 for multibyte characters. */
493 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
494 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
495 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
496 XCHAR_TABLE (copy
)->contents
[i
]
497 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
502 if (BOOL_VECTOR_P (arg
))
506 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
508 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
509 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
514 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
515 arg
= wrong_type_argument (Qsequencep
, arg
);
516 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
520 concat (nargs
, args
, target_type
, last_special
)
523 enum Lisp_Type target_type
;
527 register Lisp_Object tail
;
528 register Lisp_Object
this;
531 register int result_len
;
532 register int result_len_byte
;
534 Lisp_Object last_tail
;
537 /* When we make a multibyte string, we must pay attention to the
538 byte combining problem, i.e., a byte may be combined with a
539 multibyte charcter of the previous string. This flag tells if we
540 must consider such a situation or not. */
541 int maybe_combine_byte
;
543 /* In append, the last arg isn't treated like the others */
544 if (last_special
&& nargs
> 0)
547 last_tail
= args
[nargs
];
552 /* Canonicalize each argument. */
553 for (argnum
= 0; argnum
< nargs
; argnum
++)
556 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
557 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
560 args
[argnum
] = Fnumber_to_string (this);
562 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
566 /* Compute total length in chars of arguments in RESULT_LEN.
567 If desired output is a string, also compute length in bytes
568 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
569 whether the result should be a multibyte string. */
573 for (argnum
= 0; argnum
< nargs
; argnum
++)
577 len
= XFASTINT (Flength (this));
578 if (target_type
== Lisp_String
)
580 /* We must count the number of bytes needed in the string
581 as well as the number of characters. */
587 for (i
= 0; i
< len
; i
++)
589 ch
= XVECTOR (this)->contents
[i
];
591 wrong_type_argument (Qintegerp
, ch
);
592 this_len_byte
= CHAR_BYTES (XINT (ch
));
593 result_len_byte
+= this_len_byte
;
594 if (this_len_byte
> 1)
597 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
598 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
599 else if (CONSP (this))
600 for (; CONSP (this); this = XCONS (this)->cdr
)
602 ch
= XCONS (this)->car
;
604 wrong_type_argument (Qintegerp
, ch
);
605 this_len_byte
= CHAR_BYTES (XINT (ch
));
606 result_len_byte
+= this_len_byte
;
607 if (this_len_byte
> 1)
610 else if (STRINGP (this))
612 if (STRING_MULTIBYTE (this))
615 result_len_byte
+= STRING_BYTES (XSTRING (this));
618 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
619 XSTRING (this)->size
);
626 if (! some_multibyte
)
627 result_len_byte
= result_len
;
629 /* Create the output object. */
630 if (target_type
== Lisp_Cons
)
631 val
= Fmake_list (make_number (result_len
), Qnil
);
632 else if (target_type
== Lisp_Vectorlike
)
633 val
= Fmake_vector (make_number (result_len
), Qnil
);
634 else if (some_multibyte
)
635 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
637 val
= make_uninit_string (result_len
);
639 /* In `append', if all but last arg are nil, return last arg. */
640 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
643 /* Copy the contents of the args into the result. */
645 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
647 toindex
= 0, toindex_byte
= 0;
651 maybe_combine_byte
= 0;
652 for (argnum
= 0; argnum
< nargs
; argnum
++)
656 register unsigned int thisindex
= 0;
657 register unsigned int thisindex_byte
= 0;
661 thislen
= Flength (this), thisleni
= XINT (thislen
);
663 if (STRINGP (this) && STRINGP (val
)
664 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
665 copy_text_properties (make_number (0), thislen
, this,
666 make_number (toindex
), val
, Qnil
);
668 /* Between strings of the same kind, copy fast. */
669 if (STRINGP (this) && STRINGP (val
)
670 && STRING_MULTIBYTE (this) == some_multibyte
)
672 int thislen_byte
= STRING_BYTES (XSTRING (this));
673 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
674 STRING_BYTES (XSTRING (this)));
677 && !ASCII_BYTE_P (XSTRING (val
)->data
[toindex_byte
- 1])
678 && !CHAR_HEAD_P (XSTRING (this)->data
[0]))
679 maybe_combine_byte
= 1;
680 toindex_byte
+= thislen_byte
;
683 /* Copy a single-byte string to a multibyte string. */
684 else if (STRINGP (this) && STRINGP (val
))
686 toindex_byte
+= copy_text (XSTRING (this)->data
,
687 XSTRING (val
)->data
+ toindex_byte
,
688 XSTRING (this)->size
, 0, 1);
692 /* Copy element by element. */
695 register Lisp_Object elt
;
697 /* Fetch next element of `this' arg into `elt', or break if
698 `this' is exhausted. */
699 if (NILP (this)) break;
701 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
702 else if (thisindex
>= thisleni
)
704 else if (STRINGP (this))
707 if (STRING_MULTIBYTE (this))
709 FETCH_STRING_CHAR_ADVANCE (c
, this,
712 XSETFASTINT (elt
, c
);
716 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
718 && (XINT (elt
) >= 0240
719 || (XINT (elt
) >= 0200
720 && ! NILP (Vnonascii_translation_table
)))
721 && XINT (elt
) < 0400)
723 c
= unibyte_char_to_multibyte (XINT (elt
));
728 else if (BOOL_VECTOR_P (this))
731 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
732 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
739 elt
= XVECTOR (this)->contents
[thisindex
++];
741 /* Store this element into the result. */
744 XCONS (tail
)->car
= elt
;
746 tail
= XCONS (tail
)->cdr
;
748 else if (VECTORP (val
))
749 XVECTOR (val
)->contents
[toindex
++] = elt
;
752 CHECK_NUMBER (elt
, 0);
753 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
757 && !ASCII_BYTE_P (XSTRING (val
)->data
[toindex_byte
- 1])
758 && !CHAR_HEAD_P (XINT (elt
)))
759 maybe_combine_byte
= 1;
760 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
764 /* If we have any multibyte characters,
765 we already decided to make a multibyte string. */
768 unsigned char work
[4], *str
;
769 int i
= CHAR_STRING (c
, work
, str
);
771 /* P exists as a variable
772 to avoid a bug on the Masscomp C compiler. */
773 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
782 XCONS (prev
)->cdr
= last_tail
;
784 if (maybe_combine_byte
)
785 /* Character counter of the multibyte string VAL may be wrong
786 because of byte combining problem. We must re-calculate it. */
787 XSTRING (val
)->size
= multibyte_chars_in_text (XSTRING (val
)->data
,
788 XSTRING (val
)->size_byte
);
793 static Lisp_Object string_char_byte_cache_string
;
794 static int string_char_byte_cache_charpos
;
795 static int string_char_byte_cache_bytepos
;
798 clear_string_char_byte_cache ()
800 string_char_byte_cache_string
= Qnil
;
803 /* Return the character index corresponding to CHAR_INDEX in STRING. */
806 string_char_to_byte (string
, char_index
)
811 int best_below
, best_below_byte
;
812 int best_above
, best_above_byte
;
814 if (! STRING_MULTIBYTE (string
))
817 best_below
= best_below_byte
= 0;
818 best_above
= XSTRING (string
)->size
;
819 best_above_byte
= STRING_BYTES (XSTRING (string
));
821 if (EQ (string
, string_char_byte_cache_string
))
823 if (string_char_byte_cache_charpos
< char_index
)
825 best_below
= string_char_byte_cache_charpos
;
826 best_below_byte
= string_char_byte_cache_bytepos
;
830 best_above
= string_char_byte_cache_charpos
;
831 best_above_byte
= string_char_byte_cache_bytepos
;
835 if (char_index
- best_below
< best_above
- char_index
)
837 while (best_below
< char_index
)
840 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
843 i_byte
= best_below_byte
;
847 while (best_above
> char_index
)
849 int best_above_byte_saved
= --best_above_byte
;
851 while (best_above_byte
> 0
852 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
854 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
855 best_above_byte
= best_above_byte_saved
;
859 i_byte
= best_above_byte
;
862 string_char_byte_cache_bytepos
= i_byte
;
863 string_char_byte_cache_charpos
= i
;
864 string_char_byte_cache_string
= string
;
869 /* Return the character index corresponding to BYTE_INDEX in STRING. */
872 string_byte_to_char (string
, byte_index
)
877 int best_below
, best_below_byte
;
878 int best_above
, best_above_byte
;
880 if (! STRING_MULTIBYTE (string
))
883 best_below
= best_below_byte
= 0;
884 best_above
= XSTRING (string
)->size
;
885 best_above_byte
= STRING_BYTES (XSTRING (string
));
887 if (EQ (string
, string_char_byte_cache_string
))
889 if (string_char_byte_cache_bytepos
< byte_index
)
891 best_below
= string_char_byte_cache_charpos
;
892 best_below_byte
= string_char_byte_cache_bytepos
;
896 best_above
= string_char_byte_cache_charpos
;
897 best_above_byte
= string_char_byte_cache_bytepos
;
901 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
903 while (best_below_byte
< byte_index
)
906 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
909 i_byte
= best_below_byte
;
913 while (best_above_byte
> byte_index
)
915 int best_above_byte_saved
= --best_above_byte
;
917 while (best_above_byte
> 0
918 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
920 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
921 best_above_byte
= best_above_byte_saved
;
925 i_byte
= best_above_byte
;
928 string_char_byte_cache_bytepos
= i_byte
;
929 string_char_byte_cache_charpos
= i
;
930 string_char_byte_cache_string
= string
;
935 /* Convert STRING to a multibyte string.
936 Single-byte characters 0240 through 0377 are converted
937 by adding nonascii_insert_offset to each. */
940 string_make_multibyte (string
)
946 if (STRING_MULTIBYTE (string
))
949 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
950 XSTRING (string
)->size
);
951 /* If all the chars are ASCII, they won't need any more bytes
952 once converted. In that case, we can return STRING itself. */
953 if (nbytes
== STRING_BYTES (XSTRING (string
)))
956 buf
= (unsigned char *) alloca (nbytes
);
957 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
960 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
963 /* Convert STRING to a single-byte string. */
966 string_make_unibyte (string
)
971 if (! STRING_MULTIBYTE (string
))
974 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
976 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
979 return make_unibyte_string (buf
, XSTRING (string
)->size
);
982 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
984 "Return the multibyte equivalent of STRING.\n\
985 The function `unibyte-char-to-multibyte' is used to convert\n\
986 each unibyte character to a multibyte character.")
990 CHECK_STRING (string
, 0);
992 return string_make_multibyte (string
);
995 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
997 "Return the unibyte equivalent of STRING.\n\
998 Multibyte character codes are converted to unibyte\n\
999 by using just the low 8 bits.")
1003 CHECK_STRING (string
, 0);
1005 return string_make_unibyte (string
);
1008 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1010 "Return a unibyte string with the same individual bytes as STRING.\n\
1011 If STRING is unibyte, the result is STRING itself.\n\
1012 Otherwise it is a newly created string, with no text properties.")
1016 CHECK_STRING (string
, 0);
1018 if (STRING_MULTIBYTE (string
))
1020 string
= Fcopy_sequence (string
);
1021 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1022 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1023 SET_STRING_BYTES (XSTRING (string
), -1);
1028 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1030 "Return a multibyte string with the same individual bytes as STRING.\n\
1031 If STRING is multibyte, the result is STRING itself.\n\
1032 Otherwise it is a newly created string, with no text properties.")
1036 CHECK_STRING (string
, 0);
1038 if (! STRING_MULTIBYTE (string
))
1040 int nbytes
= STRING_BYTES (XSTRING (string
));
1041 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1043 string
= Fcopy_sequence (string
);
1044 XSTRING (string
)->size
= newlen
;
1045 XSTRING (string
)->size_byte
= nbytes
;
1046 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1051 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1052 "Return a copy of ALIST.\n\
1053 This is an alist which represents the same mapping from objects to objects,\n\
1054 but does not share the alist structure with ALIST.\n\
1055 The objects mapped (cars and cdrs of elements of the alist)\n\
1056 are shared, however.\n\
1057 Elements of ALIST that are not conses are also shared.")
1061 register Lisp_Object tem
;
1063 CHECK_LIST (alist
, 0);
1066 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1067 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1069 register Lisp_Object car
;
1070 car
= XCONS (tem
)->car
;
1073 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1078 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1079 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1080 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1081 If FROM or TO is negative, it counts from the end.\n\
1083 This function allows vectors as well as strings.")
1086 register Lisp_Object from
, to
;
1091 int from_char
, to_char
;
1092 int from_byte
, to_byte
;
1094 if (! (STRINGP (string
) || VECTORP (string
)))
1095 wrong_type_argument (Qarrayp
, string
);
1097 CHECK_NUMBER (from
, 1);
1099 if (STRINGP (string
))
1101 size
= XSTRING (string
)->size
;
1102 size_byte
= STRING_BYTES (XSTRING (string
));
1105 size
= XVECTOR (string
)->size
;
1110 to_byte
= size_byte
;
1114 CHECK_NUMBER (to
, 2);
1116 to_char
= XINT (to
);
1120 if (STRINGP (string
))
1121 to_byte
= string_char_to_byte (string
, to_char
);
1124 from_char
= XINT (from
);
1127 if (STRINGP (string
))
1128 from_byte
= string_char_to_byte (string
, from_char
);
1130 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1131 args_out_of_range_3 (string
, make_number (from_char
),
1132 make_number (to_char
));
1134 if (STRINGP (string
))
1136 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1137 to_char
- from_char
, to_byte
- from_byte
,
1138 STRING_MULTIBYTE (string
));
1139 copy_text_properties (make_number (from_char
), make_number (to_char
),
1140 string
, make_number (0), res
, Qnil
);
1143 res
= Fvector (to_char
- from_char
,
1144 XVECTOR (string
)->contents
+ from_char
);
1149 /* Extract a substring of STRING, giving start and end positions
1150 both in characters and in bytes. */
1153 substring_both (string
, from
, from_byte
, to
, to_byte
)
1155 int from
, from_byte
, to
, to_byte
;
1161 if (! (STRINGP (string
) || VECTORP (string
)))
1162 wrong_type_argument (Qarrayp
, string
);
1164 if (STRINGP (string
))
1166 size
= XSTRING (string
)->size
;
1167 size_byte
= STRING_BYTES (XSTRING (string
));
1170 size
= XVECTOR (string
)->size
;
1172 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1173 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1175 if (STRINGP (string
))
1177 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1178 to
- from
, to_byte
- from_byte
,
1179 STRING_MULTIBYTE (string
));
1180 copy_text_properties (make_number (from
), make_number (to
),
1181 string
, make_number (0), res
, Qnil
);
1184 res
= Fvector (to
- from
,
1185 XVECTOR (string
)->contents
+ from
);
1190 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1191 "Take cdr N times on LIST, returns the result.")
1194 register Lisp_Object list
;
1196 register int i
, num
;
1197 CHECK_NUMBER (n
, 0);
1199 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1207 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1208 "Return the Nth element of LIST.\n\
1209 N counts from zero. If LIST is not that long, nil is returned.")
1211 Lisp_Object n
, list
;
1213 return Fcar (Fnthcdr (n
, list
));
1216 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1217 "Return element of SEQUENCE at index N.")
1219 register Lisp_Object sequence
, n
;
1221 CHECK_NUMBER (n
, 0);
1224 if (CONSP (sequence
) || NILP (sequence
))
1225 return Fcar (Fnthcdr (n
, sequence
));
1226 else if (STRINGP (sequence
) || VECTORP (sequence
)
1227 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1228 return Faref (sequence
, n
);
1230 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1234 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1235 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1236 The value is actually the tail of LIST whose car is ELT.")
1238 register Lisp_Object elt
;
1241 register Lisp_Object tail
;
1242 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1244 register Lisp_Object tem
;
1246 if (! NILP (Fequal (elt
, tem
)))
1253 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1254 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1255 The value is actually the tail of LIST whose car is ELT.")
1257 register Lisp_Object elt
;
1260 register Lisp_Object tail
;
1261 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1263 register Lisp_Object tem
;
1265 if (EQ (elt
, tem
)) return tail
;
1271 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1272 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1273 The value is actually the element of LIST whose car is KEY.\n\
1274 Elements of LIST that are not conses are ignored.")
1276 register Lisp_Object key
;
1279 register Lisp_Object tail
;
1280 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1282 register Lisp_Object elt
, tem
;
1284 if (!CONSP (elt
)) continue;
1285 tem
= XCONS (elt
)->car
;
1286 if (EQ (key
, tem
)) return elt
;
1292 /* Like Fassq but never report an error and do not allow quits.
1293 Use only on lists known never to be circular. */
1296 assq_no_quit (key
, list
)
1297 register Lisp_Object key
;
1300 register Lisp_Object tail
;
1301 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1303 register Lisp_Object elt
, tem
;
1305 if (!CONSP (elt
)) continue;
1306 tem
= XCONS (elt
)->car
;
1307 if (EQ (key
, tem
)) return elt
;
1312 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1313 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1314 The value is actually the element of LIST whose car equals KEY.")
1316 register Lisp_Object key
;
1319 register Lisp_Object tail
;
1320 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1322 register Lisp_Object elt
, tem
;
1324 if (!CONSP (elt
)) continue;
1325 tem
= Fequal (XCONS (elt
)->car
, key
);
1326 if (!NILP (tem
)) return elt
;
1332 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1333 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1334 The value is actually the element of LIST whose cdr is ELT.")
1336 register Lisp_Object key
;
1339 register Lisp_Object tail
;
1340 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1342 register Lisp_Object elt
, tem
;
1344 if (!CONSP (elt
)) continue;
1345 tem
= XCONS (elt
)->cdr
;
1346 if (EQ (key
, tem
)) return elt
;
1352 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1353 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1354 The value is actually the element of LIST whose cdr equals KEY.")
1356 register Lisp_Object key
;
1359 register Lisp_Object tail
;
1360 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1362 register Lisp_Object elt
, tem
;
1364 if (!CONSP (elt
)) continue;
1365 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1366 if (!NILP (tem
)) return elt
;
1372 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1373 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1374 The modified LIST is returned. Comparison is done with `eq'.\n\
1375 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1376 therefore, write `(setq foo (delq element foo))'\n\
1377 to be sure of changing the value of `foo'.")
1379 register Lisp_Object elt
;
1382 register Lisp_Object tail
, prev
;
1383 register Lisp_Object tem
;
1387 while (!NILP (tail
))
1393 list
= XCONS (tail
)->cdr
;
1395 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1399 tail
= XCONS (tail
)->cdr
;
1405 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1406 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1407 The modified LIST is returned. Comparison is done with `equal'.\n\
1408 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1409 it is simply using a different list.\n\
1410 Therefore, write `(setq foo (delete element foo))'\n\
1411 to be sure of changing the value of `foo'.")
1413 register Lisp_Object elt
;
1416 register Lisp_Object tail
, prev
;
1417 register Lisp_Object tem
;
1421 while (!NILP (tail
))
1424 if (! NILP (Fequal (elt
, tem
)))
1427 list
= XCONS (tail
)->cdr
;
1429 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1433 tail
= XCONS (tail
)->cdr
;
1439 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1440 "Reverse LIST by modifying cdr pointers.\n\
1441 Returns the beginning of the reversed list.")
1445 register Lisp_Object prev
, tail
, next
;
1447 if (NILP (list
)) return list
;
1450 while (!NILP (tail
))
1454 Fsetcdr (tail
, prev
);
1461 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1462 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1463 See also the function `nreverse', which is used more often.")
1469 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1470 new = Fcons (XCONS (list
)->car
, new);
1472 wrong_type_argument (Qconsp
, list
);
1476 Lisp_Object
merge ();
1478 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1479 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1480 Returns the sorted list. LIST is modified by side effects.\n\
1481 PREDICATE is called with two elements of LIST, and should return T\n\
1482 if the first element is \"less\" than the second.")
1484 Lisp_Object list
, predicate
;
1486 Lisp_Object front
, back
;
1487 register Lisp_Object len
, tem
;
1488 struct gcpro gcpro1
, gcpro2
;
1489 register int length
;
1492 len
= Flength (list
);
1493 length
= XINT (len
);
1497 XSETINT (len
, (length
/ 2) - 1);
1498 tem
= Fnthcdr (len
, list
);
1500 Fsetcdr (tem
, Qnil
);
1502 GCPRO2 (front
, back
);
1503 front
= Fsort (front
, predicate
);
1504 back
= Fsort (back
, predicate
);
1506 return merge (front
, back
, predicate
);
1510 merge (org_l1
, org_l2
, pred
)
1511 Lisp_Object org_l1
, org_l2
;
1515 register Lisp_Object tail
;
1517 register Lisp_Object l1
, l2
;
1518 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1525 /* It is sufficient to protect org_l1 and org_l2.
1526 When l1 and l2 are updated, we copy the new values
1527 back into the org_ vars. */
1528 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1548 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1564 Fsetcdr (tail
, tem
);
1570 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1571 "Extract a value from a property list.\n\
1572 PLIST is a property list, which is a list of the form\n\
1573 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1574 corresponding to the given PROP, or nil if PROP is not\n\
1575 one of the properties on the list.")
1578 register Lisp_Object prop
;
1580 register Lisp_Object tail
;
1581 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1583 register Lisp_Object tem
;
1586 return Fcar (XCONS (tail
)->cdr
);
1591 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1592 "Return the value of SYMBOL's PROPNAME property.\n\
1593 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1595 Lisp_Object symbol
, propname
;
1597 CHECK_SYMBOL (symbol
, 0);
1598 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1601 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1602 "Change value in PLIST of PROP to VAL.\n\
1603 PLIST is a property list, which is a list of the form\n\
1604 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1605 If PROP is already a property on the list, its value is set to VAL,\n\
1606 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1607 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1608 The PLIST is modified by side effects.")
1611 register Lisp_Object prop
;
1614 register Lisp_Object tail
, prev
;
1615 Lisp_Object newcell
;
1617 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1618 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1620 if (EQ (prop
, XCONS (tail
)->car
))
1622 Fsetcar (XCONS (tail
)->cdr
, val
);
1627 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1631 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1635 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1636 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1637 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1638 (symbol
, propname
, value
)
1639 Lisp_Object symbol
, propname
, value
;
1641 CHECK_SYMBOL (symbol
, 0);
1642 XSYMBOL (symbol
)->plist
1643 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1647 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1648 "Return t if two Lisp objects have similar structure and contents.\n\
1649 They must have the same data type.\n\
1650 Conses are compared by comparing the cars and the cdrs.\n\
1651 Vectors and strings are compared element by element.\n\
1652 Numbers are compared by value, but integers cannot equal floats.\n\
1653 (Use `=' if you want integers and floats to be able to be equal.)\n\
1654 Symbols must match exactly.")
1656 register Lisp_Object o1
, o2
;
1658 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1662 internal_equal (o1
, o2
, depth
)
1663 register Lisp_Object o1
, o2
;
1667 error ("Stack overflow in equal");
1673 if (XTYPE (o1
) != XTYPE (o2
))
1678 #ifdef LISP_FLOAT_TYPE
1680 return (extract_float (o1
) == extract_float (o2
));
1684 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1686 o1
= XCONS (o1
)->cdr
;
1687 o2
= XCONS (o2
)->cdr
;
1691 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1695 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1697 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1700 o1
= XOVERLAY (o1
)->plist
;
1701 o2
= XOVERLAY (o2
)->plist
;
1706 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1707 && (XMARKER (o1
)->buffer
== 0
1708 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1712 case Lisp_Vectorlike
:
1714 register int i
, size
;
1715 size
= XVECTOR (o1
)->size
;
1716 /* Pseudovectors have the type encoded in the size field, so this test
1717 actually checks that the objects have the same type as well as the
1719 if (XVECTOR (o2
)->size
!= size
)
1721 /* Boolvectors are compared much like strings. */
1722 if (BOOL_VECTOR_P (o1
))
1725 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1727 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1729 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1734 if (WINDOW_CONFIGURATIONP (o1
))
1735 return compare_window_configurations (o1
, o2
, 0);
1737 /* Aside from them, only true vectors, char-tables, and compiled
1738 functions are sensible to compare, so eliminate the others now. */
1739 if (size
& PSEUDOVECTOR_FLAG
)
1741 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1743 size
&= PSEUDOVECTOR_SIZE_MASK
;
1745 for (i
= 0; i
< size
; i
++)
1748 v1
= XVECTOR (o1
)->contents
[i
];
1749 v2
= XVECTOR (o2
)->contents
[i
];
1750 if (!internal_equal (v1
, v2
, depth
+ 1))
1758 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1760 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1762 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1763 STRING_BYTES (XSTRING (o1
))))
1770 extern Lisp_Object
Fmake_char_internal ();
1772 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1773 "Store each element of ARRAY with ITEM.\n\
1774 ARRAY is a vector, string, char-table, or bool-vector.")
1776 Lisp_Object array
, item
;
1778 register int size
, index
, charval
;
1780 if (VECTORP (array
))
1782 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1783 size
= XVECTOR (array
)->size
;
1784 for (index
= 0; index
< size
; index
++)
1787 else if (CHAR_TABLE_P (array
))
1789 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1790 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1791 for (index
= 0; index
< size
; index
++)
1793 XCHAR_TABLE (array
)->defalt
= Qnil
;
1795 else if (STRINGP (array
))
1797 register unsigned char *p
= XSTRING (array
)->data
;
1798 CHECK_NUMBER (item
, 1);
1799 charval
= XINT (item
);
1800 size
= XSTRING (array
)->size
;
1801 if (STRING_MULTIBYTE (array
))
1803 unsigned char workbuf
[4], *str
;
1804 int len
= CHAR_STRING (charval
, workbuf
, str
);
1805 int size_byte
= STRING_BYTES (XSTRING (array
));
1806 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1809 if (size
!= size_byte
)
1812 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1813 if (len
!= this_len
)
1814 error ("Attempt to change byte length of a string");
1817 for (i
= 0; i
< size_byte
; i
++)
1818 *p
++ = str
[i
% len
];
1821 for (index
= 0; index
< size
; index
++)
1824 else if (BOOL_VECTOR_P (array
))
1826 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1828 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1830 charval
= (! NILP (item
) ? -1 : 0);
1831 for (index
= 0; index
< size_in_chars
; index
++)
1836 array
= wrong_type_argument (Qarrayp
, array
);
1842 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1844 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1846 Lisp_Object char_table
;
1848 CHECK_CHAR_TABLE (char_table
, 0);
1850 return XCHAR_TABLE (char_table
)->purpose
;
1853 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1855 "Return the parent char-table of CHAR-TABLE.\n\
1856 The value is either nil or another char-table.\n\
1857 If CHAR-TABLE holds nil for a given character,\n\
1858 then the actual applicable value is inherited from the parent char-table\n\
1859 \(or from its parents, if necessary).")
1861 Lisp_Object char_table
;
1863 CHECK_CHAR_TABLE (char_table
, 0);
1865 return XCHAR_TABLE (char_table
)->parent
;
1868 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1870 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1871 PARENT must be either nil or another char-table.")
1872 (char_table
, parent
)
1873 Lisp_Object char_table
, parent
;
1877 CHECK_CHAR_TABLE (char_table
, 0);
1881 CHECK_CHAR_TABLE (parent
, 0);
1883 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1884 if (EQ (temp
, char_table
))
1885 error ("Attempt to make a chartable be its own parent");
1888 XCHAR_TABLE (char_table
)->parent
= parent
;
1893 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1895 "Return the value of CHAR-TABLE's extra-slot number N.")
1897 Lisp_Object char_table
, n
;
1899 CHECK_CHAR_TABLE (char_table
, 1);
1900 CHECK_NUMBER (n
, 2);
1902 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1903 args_out_of_range (char_table
, n
);
1905 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1908 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1909 Sset_char_table_extra_slot
,
1911 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1912 (char_table
, n
, value
)
1913 Lisp_Object char_table
, n
, value
;
1915 CHECK_CHAR_TABLE (char_table
, 1);
1916 CHECK_NUMBER (n
, 2);
1918 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1919 args_out_of_range (char_table
, n
);
1921 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1924 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1926 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1927 RANGE should be nil (for the default value)\n\
1928 a vector which identifies a character set or a row of a character set,\n\
1929 a character set name, or a character code.")
1931 Lisp_Object char_table
, range
;
1935 CHECK_CHAR_TABLE (char_table
, 0);
1937 if (EQ (range
, Qnil
))
1938 return XCHAR_TABLE (char_table
)->defalt
;
1939 else if (INTEGERP (range
))
1940 return Faref (char_table
, range
);
1941 else if (SYMBOLP (range
))
1943 Lisp_Object charset_info
;
1945 charset_info
= Fget (range
, Qcharset
);
1946 CHECK_VECTOR (charset_info
, 0);
1948 return Faref (char_table
,
1949 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1952 else if (VECTORP (range
))
1954 if (XVECTOR (range
)->size
== 1)
1955 return Faref (char_table
,
1956 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1959 int size
= XVECTOR (range
)->size
;
1960 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1961 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1962 size
<= 1 ? Qnil
: val
[1],
1963 size
<= 2 ? Qnil
: val
[2]);
1964 return Faref (char_table
, ch
);
1968 error ("Invalid RANGE argument to `char-table-range'");
1971 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1973 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1974 RANGE should be t (for all characters), nil (for the default value)\n\
1975 a vector which identifies a character set or a row of a character set,\n\
1976 a coding system, or a character code.")
1977 (char_table
, range
, value
)
1978 Lisp_Object char_table
, range
, value
;
1982 CHECK_CHAR_TABLE (char_table
, 0);
1985 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1986 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1987 else if (EQ (range
, Qnil
))
1988 XCHAR_TABLE (char_table
)->defalt
= value
;
1989 else if (SYMBOLP (range
))
1991 Lisp_Object charset_info
;
1993 charset_info
= Fget (range
, Qcharset
);
1994 CHECK_VECTOR (charset_info
, 0);
1996 return Faset (char_table
,
1997 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2001 else if (INTEGERP (range
))
2002 Faset (char_table
, range
, value
);
2003 else if (VECTORP (range
))
2005 if (XVECTOR (range
)->size
== 1)
2006 return Faset (char_table
,
2007 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2011 int size
= XVECTOR (range
)->size
;
2012 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2013 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2014 size
<= 1 ? Qnil
: val
[1],
2015 size
<= 2 ? Qnil
: val
[2]);
2016 return Faset (char_table
, ch
, value
);
2020 error ("Invalid RANGE argument to `set-char-table-range'");
2025 DEFUN ("set-char-table-default", Fset_char_table_default
,
2026 Sset_char_table_default
, 3, 3, 0,
2027 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2028 The generic character specifies the group of characters.\n\
2029 See also the documentation of make-char.")
2030 (char_table
, ch
, value
)
2031 Lisp_Object char_table
, ch
, value
;
2033 int c
, i
, charset
, code1
, code2
;
2036 CHECK_CHAR_TABLE (char_table
, 0);
2037 CHECK_NUMBER (ch
, 1);
2040 SPLIT_CHAR (c
, charset
, code1
, code2
);
2042 /* Since we may want to set the default value for a character set
2043 not yet defined, we check only if the character set is in the
2044 valid range or not, instead of it is already defined or not. */
2045 if (! CHARSET_VALID_P (charset
))
2046 invalid_character (c
);
2048 if (charset
== CHARSET_ASCII
)
2049 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2051 /* Even if C is not a generic char, we had better behave as if a
2052 generic char is specified. */
2053 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2055 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2058 if (SUB_CHAR_TABLE_P (temp
))
2059 XCHAR_TABLE (temp
)->defalt
= value
;
2061 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2065 if (! SUB_CHAR_TABLE_P (char_table
))
2066 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2067 = make_sub_char_table (temp
));
2068 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2069 if (SUB_CHAR_TABLE_P (temp
))
2070 XCHAR_TABLE (temp
)->defalt
= value
;
2072 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2076 /* Look up the element in TABLE at index CH,
2077 and return it as an integer.
2078 If the element is nil, return CH itself.
2079 (Actually we do that for any non-integer.) */
2082 char_table_translate (table
, ch
)
2087 value
= Faref (table
, make_number (ch
));
2088 if (! INTEGERP (value
))
2090 return XINT (value
);
2093 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2094 character or group of characters that share a value.
2095 DEPTH is the current depth in the originally specified
2096 chartable, and INDICES contains the vector indices
2097 for the levels our callers have descended.
2099 ARG is passed to C_FUNCTION when that is called. */
2102 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2103 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2104 Lisp_Object function
, subtable
, arg
, *indices
;
2111 /* At first, handle ASCII and 8-bit European characters. */
2112 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2114 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2116 (*c_function
) (arg
, make_number (i
), elt
);
2118 call2 (function
, make_number (i
), elt
);
2120 #if 0 /* If the char table has entries for higher characters,
2121 we should report them. */
2122 if (NILP (current_buffer
->enable_multibyte_characters
))
2125 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2130 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2135 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2137 XSETFASTINT (indices
[depth
], i
);
2139 if (SUB_CHAR_TABLE_P (elt
))
2142 error ("Too deep char table");
2143 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2147 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2149 if (CHARSET_DEFINED_P (charset
))
2151 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2152 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2153 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2155 (*c_function
) (arg
, make_number (c
), elt
);
2157 call2 (function
, make_number (c
), elt
);
2163 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2165 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2166 FUNCTION is called with two arguments--a key and a value.\n\
2167 The key is always a possible IDX argument to `aref'.")
2168 (function
, char_table
)
2169 Lisp_Object function
, char_table
;
2171 /* The depth of char table is at most 3. */
2172 Lisp_Object indices
[3];
2174 CHECK_CHAR_TABLE (char_table
, 1);
2176 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2186 Lisp_Object args
[2];
2189 return Fnconc (2, args
);
2191 return Fnconc (2, &s1
);
2192 #endif /* NO_ARG_ARRAY */
2195 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2196 "Concatenate any number of lists by altering them.\n\
2197 Only the last argument is not altered, and need not be a list.")
2202 register int argnum
;
2203 register Lisp_Object tail
, tem
, val
;
2207 for (argnum
= 0; argnum
< nargs
; argnum
++)
2210 if (NILP (tem
)) continue;
2215 if (argnum
+ 1 == nargs
) break;
2218 tem
= wrong_type_argument (Qlistp
, tem
);
2227 tem
= args
[argnum
+ 1];
2228 Fsetcdr (tail
, tem
);
2230 args
[argnum
+ 1] = tail
;
2236 /* This is the guts of all mapping functions.
2237 Apply FN to each element of SEQ, one by one,
2238 storing the results into elements of VALS, a C vector of Lisp_Objects.
2239 LENI is the length of VALS, which should also be the length of SEQ. */
2242 mapcar1 (leni
, vals
, fn
, seq
)
2245 Lisp_Object fn
, seq
;
2247 register Lisp_Object tail
;
2250 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2252 /* Don't let vals contain any garbage when GC happens. */
2253 for (i
= 0; i
< leni
; i
++)
2256 GCPRO3 (dummy
, fn
, seq
);
2258 gcpro1
.nvars
= leni
;
2259 /* We need not explicitly protect `tail' because it is used only on lists, and
2260 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2264 for (i
= 0; i
< leni
; i
++)
2266 dummy
= XVECTOR (seq
)->contents
[i
];
2267 vals
[i
] = call1 (fn
, dummy
);
2270 else if (BOOL_VECTOR_P (seq
))
2272 for (i
= 0; i
< leni
; i
++)
2275 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2276 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2281 vals
[i
] = call1 (fn
, dummy
);
2284 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2286 /* Single-byte string. */
2287 for (i
= 0; i
< leni
; i
++)
2289 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2290 vals
[i
] = call1 (fn
, dummy
);
2293 else if (STRINGP (seq
))
2295 /* Multi-byte string. */
2296 int len_byte
= STRING_BYTES (XSTRING (seq
));
2299 for (i
= 0, i_byte
= 0; i
< leni
;)
2304 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2305 XSETFASTINT (dummy
, c
);
2306 vals
[i_before
] = call1 (fn
, dummy
);
2309 else /* Must be a list, since Flength did not get an error */
2312 for (i
= 0; i
< leni
; i
++)
2314 vals
[i
] = call1 (fn
, Fcar (tail
));
2315 tail
= XCONS (tail
)->cdr
;
2322 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2323 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2324 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2325 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2326 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2327 (function
, sequence
, separator
)
2328 Lisp_Object function
, sequence
, separator
;
2333 register Lisp_Object
*args
;
2335 struct gcpro gcpro1
;
2337 len
= Flength (sequence
);
2339 nargs
= leni
+ leni
- 1;
2340 if (nargs
< 0) return build_string ("");
2342 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2345 mapcar1 (leni
, args
, function
, sequence
);
2348 for (i
= leni
- 1; i
>= 0; i
--)
2349 args
[i
+ i
] = args
[i
];
2351 for (i
= 1; i
< nargs
; i
+= 2)
2352 args
[i
] = separator
;
2354 return Fconcat (nargs
, args
);
2357 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2358 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2359 The result is a list just as long as SEQUENCE.\n\
2360 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2361 (function
, sequence
)
2362 Lisp_Object function
, sequence
;
2364 register Lisp_Object len
;
2366 register Lisp_Object
*args
;
2368 len
= Flength (sequence
);
2369 leni
= XFASTINT (len
);
2370 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2372 mapcar1 (leni
, args
, function
, sequence
);
2374 return Flist (leni
, args
);
2377 /* Anything that calls this function must protect from GC! */
2379 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2380 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2381 Takes one argument, which is the string to display to ask the question.\n\
2382 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2383 No confirmation of the answer is requested; a single character is enough.\n\
2384 Also accepts Space to mean yes, or Delete to mean no.\n\
2386 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2391 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2392 register int answer
;
2393 Lisp_Object xprompt
;
2394 Lisp_Object args
[2];
2395 struct gcpro gcpro1
, gcpro2
;
2396 int count
= specpdl_ptr
- specpdl
;
2398 specbind (Qcursor_in_echo_area
, Qt
);
2400 map
= Fsymbol_value (intern ("query-replace-map"));
2402 CHECK_STRING (prompt
, 0);
2404 GCPRO2 (prompt
, xprompt
);
2410 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2414 Lisp_Object pane
, menu
;
2415 redisplay_preserve_echo_area ();
2416 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2417 Fcons (Fcons (build_string ("No"), Qnil
),
2419 menu
= Fcons (prompt
, pane
);
2420 obj
= Fx_popup_dialog (Qt
, menu
);
2421 answer
= !NILP (obj
);
2424 #endif /* HAVE_MENUS */
2425 cursor_in_echo_area
= 1;
2426 choose_minibuf_frame ();
2427 message_with_string ("%s(y or n) ", xprompt
, 0);
2429 if (minibuffer_auto_raise
)
2431 Lisp_Object mini_frame
;
2433 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2435 Fraise_frame (mini_frame
);
2438 obj
= read_filtered_event (1, 0, 0, 0);
2439 cursor_in_echo_area
= 0;
2440 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2443 key
= Fmake_vector (make_number (1), obj
);
2444 def
= Flookup_key (map
, key
, Qt
);
2445 answer_string
= Fsingle_key_description (obj
);
2447 if (EQ (def
, intern ("skip")))
2452 else if (EQ (def
, intern ("act")))
2457 else if (EQ (def
, intern ("recenter")))
2463 else if (EQ (def
, intern ("quit")))
2465 /* We want to exit this command for exit-prefix,
2466 and this is the only way to do it. */
2467 else if (EQ (def
, intern ("exit-prefix")))
2472 /* If we don't clear this, then the next call to read_char will
2473 return quit_char again, and we'll enter an infinite loop. */
2478 if (EQ (xprompt
, prompt
))
2480 args
[0] = build_string ("Please answer y or n. ");
2482 xprompt
= Fconcat (2, args
);
2487 if (! noninteractive
)
2489 cursor_in_echo_area
= -1;
2490 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2494 unbind_to (count
, Qnil
);
2495 return answer
? Qt
: Qnil
;
2498 /* This is how C code calls `yes-or-no-p' and allows the user
2501 Anything that calls this function must protect from GC! */
2504 do_yes_or_no_p (prompt
)
2507 return call1 (intern ("yes-or-no-p"), prompt
);
2510 /* Anything that calls this function must protect from GC! */
2512 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2513 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2514 Takes one argument, which is the string to display to ask the question.\n\
2515 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2516 The user must confirm the answer with RET,\n\
2517 and can edit it until it has been confirmed.\n\
2519 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2524 register Lisp_Object ans
;
2525 Lisp_Object args
[2];
2526 struct gcpro gcpro1
;
2529 CHECK_STRING (prompt
, 0);
2532 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2536 Lisp_Object pane
, menu
, obj
;
2537 redisplay_preserve_echo_area ();
2538 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2539 Fcons (Fcons (build_string ("No"), Qnil
),
2542 menu
= Fcons (prompt
, pane
);
2543 obj
= Fx_popup_dialog (Qt
, menu
);
2547 #endif /* HAVE_MENUS */
2550 args
[1] = build_string ("(yes or no) ");
2551 prompt
= Fconcat (2, args
);
2557 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2558 Qyes_or_no_p_history
, Qnil
,
2560 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2565 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2573 message ("Please answer yes or no.");
2574 Fsleep_for (make_number (2), Qnil
);
2578 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2579 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2580 Each of the three load averages is multiplied by 100,\n\
2581 then converted to integer.\n\
2582 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2583 These floats are not multiplied by 100.\n\n\
2584 If the 5-minute or 15-minute load averages are not available, return a\n\
2585 shortened list, containing only those averages which are available.")
2587 Lisp_Object use_floats
;
2590 int loads
= getloadavg (load_ave
, 3);
2591 Lisp_Object ret
= Qnil
;
2594 error ("load-average not implemented for this operating system");
2598 Lisp_Object load
= (NILP (use_floats
) ?
2599 make_number ((int) (100.0 * load_ave
[loads
]))
2600 : make_float (load_ave
[loads
]));
2601 ret
= Fcons (load
, ret
);
2607 Lisp_Object Vfeatures
;
2609 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2610 "Returns t if FEATURE is present in this Emacs.\n\
2611 Use this to conditionalize execution of lisp code based on the presence or\n\
2612 absence of emacs or environment extensions.\n\
2613 Use `provide' to declare that a feature is available.\n\
2614 This function looks at the value of the variable `features'.")
2616 Lisp_Object feature
;
2618 register Lisp_Object tem
;
2619 CHECK_SYMBOL (feature
, 0);
2620 tem
= Fmemq (feature
, Vfeatures
);
2621 return (NILP (tem
)) ? Qnil
: Qt
;
2624 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2625 "Announce that FEATURE is a feature of the current Emacs.")
2627 Lisp_Object feature
;
2629 register Lisp_Object tem
;
2630 CHECK_SYMBOL (feature
, 0);
2631 if (!NILP (Vautoload_queue
))
2632 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2633 tem
= Fmemq (feature
, Vfeatures
);
2635 Vfeatures
= Fcons (feature
, Vfeatures
);
2636 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2640 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2641 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2642 If FEATURE is not a member of the list `features', then the feature\n\
2643 is not loaded; so load the file FILENAME.\n\
2644 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2645 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2646 If the optional third argument NOERROR is non-nil,\n\
2647 then return nil if the file is not found.\n\
2648 Normally the return value is FEATURE.")
2649 (feature
, file_name
, noerror
)
2650 Lisp_Object feature
, file_name
, noerror
;
2652 register Lisp_Object tem
;
2653 CHECK_SYMBOL (feature
, 0);
2654 tem
= Fmemq (feature
, Vfeatures
);
2655 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2658 int count
= specpdl_ptr
- specpdl
;
2660 /* Value saved here is to be restored into Vautoload_queue */
2661 record_unwind_protect (un_autoload
, Vautoload_queue
);
2662 Vautoload_queue
= Qt
;
2664 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2665 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2666 /* If load failed entirely, return nil. */
2668 return unbind_to (count
, Qnil
);
2670 tem
= Fmemq (feature
, Vfeatures
);
2672 error ("Required feature %s was not provided",
2673 XSYMBOL (feature
)->name
->data
);
2675 /* Once loading finishes, don't undo it. */
2676 Vautoload_queue
= Qt
;
2677 feature
= unbind_to (count
, feature
);
2682 /* Primitives for work of the "widget" library.
2683 In an ideal world, this section would not have been necessary.
2684 However, lisp function calls being as slow as they are, it turns
2685 out that some functions in the widget library (wid-edit.el) are the
2686 bottleneck of Widget operation. Here is their translation to C,
2687 for the sole reason of efficiency. */
2689 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2690 "Return non-nil if PLIST has the property PROP.\n\
2691 PLIST is a property list, which is a list of the form\n\
2692 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2693 Unlike `plist-get', this allows you to distinguish between a missing\n\
2694 property and a property with the value nil.\n\
2695 The value is actually the tail of PLIST whose car is PROP.")
2697 Lisp_Object plist
, prop
;
2699 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2702 plist
= XCDR (plist
);
2703 plist
= CDR (plist
);
2708 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2709 "In WIDGET, set PROPERTY to VALUE.\n\
2710 The value can later be retrieved with `widget-get'.")
2711 (widget
, property
, value
)
2712 Lisp_Object widget
, property
, value
;
2714 CHECK_CONS (widget
, 1);
2715 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2719 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2720 "In WIDGET, get the value of PROPERTY.\n\
2721 The value could either be specified when the widget was created, or\n\
2722 later with `widget-put'.")
2724 Lisp_Object widget
, property
;
2732 CHECK_CONS (widget
, 1);
2733 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2739 tmp
= XCAR (widget
);
2742 widget
= Fget (tmp
, Qwidget_type
);
2746 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2747 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2748 ARGS are passed as extra arguments to the function.")
2753 /* This function can GC. */
2754 Lisp_Object newargs
[3];
2755 struct gcpro gcpro1
, gcpro2
;
2758 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2759 newargs
[1] = args
[0];
2760 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2761 GCPRO2 (newargs
[0], newargs
[2]);
2762 result
= Fapply (3, newargs
);
2767 /* base64 encode/decode functions.
2768 Based on code from GNU recode. */
2770 #define MIME_LINE_LENGTH 76
2772 #define IS_ASCII(Character) \
2774 #define IS_BASE64(Character) \
2775 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2776 #define IS_BASE64_IGNORABLE(Character) \
2777 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2778 || (Character) == '\f' || (Character) == '\r')
2780 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2781 character or return retval if there are no characters left to
2783 #define READ_QUADRUPLET_BYTE(retval) \
2790 while (IS_BASE64_IGNORABLE (c))
2792 /* Don't use alloca for regions larger than this, lest we overflow
2794 #define MAX_ALLOCA 16*1024
2796 /* Table of characters coding the 64 values. */
2797 static char base64_value_to_char
[64] =
2799 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2800 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2801 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2802 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2803 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2804 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2805 '8', '9', '+', '/' /* 60-63 */
2808 /* Table of base64 values for first 128 characters. */
2809 static short base64_char_to_value
[128] =
2811 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2812 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2813 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2814 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2815 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2816 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2817 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2818 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2819 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2820 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2821 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2822 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2823 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2826 /* The following diagram shows the logical steps by which three octets
2827 get transformed into four base64 characters.
2829 .--------. .--------. .--------.
2830 |aaaaaabb| |bbbbcccc| |ccdddddd|
2831 `--------' `--------' `--------'
2833 .--------+--------+--------+--------.
2834 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2835 `--------+--------+--------+--------'
2837 .--------+--------+--------+--------.
2838 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2839 `--------+--------+--------+--------'
2841 The octets are divided into 6 bit chunks, which are then encoded into
2842 base64 characters. */
2845 static int base64_encode_1
P_ ((const char *, char *, int, int));
2846 static int base64_decode_1
P_ ((const char *, char *, int));
2848 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2850 "Base64-encode the region between BEG and END.\n\
2851 Return the length of the encoded text.\n\
2852 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2853 into shorter lines.")
2854 (beg
, end
, no_line_break
)
2855 Lisp_Object beg
, end
, no_line_break
;
2858 int allength
, length
;
2859 int ibeg
, iend
, encoded_length
;
2862 validate_region (&beg
, &end
);
2864 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2865 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2866 move_gap_both (XFASTINT (beg
), ibeg
);
2868 /* We need to allocate enough room for encoding the text.
2869 We need 33 1/3% more space, plus a newline every 76
2870 characters, and then we round up. */
2871 length
= iend
- ibeg
;
2872 allength
= length
+ length
/3 + 1;
2873 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2875 if (allength
<= MAX_ALLOCA
)
2876 encoded
= (char *) alloca (allength
);
2878 encoded
= (char *) xmalloc (allength
);
2879 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2880 NILP (no_line_break
));
2881 if (encoded_length
> allength
)
2884 /* Now we have encoded the region, so we insert the new contents
2885 and delete the old. (Insert first in order to preserve markers.) */
2886 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2887 insert (encoded
, encoded_length
);
2888 if (allength
> MAX_ALLOCA
)
2890 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2892 /* If point was outside of the region, restore it exactly; else just
2893 move to the beginning of the region. */
2894 if (old_pos
>= XFASTINT (end
))
2895 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2896 else if (old_pos
> XFASTINT (beg
))
2897 old_pos
= XFASTINT (beg
);
2900 /* We return the length of the encoded text. */
2901 return make_number (encoded_length
);
2904 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2906 "Base64-encode STRING and return the result.\n\
2907 Optional second argument NO-LINE-BREAK means do not break long lines\n\
2908 into shorter lines.")
2909 (string
, no_line_break
)
2910 Lisp_Object string
, no_line_break
;
2912 int allength
, length
, encoded_length
;
2914 Lisp_Object encoded_string
;
2916 CHECK_STRING (string
, 1);
2918 /* We need to allocate enough room for encoding the text.
2919 We need 33 1/3% more space, plus a newline every 76
2920 characters, and then we round up. */
2921 length
= STRING_BYTES (XSTRING (string
));
2922 allength
= length
+ length
/3 + 1;
2923 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2925 /* We need to allocate enough room for decoding the text. */
2926 if (allength
<= MAX_ALLOCA
)
2927 encoded
= (char *) alloca (allength
);
2929 encoded
= (char *) xmalloc (allength
);
2931 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2932 encoded
, length
, NILP (no_line_break
));
2933 if (encoded_length
> allength
)
2936 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
2937 if (allength
> MAX_ALLOCA
)
2940 return encoded_string
;
2944 base64_encode_1 (from
, to
, length
, line_break
)
2950 int counter
= 0, i
= 0;
2959 /* Wrap line every 76 characters. */
2963 if (counter
< MIME_LINE_LENGTH
/ 4)
2972 /* Process first byte of a triplet. */
2974 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
2975 value
= (0x03 & c
) << 4;
2977 /* Process second byte of a triplet. */
2981 *e
++ = base64_value_to_char
[value
];
2989 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
2990 value
= (0x0f & c
) << 2;
2992 /* Process third byte of a triplet. */
2996 *e
++ = base64_value_to_char
[value
];
3003 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3004 *e
++ = base64_value_to_char
[0x3f & c
];
3011 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3013 "Base64-decode the region between BEG and END.\n\
3014 Return the length of the decoded text.\n\
3015 If the region can't be decoded, return nil and don't modify the buffer.")
3017 Lisp_Object beg
, end
;
3019 int ibeg
, iend
, length
;
3025 validate_region (&beg
, &end
);
3027 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3028 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3030 length
= iend
- ibeg
;
3031 /* We need to allocate enough room for decoding the text. */
3032 if (length
<= MAX_ALLOCA
)
3033 decoded
= (char *) alloca (length
);
3035 decoded
= (char *) xmalloc (length
);
3037 move_gap_both (XFASTINT (beg
), ibeg
);
3038 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3039 if (decoded_length
> length
)
3042 if (decoded_length
< 0)
3044 /* The decoding wasn't possible. */
3045 if (length
> MAX_ALLOCA
)
3050 /* Now we have decoded the region, so we insert the new contents
3051 and delete the old. (Insert first in order to preserve markers.) */
3052 /* We insert two spaces, then insert the decoded text in between
3053 them, at last, delete those extra two spaces. This is to avoid
3054 byte combining while inserting. */
3055 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3056 insert_1_both (" ", 2, 2, 0, 1, 0);
3057 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3058 insert (decoded
, decoded_length
);
3059 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3060 if (length
> MAX_ALLOCA
)
3062 /* At first delete the original text. This never cause byte
3064 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3065 iend
+ decoded_length
+ 2, 1);
3066 /* Next delete the extra spaces. This will cause byte combining
3068 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3069 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3070 inserted_chars
= PT
- XFASTINT (beg
);
3072 /* If point was outside of the region, restore it exactly; else just
3073 move to the beginning of the region. */
3074 if (old_pos
>= XFASTINT (end
))
3075 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3076 else if (old_pos
> XFASTINT (beg
))
3077 old_pos
= XFASTINT (beg
);
3080 return make_number (inserted_chars
);
3083 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3085 "Base64-decode STRING and return the result.")
3090 int length
, decoded_length
;
3091 Lisp_Object decoded_string
;
3093 CHECK_STRING (string
, 1);
3095 length
= STRING_BYTES (XSTRING (string
));
3096 /* We need to allocate enough room for decoding the text. */
3097 if (length
<= MAX_ALLOCA
)
3098 decoded
= (char *) alloca (length
);
3100 decoded
= (char *) xmalloc (length
);
3102 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3103 if (decoded_length
> length
)
3106 if (decoded_length
< 0)
3107 /* The decoding wasn't possible. */
3108 decoded_string
= Qnil
;
3110 decoded_string
= make_string (decoded
, decoded_length
);
3112 if (length
> MAX_ALLOCA
)
3115 return decoded_string
;
3119 base64_decode_1 (from
, to
, length
)
3127 unsigned long value
;
3131 /* Process first byte of a quadruplet. */
3133 READ_QUADRUPLET_BYTE (e
-to
);
3137 value
= base64_char_to_value
[c
] << 18;
3139 /* Process second byte of a quadruplet. */
3141 READ_QUADRUPLET_BYTE (-1);
3145 value
|= base64_char_to_value
[c
] << 12;
3147 *e
++ = (unsigned char) (value
>> 16);
3149 /* Process third byte of a quadruplet. */
3151 READ_QUADRUPLET_BYTE (-1);
3155 READ_QUADRUPLET_BYTE (-1);
3164 value
|= base64_char_to_value
[c
] << 6;
3166 *e
++ = (unsigned char) (0xff & value
>> 8);
3168 /* Process fourth byte of a quadruplet. */
3170 READ_QUADRUPLET_BYTE (-1);
3177 value
|= base64_char_to_value
[c
];
3179 *e
++ = (unsigned char) (0xff & value
);
3185 /***********************************************************************
3187 ***** Hash Tables *****
3189 ***********************************************************************/
3191 /* Implemented by gerd@gnu.org. This hash table implementation was
3192 inspired by CMUCL hash tables. */
3196 1. For small tables, association lists are probably faster than
3197 hash tables because they have lower overhead.
3199 For uses of hash tables where the O(1) behavior of table
3200 operations is not a requirement, it might therefore be a good idea
3201 not to hash. Instead, we could just do a linear search in the
3202 key_and_value vector of the hash table. This could be done
3203 if a `:linear-search t' argument is given to make-hash-table. */
3206 /* Return the contents of vector V at index IDX. */
3208 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3210 /* Value is the key part of entry IDX in hash table H. */
3212 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3214 /* Value is the value part of entry IDX in hash table H. */
3216 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3218 /* Value is the index of the next entry following the one at IDX
3221 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3223 /* Value is the hash code computed for entry IDX in hash table H. */
3225 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3227 /* Value is the index of the element in hash table H that is the
3228 start of the collision list at index IDX in the index vector of H. */
3230 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3232 /* Value is the size of hash table H. */
3234 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3236 /* The list of all weak hash tables. Don't staticpro this one. */
3238 Lisp_Object Vweak_hash_tables
;
3240 /* Various symbols. */
3242 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey_weak
, Qvalue_weak
;
3243 Lisp_Object Qkey_value_weak
;
3244 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweak
;
3245 Lisp_Object Qhash_table_test
;
3247 /* Function prototypes. */
3249 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3250 static int next_almost_prime
P_ ((int));
3251 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3252 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3253 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3254 static int cmpfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3255 Lisp_Object
, unsigned));
3256 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3257 Lisp_Object
, unsigned));
3258 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3259 Lisp_Object
, unsigned));
3260 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3261 unsigned, Lisp_Object
, unsigned));
3262 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3263 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3264 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3265 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3267 static unsigned sxhash_string
P_ ((unsigned char *, int));
3268 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3269 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3270 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3274 /***********************************************************************
3276 ***********************************************************************/
3278 /* If OBJ is a Lisp hash table, return a pointer to its struct
3279 Lisp_Hash_Table. Otherwise, signal an error. */
3281 static struct Lisp_Hash_Table
*
3282 check_hash_table (obj
)
3285 CHECK_HASH_TABLE (obj
, 0);
3286 return XHASH_TABLE (obj
);
3290 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3294 next_almost_prime (n
)
3307 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3308 which USED[I] is non-zero. If found at index I in ARGS, set
3309 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3310 -1. This function is used to extract a keyword/argument pair from
3311 a DEFUN parameter list. */
3314 get_key_arg (key
, nargs
, args
, used
)
3322 for (i
= 0; i
< nargs
- 1; ++i
)
3323 if (!used
[i
] && EQ (args
[i
], key
))
3338 /* Return a Lisp vector which has the same contents as VEC but has
3339 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3340 vector that are not copied from VEC are set to INIT. */
3343 larger_vector (vec
, new_size
, init
)
3348 struct Lisp_Vector
*v
;
3351 xassert (VECTORP (vec
));
3352 old_size
= XVECTOR (vec
)->size
;
3353 xassert (new_size
>= old_size
);
3355 v
= allocate_vectorlike (new_size
);
3357 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3358 old_size
* sizeof *v
->contents
);
3359 for (i
= old_size
; i
< new_size
; ++i
)
3360 v
->contents
[i
] = init
;
3361 XSETVECTOR (vec
, v
);
3366 /***********************************************************************
3368 ***********************************************************************/
3370 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3371 HASH2 in hash table H using `eq'. Value is non-zero if KEY1 and
3372 KEY2 are the same. */
3375 cmpfn_eq (h
, key1
, hash1
, key2
, hash2
)
3376 struct Lisp_Hash_Table
*h
;
3377 Lisp_Object key1
, key2
;
3378 unsigned hash1
, hash2
;
3380 return EQ (key1
, key2
);
3384 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3385 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3386 KEY2 are the same. */
3389 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3390 struct Lisp_Hash_Table
*h
;
3391 Lisp_Object key1
, key2
;
3392 unsigned hash1
, hash2
;
3394 return (EQ (key1
, key2
)
3397 && XFLOAT (key1
)->data
== XFLOAT (key2
)->data
));
3401 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3402 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3403 KEY2 are the same. */
3406 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3407 struct Lisp_Hash_Table
*h
;
3408 Lisp_Object key1
, key2
;
3409 unsigned hash1
, hash2
;
3411 return (EQ (key1
, key2
)
3413 && !NILP (Fequal (key1
, key2
))));
3417 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3418 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3419 if KEY1 and KEY2 are the same. */
3422 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3423 struct Lisp_Hash_Table
*h
;
3424 Lisp_Object key1
, key2
;
3425 unsigned hash1
, hash2
;
3429 Lisp_Object args
[3];
3431 args
[0] = h
->user_cmp_function
;
3434 return !NILP (Ffuncall (3, args
));
3441 /* Value is a hash code for KEY for use in hash table H which uses
3442 `eq' to compare keys. The hash code returned is guaranteed to fit
3443 in a Lisp integer. */
3447 struct Lisp_Hash_Table
*h
;
3450 /* Lisp strings can change their address. Don't try to compute a
3451 hash code for a string from its address. */
3453 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3455 return XUINT (key
) ^ XGCTYPE (key
);
3459 /* Value is a hash code for KEY for use in hash table H which uses
3460 `eql' to compare keys. The hash code returned is guaranteed to fit
3461 in a Lisp integer. */
3465 struct Lisp_Hash_Table
*h
;
3468 /* Lisp strings can change their address. Don't try to compute a
3469 hash code for a string from its address. */
3471 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3472 else if (FLOATP (key
))
3473 return sxhash (key
, 0);
3475 return XUINT (key
) ^ XGCTYPE (key
);
3479 /* Value is a hash code for KEY for use in hash table H which uses
3480 `equal' to compare keys. The hash code returned is guaranteed to fit
3481 in a Lisp integer. */
3484 hashfn_equal (h
, key
)
3485 struct Lisp_Hash_Table
*h
;
3488 return sxhash (key
, 0);
3492 /* Value is a hash code for KEY for use in hash table H which uses as
3493 user-defined function to compare keys. The hash code returned is
3494 guaranteed to fit in a Lisp integer. */
3497 hashfn_user_defined (h
, key
)
3498 struct Lisp_Hash_Table
*h
;
3501 Lisp_Object args
[2], hash
;
3503 args
[0] = h
->user_hash_function
;
3505 hash
= Ffuncall (2, args
);
3506 if (!INTEGERP (hash
))
3508 list2 (build_string ("Illegal hash code returned from \
3509 user-supplied hash function"),
3511 return XUINT (hash
);
3515 /* Create and initialize a new hash table.
3517 TEST specifies the test the hash table will use to compare keys.
3518 It must be either one of the predefined tests `eq', `eql' or
3519 `equal' or a symbol denoting a user-defined test named TEST with
3520 test and hash functions USER_TEST and USER_HASH.
3522 Give the table initial capacity SIZE, SIZE > 0, an integer.
3524 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3525 new size when it becomes full is computed by adding REHASH_SIZE to
3526 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3527 table's new size is computed by multiplying its old size with
3530 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3531 be resized when the ratio of (number of entries in the table) /
3532 (table size) is >= REHASH_THRESHOLD.
3534 WEAK specifies the weakness of the table. If non-nil, it must be
3535 one of the symbols `key-weak', `value-weak' or `key-value-weak'. */
3538 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3539 user_test
, user_hash
)
3540 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3541 Lisp_Object user_test
, user_hash
;
3543 struct Lisp_Hash_Table
*h
;
3544 struct Lisp_Vector
*v
;
3546 int index_size
, i
, len
, sz
;
3548 /* Preconditions. */
3549 xassert (SYMBOLP (test
));
3550 xassert (INTEGERP (size
) && XINT (size
) > 0);
3551 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3552 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3553 xassert (FLOATP (rehash_threshold
)
3554 && XFLOATINT (rehash_threshold
) > 0
3555 && XFLOATINT (rehash_threshold
) <= 1.0);
3557 /* Allocate a vector, and initialize it. */
3558 len
= VECSIZE (struct Lisp_Hash_Table
);
3559 v
= allocate_vectorlike (len
);
3561 for (i
= 0; i
< len
; ++i
)
3562 v
->contents
[i
] = Qnil
;
3564 /* Initialize hash table slots. */
3565 sz
= XFASTINT (size
);
3566 h
= (struct Lisp_Hash_Table
*) v
;
3569 if (EQ (test
, Qeql
))
3571 h
->cmpfn
= cmpfn_eql
;
3572 h
->hashfn
= hashfn_eql
;
3574 else if (EQ (test
, Qeq
))
3576 h
->cmpfn
= cmpfn_eq
;
3577 h
->hashfn
= hashfn_eq
;
3579 else if (EQ (test
, Qequal
))
3581 h
->cmpfn
= cmpfn_equal
;
3582 h
->hashfn
= hashfn_equal
;
3586 h
->user_cmp_function
= user_test
;
3587 h
->user_hash_function
= user_hash
;
3588 h
->cmpfn
= cmpfn_user_defined
;
3589 h
->hashfn
= hashfn_user_defined
;
3593 h
->rehash_threshold
= rehash_threshold
;
3594 h
->rehash_size
= rehash_size
;
3595 h
->count
= make_number (0);
3596 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3597 h
->hash
= Fmake_vector (size
, Qnil
);
3598 h
->next
= Fmake_vector (size
, Qnil
);
3599 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3600 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3602 /* Set up the free list. */
3603 for (i
= 0; i
< sz
- 1; ++i
)
3604 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3605 h
->next_free
= make_number (0);
3607 XSET_HASH_TABLE (table
, h
);
3608 xassert (HASH_TABLE_P (table
));
3609 xassert (XHASH_TABLE (table
) == h
);
3611 /* Maybe add this hash table to the list of all weak hash tables. */
3613 h
->next_weak
= Qnil
;
3616 h
->next_weak
= Vweak_hash_tables
;
3617 Vweak_hash_tables
= table
;
3624 /* Resize hash table H if it's too full. If H cannot be resized
3625 because it's already too large, throw an error. */
3628 maybe_resize_hash_table (h
)
3629 struct Lisp_Hash_Table
*h
;
3631 if (NILP (h
->next_free
))
3633 int old_size
= HASH_TABLE_SIZE (h
);
3634 int i
, new_size
, index_size
;
3636 if (INTEGERP (h
->rehash_size
))
3637 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3639 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3640 index_size
= next_almost_prime (new_size
3641 / XFLOATINT (h
->rehash_threshold
));
3642 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3643 error ("Hash table too large to resize");
3645 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3646 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3647 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3648 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3650 /* Update the free list. Do it so that new entries are added at
3651 the end of the free list. This makes some operations like
3653 for (i
= old_size
; i
< new_size
- 1; ++i
)
3654 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3656 if (!NILP (h
->next_free
))
3658 Lisp_Object last
, next
;
3660 last
= h
->next_free
;
3661 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3665 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3668 XSETFASTINT (h
->next_free
, old_size
);
3671 for (i
= 0; i
< old_size
; ++i
)
3672 if (!NILP (HASH_HASH (h
, i
)))
3674 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3675 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3676 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3677 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3683 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3684 the hash code of KEY. Value is the index of the entry in H
3685 matching KEY, or -1 if not found. */
3688 hash_lookup (h
, key
, hash
)
3689 struct Lisp_Hash_Table
*h
;
3694 int start_of_bucket
;
3697 hash_code
= h
->hashfn (h
, key
);
3701 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3702 idx
= HASH_INDEX (h
, start_of_bucket
);
3706 int i
= XFASTINT (idx
);
3707 if (h
->cmpfn (h
, key
, hash_code
, HASH_KEY (h
, i
), HASH_HASH (h
, i
)))
3709 idx
= HASH_NEXT (h
, i
);
3712 return NILP (idx
) ? -1 : XFASTINT (idx
);
3716 /* Put an entry into hash table H that associates KEY with VALUE.
3717 HASH is a previously computed hash code of KEY. */
3720 hash_put (h
, key
, value
, hash
)
3721 struct Lisp_Hash_Table
*h
;
3722 Lisp_Object key
, value
;
3725 int start_of_bucket
, i
;
3727 xassert ((hash
& ~VALMASK
) == 0);
3729 /* Increment count after resizing because resizing may fail. */
3730 maybe_resize_hash_table (h
);
3731 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3733 /* Store key/value in the key_and_value vector. */
3734 i
= XFASTINT (h
->next_free
);
3735 h
->next_free
= HASH_NEXT (h
, i
);
3736 HASH_KEY (h
, i
) = key
;
3737 HASH_VALUE (h
, i
) = value
;
3739 /* Remember its hash code. */
3740 HASH_HASH (h
, i
) = make_number (hash
);
3742 /* Add new entry to its collision chain. */
3743 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3744 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3745 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3749 /* Remove the entry matching KEY from hash table H, if there is one. */
3752 hash_remove (h
, key
)
3753 struct Lisp_Hash_Table
*h
;
3757 int start_of_bucket
;
3758 Lisp_Object idx
, prev
;
3760 hash_code
= h
->hashfn (h
, key
);
3761 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3762 idx
= HASH_INDEX (h
, start_of_bucket
);
3767 int i
= XFASTINT (idx
);
3769 if (h
->cmpfn (h
, key
, hash_code
, HASH_KEY (h
, i
), HASH_HASH (h
, i
)))
3771 /* Take entry out of collision chain. */
3773 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3775 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3777 /* Clear slots in key_and_value and add the slots to
3779 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3780 HASH_NEXT (h
, i
) = h
->next_free
;
3781 h
->next_free
= make_number (i
);
3782 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3783 xassert (XINT (h
->count
) >= 0);
3789 idx
= HASH_NEXT (h
, i
);
3795 /* Clear hash table H. */
3799 struct Lisp_Hash_Table
*h
;
3801 if (XFASTINT (h
->count
) > 0)
3803 int i
, size
= HASH_TABLE_SIZE (h
);
3805 for (i
= 0; i
< size
; ++i
)
3807 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3808 HASH_KEY (h
, i
) = Qnil
;
3809 HASH_VALUE (h
, i
) = Qnil
;
3810 HASH_HASH (h
, i
) = Qnil
;
3813 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3814 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3816 h
->next_free
= make_number (0);
3817 h
->count
= make_number (0);
3823 /************************************************************************
3825 ************************************************************************/
3827 /* Remove elements from weak hash tables that don't survive the
3828 current garbage collection. Remove weak tables that don't survive
3829 from Vweak_hash_tables. Called from gc_sweep. */
3832 sweep_weak_hash_tables ()
3835 struct Lisp_Hash_Table
*h
= 0, *prev
;
3837 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
3840 h
= XHASH_TABLE (table
);
3842 if (h
->size
& ARRAY_MARK_FLAG
)
3844 if (XFASTINT (h
->count
) > 0)
3848 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3849 for (bucket
= 0; bucket
< n
; ++bucket
)
3851 Lisp_Object idx
, key
, value
, prev
, next
;
3853 /* Follow collision chain, removing entries that
3854 don't survive this garbage collection. */
3855 idx
= HASH_INDEX (h
, bucket
);
3857 while (!GC_NILP (idx
))
3860 int i
= XFASTINT (idx
);
3863 if (EQ (h
->weak
, Qkey_weak
))
3864 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
3865 else if (EQ (h
->weak
, Qvalue_weak
))
3866 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
3867 else if (EQ (h
->weak
, Qkey_value_weak
))
3868 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
3869 || !survives_gc_p (HASH_VALUE (h
, i
)));
3873 next
= HASH_NEXT (h
, i
);
3876 /* Take out of collision chain. */
3878 HASH_INDEX (h
, i
) = next
;
3880 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3882 /* Add to free list. */
3883 HASH_NEXT (h
, i
) = h
->next_free
;
3886 /* Clear key, value, and hash. */
3887 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3888 HASH_HASH (h
, i
) = Qnil
;
3890 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3894 /* Make sure key and value survive. */
3895 mark_object (&HASH_KEY (h
, i
));
3896 mark_object (&HASH_VALUE (h
, i
));
3906 /* Table is not marked, and will thus be freed.
3907 Take it out of the list of weak hash tables. */
3909 prev
->next_weak
= h
->next_weak
;
3911 Vweak_hash_tables
= h
->next_weak
;
3918 /***********************************************************************
3919 Hash Code Computation
3920 ***********************************************************************/
3922 /* Maximum depth up to which to dive into Lisp structures. */
3924 #define SXHASH_MAX_DEPTH 3
3926 /* Maximum length up to which to take list and vector elements into
3929 #define SXHASH_MAX_LEN 7
3931 /* Combine two integers X and Y for hashing. */
3933 #define SXHASH_COMBINE(X, Y) \
3934 ((((unsigned)(X) << 4) + ((unsigned)(X) >> 24) & 0x0fffffff) \
3938 /* Return a hash for string PTR which has length LEN. */
3941 sxhash_string (ptr
, len
)
3945 unsigned char *p
= ptr
;
3946 unsigned char *end
= p
+ len
;
3955 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
3958 return hash
& 07777777777;
3962 /* Return a hash for list LIST. DEPTH is the current depth in the
3963 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
3966 sxhash_list (list
, depth
)
3973 if (depth
< SXHASH_MAX_DEPTH
)
3975 CONSP (list
) && i
< SXHASH_MAX_LEN
;
3976 list
= XCDR (list
), ++i
)
3978 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
3979 hash
= SXHASH_COMBINE (hash
, hash2
);
3986 /* Return a hash for vector VECTOR. DEPTH is the current depth in
3987 the Lisp structure. */
3990 sxhash_vector (vec
, depth
)
3994 unsigned hash
= XVECTOR (vec
)->size
;
3997 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
3998 for (i
= 0; i
< n
; ++i
)
4000 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4001 hash
= SXHASH_COMBINE (hash
, hash2
);
4008 /* Return a hash for bool-vector VECTOR. */
4011 sxhash_bool_vector (vec
)
4014 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4017 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4018 for (i
= 0; i
< n
; ++i
)
4019 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4025 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4026 structure. Value is an unsigned integer clipped to VALMASK. */
4035 if (depth
> SXHASH_MAX_DEPTH
)
4038 switch (XTYPE (obj
))
4045 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4046 XSYMBOL (obj
)->name
->size
);
4054 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4057 /* This can be everything from a vector to an overlay. */
4058 case Lisp_Vectorlike
:
4060 /* According to the CL HyperSpec, two arrays are equal only if
4061 they are `eq', except for strings and bit-vectors. In
4062 Emacs, this works differently. We have to compare element
4064 hash
= sxhash_vector (obj
, depth
);
4065 else if (BOOL_VECTOR_P (obj
))
4066 hash
= sxhash_bool_vector (obj
);
4068 /* Others are `equal' if they are `eq', so let's take their
4074 hash
= sxhash_list (obj
, depth
);
4079 unsigned char *p
= (unsigned char *) &XFLOAT (obj
)->data
;
4080 unsigned char *e
= p
+ sizeof XFLOAT (obj
)->data
;
4081 for (hash
= 0; p
< e
; ++p
)
4082 hash
= SXHASH_COMBINE (hash
, *p
);
4090 return hash
& VALMASK
;
4095 /***********************************************************************
4097 ***********************************************************************/
4100 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4101 "Compute a hash code for OBJ and return it as integer.")
4105 unsigned hash
= sxhash (obj
, 0);;
4106 return make_number (hash
);
4110 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4111 "Create and return a new hash table.\n\
4112 Arguments are specified as keyword/argument pairs. The following\n\
4113 arguments are defined:\n\
4115 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.
4116 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4117 User-supplied test and hash functions can be specified via\n\
4118 `define-hash-table-test'.\n\
4120 :SIZE SIZE -- A hint as to how many elements will be put in the table.
4123 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4124 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4125 If it is a float, it must be > 1.0, and the new size is computed by\n\
4126 multiplying the old size with that factor. Default is 1.5.\n\
4128 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4129 Resize the hash table when ratio of the number of entries in the table.\n\
4132 :WEAK WEAK -- WEAK must be one of nil, t, `key-weak', `value-weak' or\n\
4133 `key-value-weak'. WEAK t means the same as `key-value-weak'. Elements\n\
4134 are removed from a weak hash table when their key, value or both \n\
4135 according to WEAKNESS are otherwise unreferenced. Default is nil.")
4140 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4141 Lisp_Object user_test
, user_hash
;
4145 /* The vector `used' is used to keep track of arguments that
4146 have been consumed. */
4147 used
= (char *) alloca (nargs
* sizeof *used
);
4148 bzero (used
, nargs
* sizeof *used
);
4150 /* See if there's a `:test TEST' among the arguments. */
4151 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4152 test
= i
< 0 ? Qeql
: args
[i
];
4153 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4155 /* See if it is a user-defined test. */
4158 prop
= Fget (test
, Qhash_table_test
);
4159 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4160 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4162 user_test
= Fnth (make_number (0), prop
);
4163 user_hash
= Fnth (make_number (1), prop
);
4166 user_test
= user_hash
= Qnil
;
4168 /* See if there's a `:size SIZE' argument. */
4169 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4170 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4171 if (!INTEGERP (size
) || XINT (size
) <= 0)
4173 list2 (build_string ("Illegal hash table size"),
4176 /* Look for `:rehash-size SIZE'. */
4177 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4178 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4179 if (!NUMBERP (rehash_size
)
4180 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4181 || XFLOATINT (rehash_size
) <= 1.0)
4183 list2 (build_string ("Illegal hash table rehash size"),
4186 /* Look for `:rehash-threshold THRESHOLD'. */
4187 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4188 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4189 if (!FLOATP (rehash_threshold
)
4190 || XFLOATINT (rehash_threshold
) <= 0.0
4191 || XFLOATINT (rehash_threshold
) > 1.0)
4193 list2 (build_string ("Illegal hash table rehash threshold"),
4196 /* Look for `:weak WEAK'. */
4197 i
= get_key_arg (QCweak
, nargs
, args
, used
);
4198 weak
= i
< 0 ? Qnil
: args
[i
];
4200 weak
= Qkey_value_weak
;
4202 && !EQ (weak
, Qkey_weak
)
4203 && !EQ (weak
, Qvalue_weak
)
4204 && !EQ (weak
, Qkey_value_weak
))
4205 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4208 /* Now, all args should have been used up, or there's a problem. */
4209 for (i
= 0; i
< nargs
; ++i
)
4212 list2 (build_string ("Invalid argument list"), args
[i
]));
4214 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4215 user_test
, user_hash
);
4219 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, MANY
, 0,
4220 "Create a new hash table.\n\
4221 Optional first argument SIZE is a hint to the implementation as\n\
4222 to how many elements will be put in the table. Default is 65.\n\
4224 Optional second argument TEST specifies how to compare keys in\n\
4225 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4226 is `eql'. New tests can be defined with `define-hash-table-test'.\n\
4228 Optional third argument WEAK must be one of nil, t, `key-weak',\n\
4229 `value-weak' or `key-value-weak'. WEAK t means the same as\n\
4230 `key-value-weak'. Default is nil. Elements of weak hash tables\n\
4231 are removed when their key, value or both are otherwise unreferenced.\n\
4233 The rest of the optional arguments are keyword/value pairs. The\n\
4234 following are recognized:\n\
4236 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4237 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4238 If it is a float, it must be > 1.0, and the new size is computed by\n\
4239 multiplying the old size with that factor. Default is 1.5.\n\
4241 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4242 Resize the hash table when ratio of the number of entries in the table.\n\
4248 Lisp_Object args2
[nargs
+ 6];
4251 /* Recognize size argument. */
4253 if (INTEGERP (args
[i
]))
4255 args2
[j
++] = QCsize
;
4256 args2
[j
++] = args
[i
++];
4259 /* Recognize test argument. */
4260 if (SYMBOLP (args
[i
])
4261 && !EQ (args
[i
], QCrehash_size
)
4262 && !EQ (args
[i
], QCrehash_threshold
)
4263 && !EQ (args
[i
], QCweak
))
4265 args2
[j
++] = QCtest
;
4266 args2
[j
++] = args
[i
++];
4269 /* Recognize weakness argument. */
4270 if (EQ (args
[i
], Qt
)
4272 || EQ (args
[i
], Qkey_weak
)
4273 || EQ (args
[i
], Qvalue_weak
)
4274 || EQ (args
[i
], Qkey_value_weak
))
4276 args2
[j
++] = QCweak
;
4277 args2
[j
++] = args
[i
++];
4280 /* Copy remaining arguments. */
4282 args2
[j
++] = args
[i
++];
4284 return Fmake_hash_table (j
, args2
);
4288 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4289 "Return the number of elements in TABLE.")
4293 return check_hash_table (table
)->count
;
4297 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4298 Shash_table_rehash_size
, 1, 1, 0,
4299 "Return the current rehash size of TABLE.")
4303 return check_hash_table (table
)->rehash_size
;
4307 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4308 Shash_table_rehash_threshold
, 1, 1, 0,
4309 "Return the current rehash threshold of TABLE.")
4313 return check_hash_table (table
)->rehash_threshold
;
4317 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4318 "Return the size of TABLE.\n\
4319 The size can be used as an argument to `make-hash-table' to create\n\
4320 a hash table than can hold as many elements of TABLE holds\n\
4321 without need for resizing.")
4325 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4326 return make_number (HASH_TABLE_SIZE (h
));
4330 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4331 "Return the test TABLE uses.")
4335 return check_hash_table (table
)->test
;
4339 DEFUN ("hash-table-weak", Fhash_table_weak
, Shash_table_weak
, 1, 1, 0,
4340 "Return the weakness of TABLE.")
4344 return check_hash_table (table
)->weak
;
4348 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4349 "Return t if OBJ is a Lisp hash table object.")
4353 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4357 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4358 "Clear hash table TABLE.")
4362 hash_clear (check_hash_table (table
));
4367 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4368 "Look up KEY in TABLE and return its associated value.\n\
4369 If KEY is not found, return DFLT which defaults to nil.")
4371 Lisp_Object table
, key
;
4373 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4374 int i
= hash_lookup (h
, key
, NULL
);
4375 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4379 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4380 "Associate KEY with VALUE is hash table TABLE.\n\
4381 If KEY is already present in table, replace its current value with\n\
4384 Lisp_Object table
, key
, value
;
4386 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4390 i
= hash_lookup (h
, key
, &hash
);
4392 HASH_VALUE (h
, i
) = value
;
4394 hash_put (h
, key
, value
, hash
);
4400 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4401 "Remove KEY from TABLE.")
4403 Lisp_Object table
, key
;
4405 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4406 hash_remove (h
, key
);
4411 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4412 "Call FUNCTION for all entries in hash table TABLE.\n\
4413 FUNCTION is called with 2 arguments KEY and VALUE.")
4415 Lisp_Object function
, table
;
4417 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4418 Lisp_Object args
[3];
4421 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4422 if (!NILP (HASH_HASH (h
, i
)))
4425 args
[1] = HASH_KEY (h
, i
);
4426 args
[2] = HASH_VALUE (h
, i
);
4434 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4435 Sdefine_hash_table_test
, 3, 3, 0,
4436 "Define a new hash table test with name NAME, a symbol.\n\
4437 In hash tables create with NAME specified as test, use TEST to compare\n\
4438 keys, and HASH for computing hash codes of keys.\n\
4440 TEST must be a function taking two arguments and returning non-nil\n\
4441 if both arguments are the same. HASH must be a function taking\n\
4442 one argument and return an integer that is the hash code of the\n\
4443 argument. Hash code computation should use the whole value range of\n\
4444 integers, including negative integers.")
4446 Lisp_Object name
, test
, hash
;
4448 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4457 /* Hash table stuff. */
4458 Qhash_table_p
= intern ("hash-table-p");
4459 staticpro (&Qhash_table_p
);
4460 Qeq
= intern ("eq");
4462 Qeql
= intern ("eql");
4464 Qequal
= intern ("equal");
4465 staticpro (&Qequal
);
4466 QCtest
= intern (":test");
4467 staticpro (&QCtest
);
4468 QCsize
= intern (":size");
4469 staticpro (&QCsize
);
4470 QCrehash_size
= intern (":rehash-size");
4471 staticpro (&QCrehash_size
);
4472 QCrehash_threshold
= intern (":rehash-threshold");
4473 staticpro (&QCrehash_threshold
);
4474 QCweak
= intern (":weak");
4475 staticpro (&QCweak
);
4476 Qkey_weak
= intern ("key-weak");
4477 staticpro (&Qkey_weak
);
4478 Qvalue_weak
= intern ("value-weak");
4479 staticpro (&Qvalue_weak
);
4480 Qkey_value_weak
= intern ("key-value-weak");
4481 staticpro (&Qkey_value_weak
);
4482 Qhash_table_test
= intern ("hash-table-test");
4483 staticpro (&Qhash_table_test
);
4486 defsubr (&Smake_hash_table
);
4487 defsubr (&Smakehash
);
4488 defsubr (&Shash_table_count
);
4489 defsubr (&Shash_table_rehash_size
);
4490 defsubr (&Shash_table_rehash_threshold
);
4491 defsubr (&Shash_table_size
);
4492 defsubr (&Shash_table_test
);
4493 defsubr (&Shash_table_weak
);
4494 defsubr (&Shash_table_p
);
4495 defsubr (&Sclrhash
);
4496 defsubr (&Sgethash
);
4497 defsubr (&Sputhash
);
4498 defsubr (&Sremhash
);
4499 defsubr (&Smaphash
);
4500 defsubr (&Sdefine_hash_table_test
);
4502 Qstring_lessp
= intern ("string-lessp");
4503 staticpro (&Qstring_lessp
);
4504 Qprovide
= intern ("provide");
4505 staticpro (&Qprovide
);
4506 Qrequire
= intern ("require");
4507 staticpro (&Qrequire
);
4508 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4509 staticpro (&Qyes_or_no_p_history
);
4510 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4511 staticpro (&Qcursor_in_echo_area
);
4512 Qwidget_type
= intern ("widget-type");
4513 staticpro (&Qwidget_type
);
4515 staticpro (&string_char_byte_cache_string
);
4516 string_char_byte_cache_string
= Qnil
;
4518 Fset (Qyes_or_no_p_history
, Qnil
);
4520 DEFVAR_LISP ("features", &Vfeatures
,
4521 "A list of symbols which are the features of the executing emacs.\n\
4522 Used by `featurep' and `require', and altered by `provide'.");
4525 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4526 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4527 This applies to y-or-n and yes-or-no questions asked by commands\n\
4528 invoked by mouse clicks and mouse menu items.");
4531 defsubr (&Sidentity
);
4534 defsubr (&Ssafe_length
);
4535 defsubr (&Sstring_bytes
);
4536 defsubr (&Sstring_equal
);
4537 defsubr (&Scompare_strings
);
4538 defsubr (&Sstring_lessp
);
4541 defsubr (&Svconcat
);
4542 defsubr (&Scopy_sequence
);
4543 defsubr (&Sstring_make_multibyte
);
4544 defsubr (&Sstring_make_unibyte
);
4545 defsubr (&Sstring_as_multibyte
);
4546 defsubr (&Sstring_as_unibyte
);
4547 defsubr (&Scopy_alist
);
4548 defsubr (&Ssubstring
);
4560 defsubr (&Snreverse
);
4561 defsubr (&Sreverse
);
4563 defsubr (&Splist_get
);
4565 defsubr (&Splist_put
);
4568 defsubr (&Sfillarray
);
4569 defsubr (&Schar_table_subtype
);
4570 defsubr (&Schar_table_parent
);
4571 defsubr (&Sset_char_table_parent
);
4572 defsubr (&Schar_table_extra_slot
);
4573 defsubr (&Sset_char_table_extra_slot
);
4574 defsubr (&Schar_table_range
);
4575 defsubr (&Sset_char_table_range
);
4576 defsubr (&Sset_char_table_default
);
4577 defsubr (&Smap_char_table
);
4580 defsubr (&Smapconcat
);
4581 defsubr (&Sy_or_n_p
);
4582 defsubr (&Syes_or_no_p
);
4583 defsubr (&Sload_average
);
4584 defsubr (&Sfeaturep
);
4585 defsubr (&Srequire
);
4586 defsubr (&Sprovide
);
4587 defsubr (&Swidget_plist_member
);
4588 defsubr (&Swidget_put
);
4589 defsubr (&Swidget_get
);
4590 defsubr (&Swidget_apply
);
4591 defsubr (&Sbase64_encode_region
);
4592 defsubr (&Sbase64_decode_region
);
4593 defsubr (&Sbase64_encode_string
);
4594 defsubr (&Sbase64_decode_string
);
4601 Vweak_hash_tables
= Qnil
;