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
, MAX_CHAR
);
143 else if (BOOL_VECTOR_P (sequence
))
144 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
145 else if (COMPILEDP (sequence
))
146 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
147 else if (CONSP (sequence
))
150 while (CONSP (sequence
))
152 sequence
= XCDR (sequence
);
155 if (!CONSP (sequence
))
158 sequence
= XCDR (sequence
);
163 if (!NILP (sequence
))
164 wrong_type_argument (Qlistp
, sequence
);
166 val
= make_number (i
);
168 else if (NILP (sequence
))
169 XSETFASTINT (val
, 0);
172 sequence
= wrong_type_argument (Qsequencep
, sequence
);
178 /* This does not check for quits. That is safe
179 since it must terminate. */
181 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
182 "Return the length of a list, but avoid error or infinite loop.\n\
183 This function never gets an error. If LIST is not really a list,\n\
184 it returns 0. If LIST is circular, it returns a finite value\n\
185 which is at least the number of distinct elements.")
189 Lisp_Object tail
, halftail
, length
;
192 /* halftail is used to detect circular lists. */
194 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
196 if (EQ (tail
, halftail
) && len
!= 0)
200 halftail
= XCDR (halftail
);
203 XSETINT (length
, len
);
207 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
208 "Return the number of bytes in STRING.\n\
209 If STRING is a multibyte string, this is greater than the length of STRING.")
213 CHECK_STRING (string
, 1);
214 return make_number (STRING_BYTES (XSTRING (string
)));
217 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
218 "Return t if two strings have identical contents.\n\
219 Case is significant, but text properties are ignored.\n\
220 Symbols are also allowed; their print names are used instead.")
222 register Lisp_Object s1
, s2
;
225 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
227 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
228 CHECK_STRING (s1
, 0);
229 CHECK_STRING (s2
, 1);
231 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
232 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
233 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
238 DEFUN ("compare-strings", Fcompare_strings
,
239 Scompare_strings
, 6, 7, 0,
240 "Compare the contents of two strings, converting to multibyte if needed.\n\
241 In string STR1, skip the first START1 characters and stop at END1.\n\
242 In string STR2, skip the first START2 characters and stop at END2.\n\
243 END1 and END2 default to the full lengths of the respective strings.\n\
245 Case is significant in this comparison if IGNORE-CASE is nil.\n\
246 Unibyte strings are converted to multibyte for comparison.\n\
248 The value is t if the strings (or specified portions) match.\n\
249 If string STR1 is less, the value is a negative number N;\n\
250 - 1 - N is the number of characters that match at the beginning.\n\
251 If string STR1 is greater, the value is a positive number N;\n\
252 N - 1 is the number of characters that match at the beginning.")
253 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
254 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
256 register int end1_char
, end2_char
;
257 register int i1
, i1_byte
, i2
, i2_byte
;
259 CHECK_STRING (str1
, 0);
260 CHECK_STRING (str2
, 1);
262 start1
= make_number (0);
264 start2
= make_number (0);
265 CHECK_NATNUM (start1
, 2);
266 CHECK_NATNUM (start2
, 3);
268 CHECK_NATNUM (end1
, 4);
270 CHECK_NATNUM (end2
, 4);
275 i1_byte
= string_char_to_byte (str1
, i1
);
276 i2_byte
= string_char_to_byte (str2
, i2
);
278 end1_char
= XSTRING (str1
)->size
;
279 if (! NILP (end1
) && end1_char
> XINT (end1
))
280 end1_char
= XINT (end1
);
282 end2_char
= XSTRING (str2
)->size
;
283 if (! NILP (end2
) && end2_char
> XINT (end2
))
284 end2_char
= XINT (end2
);
286 while (i1
< end1_char
&& i2
< end2_char
)
288 /* When we find a mismatch, we must compare the
289 characters, not just the bytes. */
292 if (STRING_MULTIBYTE (str1
))
293 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
296 c1
= XSTRING (str1
)->data
[i1
++];
297 c1
= unibyte_char_to_multibyte (c1
);
300 if (STRING_MULTIBYTE (str2
))
301 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
304 c2
= XSTRING (str2
)->data
[i2
++];
305 c2
= unibyte_char_to_multibyte (c2
);
311 if (! NILP (ignore_case
))
315 tem
= Fupcase (make_number (c1
));
317 tem
= Fupcase (make_number (c2
));
324 /* Note that I1 has already been incremented
325 past the character that we are comparing;
326 hence we don't add or subtract 1 here. */
328 return make_number (- i1
);
330 return make_number (i1
);
334 return make_number (i1
- XINT (start1
) + 1);
336 return make_number (- i1
+ XINT (start1
) - 1);
341 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
342 "Return t if first arg string is less than second in lexicographic order.\n\
343 Case is significant.\n\
344 Symbols are also allowed; their print names are used instead.")
346 register Lisp_Object s1
, s2
;
349 register int i1
, i1_byte
, i2
, i2_byte
;
352 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
354 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
355 CHECK_STRING (s1
, 0);
356 CHECK_STRING (s2
, 1);
358 i1
= i1_byte
= i2
= i2_byte
= 0;
360 end
= XSTRING (s1
)->size
;
361 if (end
> XSTRING (s2
)->size
)
362 end
= XSTRING (s2
)->size
;
366 /* When we find a mismatch, we must compare the
367 characters, not just the bytes. */
370 if (STRING_MULTIBYTE (s1
))
371 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
373 c1
= XSTRING (s1
)->data
[i1
++];
375 if (STRING_MULTIBYTE (s2
))
376 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
378 c2
= XSTRING (s2
)->data
[i2
++];
381 return c1
< c2
? Qt
: Qnil
;
383 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
386 static Lisp_Object
concat ();
397 return concat (2, args
, Lisp_String
, 0);
399 return concat (2, &s1
, Lisp_String
, 0);
400 #endif /* NO_ARG_ARRAY */
406 Lisp_Object s1
, s2
, s3
;
413 return concat (3, args
, Lisp_String
, 0);
415 return concat (3, &s1
, Lisp_String
, 0);
416 #endif /* NO_ARG_ARRAY */
419 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
420 "Concatenate all the arguments and make the result a list.\n\
421 The result is a list whose elements are the elements of all the arguments.\n\
422 Each argument may be a list, vector or string.\n\
423 The last argument is not copied, just used as the tail of the new list.")
428 return concat (nargs
, args
, Lisp_Cons
, 1);
431 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
432 "Concatenate all the arguments and make the result a string.\n\
433 The result is a string whose elements are the elements of all the arguments.\n\
434 Each argument may be a string or a list or vector of characters (integers).\n\
436 Do not use individual integers as arguments!\n\
437 The behavior of `concat' in that case will be changed later!\n\
438 If your program passes an integer as an argument to `concat',\n\
439 you should change it right away not to do so.")
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 "Concatenate all the arguments and make the result a vector.\n\
449 The result is a vector whose elements are the elements of all the arguments.\n\
450 Each argument may be a list, vector or string.")
455 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
458 /* Retrun a copy of a sub char table ARG. The elements except for a
459 nested sub char table are not copied. */
461 copy_sub_char_table (arg
)
464 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
467 /* Copy all the contents. */
468 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
469 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
470 /* Recursively copy any sub char-tables in the ordinary slots. */
471 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
472 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
473 XCHAR_TABLE (copy
)->contents
[i
]
474 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
480 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
481 "Return a copy of a list, vector or string.\n\
482 The elements of a list or vector are not copied; they are shared\n\
487 if (NILP (arg
)) return arg
;
489 if (CHAR_TABLE_P (arg
))
494 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
495 /* Copy all the slots, including the extra ones. */
496 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
497 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
498 * sizeof (Lisp_Object
)));
500 /* Recursively copy any sub char tables in the ordinary slots
501 for multibyte characters. */
502 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
503 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
504 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
505 XCHAR_TABLE (copy
)->contents
[i
]
506 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
511 if (BOOL_VECTOR_P (arg
))
515 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
517 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
518 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
523 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
524 arg
= wrong_type_argument (Qsequencep
, arg
);
525 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
528 /* In string STR of length LEN, see if bytes before STR[I] combine
529 with bytes after STR[I] to form a single character. If so, return
530 the number of bytes after STR[I] which combine in this way.
531 Otherwize, return 0. */
534 count_combining (str
, len
, i
)
538 int j
= i
- 1, bytes
;
540 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
542 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
543 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
545 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
546 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
549 /* This structure holds information of an argument of `concat' that is
550 a string and has text properties to be copied. */
553 int argnum
; /* refer to ARGS (arguments of `concat') */
554 int from
; /* refer to ARGS[argnum] (argument string) */
555 int to
; /* refer to VAL (the target string) */
559 concat (nargs
, args
, target_type
, last_special
)
562 enum Lisp_Type target_type
;
566 register Lisp_Object tail
;
567 register Lisp_Object
this;
570 register int result_len
;
571 register int result_len_byte
;
573 Lisp_Object last_tail
;
576 /* When we make a multibyte string, we can't copy text properties
577 while concatinating each string because the length of resulting
578 string can't be decided until we finish the whole concatination.
579 So, we record strings that have text properties to be copied
580 here, and copy the text properties after the concatination. */
581 struct textprop_rec
*textprops
;
582 /* Number of elments in textprops. */
583 int num_textprops
= 0;
585 /* In append, the last arg isn't treated like the others */
586 if (last_special
&& nargs
> 0)
589 last_tail
= args
[nargs
];
594 /* Canonicalize each argument. */
595 for (argnum
= 0; argnum
< nargs
; argnum
++)
598 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
599 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
602 args
[argnum
] = Fnumber_to_string (this);
604 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
608 /* Compute total length in chars of arguments in RESULT_LEN.
609 If desired output is a string, also compute length in bytes
610 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
611 whether the result should be a multibyte string. */
615 for (argnum
= 0; argnum
< nargs
; argnum
++)
619 len
= XFASTINT (Flength (this));
620 if (target_type
== Lisp_String
)
622 /* We must count the number of bytes needed in the string
623 as well as the number of characters. */
629 for (i
= 0; i
< len
; i
++)
631 ch
= XVECTOR (this)->contents
[i
];
633 wrong_type_argument (Qintegerp
, ch
);
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (this_len_byte
> 1)
639 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
640 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
641 else if (CONSP (this))
642 for (; CONSP (this); this = XCDR (this))
646 wrong_type_argument (Qintegerp
, ch
);
647 this_len_byte
= CHAR_BYTES (XINT (ch
));
648 result_len_byte
+= this_len_byte
;
649 if (this_len_byte
> 1)
652 else if (STRINGP (this))
654 if (STRING_MULTIBYTE (this))
657 result_len_byte
+= STRING_BYTES (XSTRING (this));
660 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
661 XSTRING (this)->size
);
668 if (! some_multibyte
)
669 result_len_byte
= result_len
;
671 /* Create the output object. */
672 if (target_type
== Lisp_Cons
)
673 val
= Fmake_list (make_number (result_len
), Qnil
);
674 else if (target_type
== Lisp_Vectorlike
)
675 val
= Fmake_vector (make_number (result_len
), Qnil
);
676 else if (some_multibyte
)
677 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
679 val
= make_uninit_string (result_len
);
681 /* In `append', if all but last arg are nil, return last arg. */
682 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
685 /* Copy the contents of the args into the result. */
687 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
689 toindex
= 0, toindex_byte
= 0;
694 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
696 for (argnum
= 0; argnum
< nargs
; argnum
++)
700 register unsigned int thisindex
= 0;
701 register unsigned int thisindex_byte
= 0;
705 thislen
= Flength (this), thisleni
= XINT (thislen
);
707 /* Between strings of the same kind, copy fast. */
708 if (STRINGP (this) && STRINGP (val
)
709 && STRING_MULTIBYTE (this) == some_multibyte
)
711 int thislen_byte
= STRING_BYTES (XSTRING (this));
714 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
715 STRING_BYTES (XSTRING (this)));
716 combined
= (some_multibyte
&& toindex_byte
> 0
717 ? count_combining (XSTRING (val
)->data
,
718 toindex_byte
+ thislen_byte
,
721 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
723 textprops
[num_textprops
].argnum
= argnum
;
724 /* We ignore text properties on characters being combined. */
725 textprops
[num_textprops
].from
= combined
;
726 textprops
[num_textprops
++].to
= toindex
;
728 toindex_byte
+= thislen_byte
;
729 toindex
+= thisleni
- combined
;
730 XSTRING (val
)->size
-= combined
;
732 /* Copy a single-byte string to a multibyte string. */
733 else if (STRINGP (this) && STRINGP (val
))
735 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
737 textprops
[num_textprops
].argnum
= argnum
;
738 textprops
[num_textprops
].from
= 0;
739 textprops
[num_textprops
++].to
= toindex
;
741 toindex_byte
+= copy_text (XSTRING (this)->data
,
742 XSTRING (val
)->data
+ toindex_byte
,
743 XSTRING (this)->size
, 0, 1);
747 /* Copy element by element. */
750 register Lisp_Object elt
;
752 /* Fetch next element of `this' arg into `elt', or break if
753 `this' is exhausted. */
754 if (NILP (this)) break;
756 elt
= XCAR (this), this = XCDR (this);
757 else if (thisindex
>= thisleni
)
759 else if (STRINGP (this))
762 if (STRING_MULTIBYTE (this))
764 FETCH_STRING_CHAR_ADVANCE (c
, this,
767 XSETFASTINT (elt
, c
);
771 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
773 && (XINT (elt
) >= 0240
774 || (XINT (elt
) >= 0200
775 && ! NILP (Vnonascii_translation_table
)))
776 && XINT (elt
) < 0400)
778 c
= unibyte_char_to_multibyte (XINT (elt
));
783 else if (BOOL_VECTOR_P (this))
786 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
787 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
794 elt
= XVECTOR (this)->contents
[thisindex
++];
796 /* Store this element into the result. */
803 else if (VECTORP (val
))
804 XVECTOR (val
)->contents
[toindex
++] = elt
;
807 CHECK_NUMBER (elt
, 0);
808 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
810 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
813 && count_combining (XSTRING (val
)->data
,
814 toindex_byte
, toindex_byte
- 1))
815 XSTRING (val
)->size
--;
820 /* If we have any multibyte characters,
821 we already decided to make a multibyte string. */
824 /* P exists as a variable
825 to avoid a bug on the Masscomp C compiler. */
826 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
828 toindex_byte
+= CHAR_STRING (c
, p
);
835 XCDR (prev
) = last_tail
;
837 if (num_textprops
> 0)
839 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
841 this = args
[textprops
[argnum
].argnum
];
842 copy_text_properties (make_number (textprops
[argnum
].from
),
843 XSTRING (this)->size
, this,
844 make_number (textprops
[argnum
].to
), val
, Qnil
);
850 static Lisp_Object string_char_byte_cache_string
;
851 static int string_char_byte_cache_charpos
;
852 static int string_char_byte_cache_bytepos
;
855 clear_string_char_byte_cache ()
857 string_char_byte_cache_string
= Qnil
;
860 /* Return the character index corresponding to CHAR_INDEX in STRING. */
863 string_char_to_byte (string
, char_index
)
868 int best_below
, best_below_byte
;
869 int best_above
, best_above_byte
;
871 if (! STRING_MULTIBYTE (string
))
874 best_below
= best_below_byte
= 0;
875 best_above
= XSTRING (string
)->size
;
876 best_above_byte
= STRING_BYTES (XSTRING (string
));
878 if (EQ (string
, string_char_byte_cache_string
))
880 if (string_char_byte_cache_charpos
< char_index
)
882 best_below
= string_char_byte_cache_charpos
;
883 best_below_byte
= string_char_byte_cache_bytepos
;
887 best_above
= string_char_byte_cache_charpos
;
888 best_above_byte
= string_char_byte_cache_bytepos
;
892 if (char_index
- best_below
< best_above
- char_index
)
894 while (best_below
< char_index
)
897 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
900 i_byte
= best_below_byte
;
904 while (best_above
> char_index
)
906 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
907 unsigned char *pbeg
= pend
- best_above_byte
;
908 unsigned char *p
= pend
- 1;
911 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
912 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
913 if (bytes
== pend
- p
)
914 best_above_byte
-= bytes
;
915 else if (bytes
> pend
- p
)
916 best_above_byte
-= (pend
- p
);
922 i_byte
= best_above_byte
;
925 string_char_byte_cache_bytepos
= i_byte
;
926 string_char_byte_cache_charpos
= i
;
927 string_char_byte_cache_string
= string
;
932 /* Return the character index corresponding to BYTE_INDEX in STRING. */
935 string_byte_to_char (string
, byte_index
)
940 int best_below
, best_below_byte
;
941 int best_above
, best_above_byte
;
943 if (! STRING_MULTIBYTE (string
))
946 best_below
= best_below_byte
= 0;
947 best_above
= XSTRING (string
)->size
;
948 best_above_byte
= STRING_BYTES (XSTRING (string
));
950 if (EQ (string
, string_char_byte_cache_string
))
952 if (string_char_byte_cache_bytepos
< byte_index
)
954 best_below
= string_char_byte_cache_charpos
;
955 best_below_byte
= string_char_byte_cache_bytepos
;
959 best_above
= string_char_byte_cache_charpos
;
960 best_above_byte
= string_char_byte_cache_bytepos
;
964 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
966 while (best_below_byte
< byte_index
)
969 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
972 i_byte
= best_below_byte
;
976 while (best_above_byte
> byte_index
)
978 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
979 unsigned char *pbeg
= pend
- best_above_byte
;
980 unsigned char *p
= pend
- 1;
983 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
984 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
985 if (bytes
== pend
- p
)
986 best_above_byte
-= bytes
;
987 else if (bytes
> pend
- p
)
988 best_above_byte
-= (pend
- p
);
994 i_byte
= best_above_byte
;
997 string_char_byte_cache_bytepos
= i_byte
;
998 string_char_byte_cache_charpos
= i
;
999 string_char_byte_cache_string
= string
;
1004 /* Convert STRING to a multibyte string.
1005 Single-byte characters 0240 through 0377 are converted
1006 by adding nonascii_insert_offset to each. */
1009 string_make_multibyte (string
)
1015 if (STRING_MULTIBYTE (string
))
1018 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1019 XSTRING (string
)->size
);
1020 /* If all the chars are ASCII, they won't need any more bytes
1021 once converted. In that case, we can return STRING itself. */
1022 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1025 buf
= (unsigned char *) alloca (nbytes
);
1026 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1029 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1032 /* Convert STRING to a single-byte string. */
1035 string_make_unibyte (string
)
1040 if (! STRING_MULTIBYTE (string
))
1043 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1045 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1048 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1051 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1053 "Return the multibyte equivalent of STRING.\n\
1054 The function `unibyte-char-to-multibyte' is used to convert\n\
1055 each unibyte character to a multibyte character.")
1059 CHECK_STRING (string
, 0);
1061 return string_make_multibyte (string
);
1064 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1066 "Return the unibyte equivalent of STRING.\n\
1067 Multibyte character codes are converted to unibyte\n\
1068 by using just the low 8 bits.")
1072 CHECK_STRING (string
, 0);
1074 return string_make_unibyte (string
);
1077 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1079 "Return a unibyte string with the same individual bytes as STRING.\n\
1080 If STRING is unibyte, the result is STRING itself.\n\
1081 Otherwise it is a newly created string, with no text properties.")
1085 CHECK_STRING (string
, 0);
1087 if (STRING_MULTIBYTE (string
))
1089 string
= Fcopy_sequence (string
);
1090 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1091 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1092 SET_STRING_BYTES (XSTRING (string
), -1);
1097 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1099 "Return a multibyte string with the same individual bytes as STRING.\n\
1100 If STRING is multibyte, the result is STRING itself.\n\
1101 Otherwise it is a newly created string, with no text properties.")
1105 CHECK_STRING (string
, 0);
1107 if (! STRING_MULTIBYTE (string
))
1109 int nbytes
= STRING_BYTES (XSTRING (string
));
1110 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1112 string
= Fcopy_sequence (string
);
1113 XSTRING (string
)->size
= newlen
;
1114 XSTRING (string
)->size_byte
= nbytes
;
1115 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1120 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1121 "Return a copy of ALIST.\n\
1122 This is an alist which represents the same mapping from objects to objects,\n\
1123 but does not share the alist structure with ALIST.\n\
1124 The objects mapped (cars and cdrs of elements of the alist)\n\
1125 are shared, however.\n\
1126 Elements of ALIST that are not conses are also shared.")
1130 register Lisp_Object tem
;
1132 CHECK_LIST (alist
, 0);
1135 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1136 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1138 register Lisp_Object car
;
1142 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1147 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1148 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1149 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1150 If FROM or TO is negative, it counts from the end.\n\
1152 This function allows vectors as well as strings.")
1155 register Lisp_Object from
, to
;
1160 int from_char
, to_char
;
1161 int from_byte
, to_byte
;
1163 if (! (STRINGP (string
) || VECTORP (string
)))
1164 wrong_type_argument (Qarrayp
, string
);
1166 CHECK_NUMBER (from
, 1);
1168 if (STRINGP (string
))
1170 size
= XSTRING (string
)->size
;
1171 size_byte
= STRING_BYTES (XSTRING (string
));
1174 size
= XVECTOR (string
)->size
;
1179 to_byte
= size_byte
;
1183 CHECK_NUMBER (to
, 2);
1185 to_char
= XINT (to
);
1189 if (STRINGP (string
))
1190 to_byte
= string_char_to_byte (string
, to_char
);
1193 from_char
= XINT (from
);
1196 if (STRINGP (string
))
1197 from_byte
= string_char_to_byte (string
, from_char
);
1199 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1200 args_out_of_range_3 (string
, make_number (from_char
),
1201 make_number (to_char
));
1203 if (STRINGP (string
))
1205 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1206 to_char
- from_char
, to_byte
- from_byte
,
1207 STRING_MULTIBYTE (string
));
1208 copy_text_properties (make_number (from_char
), make_number (to_char
),
1209 string
, make_number (0), res
, Qnil
);
1212 res
= Fvector (to_char
- from_char
,
1213 XVECTOR (string
)->contents
+ from_char
);
1218 /* Extract a substring of STRING, giving start and end positions
1219 both in characters and in bytes. */
1222 substring_both (string
, from
, from_byte
, to
, to_byte
)
1224 int from
, from_byte
, to
, to_byte
;
1230 if (! (STRINGP (string
) || VECTORP (string
)))
1231 wrong_type_argument (Qarrayp
, string
);
1233 if (STRINGP (string
))
1235 size
= XSTRING (string
)->size
;
1236 size_byte
= STRING_BYTES (XSTRING (string
));
1239 size
= XVECTOR (string
)->size
;
1241 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1242 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1244 if (STRINGP (string
))
1246 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1247 to
- from
, to_byte
- from_byte
,
1248 STRING_MULTIBYTE (string
));
1249 copy_text_properties (make_number (from
), make_number (to
),
1250 string
, make_number (0), res
, Qnil
);
1253 res
= Fvector (to
- from
,
1254 XVECTOR (string
)->contents
+ from
);
1259 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1260 "Take cdr N times on LIST, returns the result.")
1263 register Lisp_Object list
;
1265 register int i
, num
;
1266 CHECK_NUMBER (n
, 0);
1268 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1272 wrong_type_argument (Qlistp
, list
);
1278 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1279 "Return the Nth element of LIST.\n\
1280 N counts from zero. If LIST is not that long, nil is returned.")
1282 Lisp_Object n
, list
;
1284 return Fcar (Fnthcdr (n
, list
));
1287 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1288 "Return element of SEQUENCE at index N.")
1290 register Lisp_Object sequence
, n
;
1292 CHECK_NUMBER (n
, 0);
1295 if (CONSP (sequence
) || NILP (sequence
))
1296 return Fcar (Fnthcdr (n
, sequence
));
1297 else if (STRINGP (sequence
) || VECTORP (sequence
)
1298 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1299 return Faref (sequence
, n
);
1301 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1305 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1306 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1307 The value is actually the tail of LIST whose car is ELT.")
1309 register Lisp_Object elt
;
1312 register Lisp_Object tail
;
1313 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1315 register Lisp_Object tem
;
1317 wrong_type_argument (Qlistp
, list
);
1319 if (! NILP (Fequal (elt
, tem
)))
1326 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1327 "Return non-nil if ELT is an element of LIST.\n\
1328 Comparison done with EQ. The value is actually the tail of LIST\n\
1331 Lisp_Object elt
, list
;
1335 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1339 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1343 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1350 if (!CONSP (list
) && !NILP (list
))
1351 list
= wrong_type_argument (Qlistp
, list
);
1356 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1357 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1358 The value is actually the element of LIST whose car is KEY.\n\
1359 Elements of LIST that are not conses are ignored.")
1361 Lisp_Object key
, list
;
1368 || (CONSP (XCAR (list
))
1369 && EQ (XCAR (XCAR (list
)), key
)))
1374 || (CONSP (XCAR (list
))
1375 && EQ (XCAR (XCAR (list
)), key
)))
1380 || (CONSP (XCAR (list
))
1381 && EQ (XCAR (XCAR (list
)), key
)))
1389 result
= XCAR (list
);
1390 else if (NILP (list
))
1393 result
= wrong_type_argument (Qlistp
, list
);
1398 /* Like Fassq but never report an error and do not allow quits.
1399 Use only on lists known never to be circular. */
1402 assq_no_quit (key
, list
)
1403 Lisp_Object key
, list
;
1406 && (!CONSP (XCAR (list
))
1407 || !EQ (XCAR (XCAR (list
)), key
)))
1410 return CONSP (list
) ? XCAR (list
) : Qnil
;
1413 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1414 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1415 The value is actually the element of LIST whose car equals KEY.")
1417 Lisp_Object key
, list
;
1419 Lisp_Object result
, car
;
1424 || (CONSP (XCAR (list
))
1425 && (car
= XCAR (XCAR (list
)),
1426 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1431 || (CONSP (XCAR (list
))
1432 && (car
= XCAR (XCAR (list
)),
1433 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1438 || (CONSP (XCAR (list
))
1439 && (car
= XCAR (XCAR (list
)),
1440 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1448 result
= XCAR (list
);
1449 else if (NILP (list
))
1452 result
= wrong_type_argument (Qlistp
, list
);
1457 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1458 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1459 The value is actually the element of LIST whose cdr is KEY.")
1461 register Lisp_Object key
;
1469 || (CONSP (XCAR (list
))
1470 && EQ (XCDR (XCAR (list
)), key
)))
1475 || (CONSP (XCAR (list
))
1476 && EQ (XCDR (XCAR (list
)), key
)))
1481 || (CONSP (XCAR (list
))
1482 && EQ (XCDR (XCAR (list
)), key
)))
1491 else if (CONSP (list
))
1492 result
= XCAR (list
);
1494 result
= wrong_type_argument (Qlistp
, list
);
1499 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1500 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1501 The value is actually the element of LIST whose cdr equals KEY.")
1503 Lisp_Object key
, list
;
1505 Lisp_Object result
, cdr
;
1510 || (CONSP (XCAR (list
))
1511 && (cdr
= XCDR (XCAR (list
)),
1512 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1534 result
= XCAR (list
);
1535 else if (NILP (list
))
1538 result
= wrong_type_argument (Qlistp
, list
);
1543 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1544 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1545 The modified LIST is returned. Comparison is done with `eq'.\n\
1546 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1547 therefore, write `(setq foo (delq element foo))'\n\
1548 to be sure of changing the value of `foo'.")
1550 register Lisp_Object elt
;
1553 register Lisp_Object tail
, prev
;
1554 register Lisp_Object tem
;
1558 while (!NILP (tail
))
1561 wrong_type_argument (Qlistp
, list
);
1568 Fsetcdr (prev
, XCDR (tail
));
1578 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1579 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1580 The modified LIST is returned. Comparison is done with `equal'.\n\
1581 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1582 it is simply using a different list.\n\
1583 Therefore, write `(setq foo (delete element foo))'\n\
1584 to be sure of changing the value of `foo'.")
1586 register Lisp_Object elt
;
1589 register Lisp_Object tail
, prev
;
1590 register Lisp_Object tem
;
1594 while (!NILP (tail
))
1597 wrong_type_argument (Qlistp
, list
);
1599 if (! NILP (Fequal (elt
, tem
)))
1604 Fsetcdr (prev
, XCDR (tail
));
1614 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1615 "Reverse LIST by modifying cdr pointers.\n\
1616 Returns the beginning of the reversed list.")
1620 register Lisp_Object prev
, tail
, next
;
1622 if (NILP (list
)) return list
;
1625 while (!NILP (tail
))
1629 wrong_type_argument (Qlistp
, list
);
1631 Fsetcdr (tail
, prev
);
1638 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1639 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1640 See also the function `nreverse', which is used more often.")
1646 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1647 new = Fcons (XCAR (list
), new);
1649 wrong_type_argument (Qconsp
, list
);
1653 Lisp_Object
merge ();
1655 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1656 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1657 Returns the sorted list. LIST is modified by side effects.\n\
1658 PREDICATE is called with two elements of LIST, and should return T\n\
1659 if the first element is \"less\" than the second.")
1661 Lisp_Object list
, predicate
;
1663 Lisp_Object front
, back
;
1664 register Lisp_Object len
, tem
;
1665 struct gcpro gcpro1
, gcpro2
;
1666 register int length
;
1669 len
= Flength (list
);
1670 length
= XINT (len
);
1674 XSETINT (len
, (length
/ 2) - 1);
1675 tem
= Fnthcdr (len
, list
);
1677 Fsetcdr (tem
, Qnil
);
1679 GCPRO2 (front
, back
);
1680 front
= Fsort (front
, predicate
);
1681 back
= Fsort (back
, predicate
);
1683 return merge (front
, back
, predicate
);
1687 merge (org_l1
, org_l2
, pred
)
1688 Lisp_Object org_l1
, org_l2
;
1692 register Lisp_Object tail
;
1694 register Lisp_Object l1
, l2
;
1695 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1702 /* It is sufficient to protect org_l1 and org_l2.
1703 When l1 and l2 are updated, we copy the new values
1704 back into the org_ vars. */
1705 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1725 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1741 Fsetcdr (tail
, tem
);
1747 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1748 "Extract a value from a property list.\n\
1749 PLIST is a property list, which is a list of the form\n\
1750 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1751 corresponding to the given PROP, or nil if PROP is not\n\
1752 one of the properties on the list.")
1755 register Lisp_Object prop
;
1757 register Lisp_Object tail
;
1758 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1760 register Lisp_Object tem
;
1763 return Fcar (XCDR (tail
));
1768 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1769 "Return the value of SYMBOL's PROPNAME property.\n\
1770 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1772 Lisp_Object symbol
, propname
;
1774 CHECK_SYMBOL (symbol
, 0);
1775 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1778 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1779 "Change value in PLIST of PROP to VAL.\n\
1780 PLIST is a property list, which is a list of the form\n\
1781 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1782 If PROP is already a property on the list, its value is set to VAL,\n\
1783 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1784 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1785 The PLIST is modified by side effects.")
1788 register Lisp_Object prop
;
1791 register Lisp_Object tail
, prev
;
1792 Lisp_Object newcell
;
1794 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1795 tail
= XCDR (XCDR (tail
)))
1797 if (EQ (prop
, XCAR (tail
)))
1799 Fsetcar (XCDR (tail
), val
);
1804 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1808 Fsetcdr (XCDR (prev
), newcell
);
1812 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1813 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1814 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1815 (symbol
, propname
, value
)
1816 Lisp_Object symbol
, propname
, value
;
1818 CHECK_SYMBOL (symbol
, 0);
1819 XSYMBOL (symbol
)->plist
1820 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1824 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1825 "Return t if two Lisp objects have similar structure and contents.\n\
1826 They must have the same data type.\n\
1827 Conses are compared by comparing the cars and the cdrs.\n\
1828 Vectors and strings are compared element by element.\n\
1829 Numbers are compared by value, but integers cannot equal floats.\n\
1830 (Use `=' if you want integers and floats to be able to be equal.)\n\
1831 Symbols must match exactly.")
1833 register Lisp_Object o1
, o2
;
1835 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1839 internal_equal (o1
, o2
, depth
)
1840 register Lisp_Object o1
, o2
;
1844 error ("Stack overflow in equal");
1850 if (XTYPE (o1
) != XTYPE (o2
))
1856 return (extract_float (o1
) == extract_float (o2
));
1859 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1866 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1870 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1872 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1875 o1
= XOVERLAY (o1
)->plist
;
1876 o2
= XOVERLAY (o2
)->plist
;
1881 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1882 && (XMARKER (o1
)->buffer
== 0
1883 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1887 case Lisp_Vectorlike
:
1889 register int i
, size
;
1890 size
= XVECTOR (o1
)->size
;
1891 /* Pseudovectors have the type encoded in the size field, so this test
1892 actually checks that the objects have the same type as well as the
1894 if (XVECTOR (o2
)->size
!= size
)
1896 /* Boolvectors are compared much like strings. */
1897 if (BOOL_VECTOR_P (o1
))
1900 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1902 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1904 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1909 if (WINDOW_CONFIGURATIONP (o1
))
1910 return compare_window_configurations (o1
, o2
, 0);
1912 /* Aside from them, only true vectors, char-tables, and compiled
1913 functions are sensible to compare, so eliminate the others now. */
1914 if (size
& PSEUDOVECTOR_FLAG
)
1916 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1918 size
&= PSEUDOVECTOR_SIZE_MASK
;
1920 for (i
= 0; i
< size
; i
++)
1923 v1
= XVECTOR (o1
)->contents
[i
];
1924 v2
= XVECTOR (o2
)->contents
[i
];
1925 if (!internal_equal (v1
, v2
, depth
+ 1))
1933 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1935 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1937 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1938 STRING_BYTES (XSTRING (o1
))))
1945 extern Lisp_Object
Fmake_char_internal ();
1947 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1948 "Store each element of ARRAY with ITEM.\n\
1949 ARRAY is a vector, string, char-table, or bool-vector.")
1951 Lisp_Object array
, item
;
1953 register int size
, index
, charval
;
1955 if (VECTORP (array
))
1957 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1958 size
= XVECTOR (array
)->size
;
1959 for (index
= 0; index
< size
; index
++)
1962 else if (CHAR_TABLE_P (array
))
1964 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1965 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1966 for (index
= 0; index
< size
; index
++)
1968 XCHAR_TABLE (array
)->defalt
= Qnil
;
1970 else if (STRINGP (array
))
1972 register unsigned char *p
= XSTRING (array
)->data
;
1973 CHECK_NUMBER (item
, 1);
1974 charval
= XINT (item
);
1975 size
= XSTRING (array
)->size
;
1976 if (STRING_MULTIBYTE (array
))
1978 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1979 int len
= CHAR_STRING (charval
, str
);
1980 int size_byte
= STRING_BYTES (XSTRING (array
));
1981 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1984 if (size
!= size_byte
)
1987 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1988 if (len
!= this_len
)
1989 error ("Attempt to change byte length of a string");
1992 for (i
= 0; i
< size_byte
; i
++)
1993 *p
++ = str
[i
% len
];
1996 for (index
= 0; index
< size
; index
++)
1999 else if (BOOL_VECTOR_P (array
))
2001 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2003 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2005 charval
= (! NILP (item
) ? -1 : 0);
2006 for (index
= 0; index
< size_in_chars
; index
++)
2011 array
= wrong_type_argument (Qarrayp
, array
);
2017 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2019 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2021 Lisp_Object char_table
;
2023 CHECK_CHAR_TABLE (char_table
, 0);
2025 return XCHAR_TABLE (char_table
)->purpose
;
2028 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2030 "Return the parent char-table of CHAR-TABLE.\n\
2031 The value is either nil or another char-table.\n\
2032 If CHAR-TABLE holds nil for a given character,\n\
2033 then the actual applicable value is inherited from the parent char-table\n\
2034 \(or from its parents, if necessary).")
2036 Lisp_Object char_table
;
2038 CHECK_CHAR_TABLE (char_table
, 0);
2040 return XCHAR_TABLE (char_table
)->parent
;
2043 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2045 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2046 PARENT must be either nil or another char-table.")
2047 (char_table
, parent
)
2048 Lisp_Object char_table
, parent
;
2052 CHECK_CHAR_TABLE (char_table
, 0);
2056 CHECK_CHAR_TABLE (parent
, 0);
2058 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2059 if (EQ (temp
, char_table
))
2060 error ("Attempt to make a chartable be its own parent");
2063 XCHAR_TABLE (char_table
)->parent
= parent
;
2068 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2070 "Return the value of CHAR-TABLE's extra-slot number N.")
2072 Lisp_Object char_table
, n
;
2074 CHECK_CHAR_TABLE (char_table
, 1);
2075 CHECK_NUMBER (n
, 2);
2077 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2078 args_out_of_range (char_table
, n
);
2080 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2083 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2084 Sset_char_table_extra_slot
,
2086 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2087 (char_table
, n
, value
)
2088 Lisp_Object char_table
, n
, value
;
2090 CHECK_CHAR_TABLE (char_table
, 1);
2091 CHECK_NUMBER (n
, 2);
2093 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2094 args_out_of_range (char_table
, n
);
2096 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2099 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2101 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2102 RANGE should be nil (for the default value)\n\
2103 a vector which identifies a character set or a row of a character set,\n\
2104 a character set name, or a character code.")
2106 Lisp_Object char_table
, range
;
2108 CHECK_CHAR_TABLE (char_table
, 0);
2110 if (EQ (range
, Qnil
))
2111 return XCHAR_TABLE (char_table
)->defalt
;
2112 else if (INTEGERP (range
))
2113 return Faref (char_table
, range
);
2114 else if (SYMBOLP (range
))
2116 Lisp_Object charset_info
;
2118 charset_info
= Fget (range
, Qcharset
);
2119 CHECK_VECTOR (charset_info
, 0);
2121 return Faref (char_table
,
2122 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2125 else if (VECTORP (range
))
2127 if (XVECTOR (range
)->size
== 1)
2128 return Faref (char_table
,
2129 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2132 int size
= XVECTOR (range
)->size
;
2133 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2134 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2135 size
<= 1 ? Qnil
: val
[1],
2136 size
<= 2 ? Qnil
: val
[2]);
2137 return Faref (char_table
, ch
);
2141 error ("Invalid RANGE argument to `char-table-range'");
2144 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2146 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2147 RANGE should be t (for all characters), nil (for the default value)\n\
2148 a vector which identifies a character set or a row of a character set,\n\
2149 a coding system, or a character code.")
2150 (char_table
, range
, value
)
2151 Lisp_Object char_table
, range
, value
;
2155 CHECK_CHAR_TABLE (char_table
, 0);
2158 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2159 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2160 else if (EQ (range
, Qnil
))
2161 XCHAR_TABLE (char_table
)->defalt
= value
;
2162 else if (SYMBOLP (range
))
2164 Lisp_Object charset_info
;
2166 charset_info
= Fget (range
, Qcharset
);
2167 CHECK_VECTOR (charset_info
, 0);
2169 return Faset (char_table
,
2170 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2174 else if (INTEGERP (range
))
2175 Faset (char_table
, range
, value
);
2176 else if (VECTORP (range
))
2178 if (XVECTOR (range
)->size
== 1)
2179 return Faset (char_table
,
2180 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2184 int size
= XVECTOR (range
)->size
;
2185 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2186 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2187 size
<= 1 ? Qnil
: val
[1],
2188 size
<= 2 ? Qnil
: val
[2]);
2189 return Faset (char_table
, ch
, value
);
2193 error ("Invalid RANGE argument to `set-char-table-range'");
2198 DEFUN ("set-char-table-default", Fset_char_table_default
,
2199 Sset_char_table_default
, 3, 3, 0,
2200 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2201 The generic character specifies the group of characters.\n\
2202 See also the documentation of make-char.")
2203 (char_table
, ch
, value
)
2204 Lisp_Object char_table
, ch
, value
;
2206 int c
, charset
, code1
, code2
;
2209 CHECK_CHAR_TABLE (char_table
, 0);
2210 CHECK_NUMBER (ch
, 1);
2213 SPLIT_CHAR (c
, charset
, code1
, code2
);
2215 /* Since we may want to set the default value for a character set
2216 not yet defined, we check only if the character set is in the
2217 valid range or not, instead of it is already defined or not. */
2218 if (! CHARSET_VALID_P (charset
))
2219 invalid_character (c
);
2221 if (charset
== CHARSET_ASCII
)
2222 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2224 /* Even if C is not a generic char, we had better behave as if a
2225 generic char is specified. */
2226 if (CHARSET_DIMENSION (charset
) == 1)
2228 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2231 if (SUB_CHAR_TABLE_P (temp
))
2232 XCHAR_TABLE (temp
)->defalt
= value
;
2234 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2238 if (! SUB_CHAR_TABLE_P (char_table
))
2239 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2240 = make_sub_char_table (temp
));
2241 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2242 if (SUB_CHAR_TABLE_P (temp
))
2243 XCHAR_TABLE (temp
)->defalt
= value
;
2245 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2249 /* Look up the element in TABLE at index CH,
2250 and return it as an integer.
2251 If the element is nil, return CH itself.
2252 (Actually we do that for any non-integer.) */
2255 char_table_translate (table
, ch
)
2260 value
= Faref (table
, make_number (ch
));
2261 if (! INTEGERP (value
))
2263 return XINT (value
);
2267 optimize_sub_char_table (table
, chars
)
2275 from
= 33, to
= 127;
2277 from
= 32, to
= 128;
2279 if (!SUB_CHAR_TABLE_P (*table
))
2281 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2282 for (; from
< to
; from
++)
2283 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2288 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2290 "Optimize char table TABLE.")
2298 CHECK_CHAR_TABLE (table
, 0);
2300 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2302 elt
= XCHAR_TABLE (table
)->contents
[i
];
2303 if (!SUB_CHAR_TABLE_P (elt
))
2305 dim
= CHARSET_DIMENSION (i
);
2307 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2308 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2309 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2315 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2316 character or group of characters that share a value.
2317 DEPTH is the current depth in the originally specified
2318 chartable, and INDICES contains the vector indices
2319 for the levels our callers have descended.
2321 ARG is passed to C_FUNCTION when that is called. */
2324 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2325 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2326 Lisp_Object function
, subtable
, arg
, *indices
;
2333 /* At first, handle ASCII and 8-bit European characters. */
2334 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2336 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2338 (*c_function
) (arg
, make_number (i
), elt
);
2340 call2 (function
, make_number (i
), elt
);
2342 #if 0 /* If the char table has entries for higher characters,
2343 we should report them. */
2344 if (NILP (current_buffer
->enable_multibyte_characters
))
2347 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2352 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2357 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2359 XSETFASTINT (indices
[depth
], i
);
2361 if (SUB_CHAR_TABLE_P (elt
))
2364 error ("Too deep char table");
2365 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2369 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2371 if (CHARSET_DEFINED_P (charset
))
2373 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2374 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2375 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2377 (*c_function
) (arg
, make_number (c
), elt
);
2379 call2 (function
, make_number (c
), elt
);
2385 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2387 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2388 FUNCTION is called with two arguments--a key and a value.\n\
2389 The key is always a possible IDX argument to `aref'.")
2390 (function
, char_table
)
2391 Lisp_Object function
, char_table
;
2393 /* The depth of char table is at most 3. */
2394 Lisp_Object indices
[3];
2396 CHECK_CHAR_TABLE (char_table
, 1);
2398 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2408 Lisp_Object args
[2];
2411 return Fnconc (2, args
);
2413 return Fnconc (2, &s1
);
2414 #endif /* NO_ARG_ARRAY */
2417 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2418 "Concatenate any number of lists by altering them.\n\
2419 Only the last argument is not altered, and need not be a list.")
2424 register int argnum
;
2425 register Lisp_Object tail
, tem
, val
;
2429 for (argnum
= 0; argnum
< nargs
; argnum
++)
2432 if (NILP (tem
)) continue;
2437 if (argnum
+ 1 == nargs
) break;
2440 tem
= wrong_type_argument (Qlistp
, tem
);
2449 tem
= args
[argnum
+ 1];
2450 Fsetcdr (tail
, tem
);
2452 args
[argnum
+ 1] = tail
;
2458 /* This is the guts of all mapping functions.
2459 Apply FN to each element of SEQ, one by one,
2460 storing the results into elements of VALS, a C vector of Lisp_Objects.
2461 LENI is the length of VALS, which should also be the length of SEQ. */
2464 mapcar1 (leni
, vals
, fn
, seq
)
2467 Lisp_Object fn
, seq
;
2469 register Lisp_Object tail
;
2472 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2474 /* Don't let vals contain any garbage when GC happens. */
2475 for (i
= 0; i
< leni
; i
++)
2478 GCPRO3 (dummy
, fn
, seq
);
2480 gcpro1
.nvars
= leni
;
2481 /* We need not explicitly protect `tail' because it is used only on lists, and
2482 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2486 for (i
= 0; i
< leni
; i
++)
2488 dummy
= XVECTOR (seq
)->contents
[i
];
2489 vals
[i
] = call1 (fn
, dummy
);
2492 else if (BOOL_VECTOR_P (seq
))
2494 for (i
= 0; i
< leni
; i
++)
2497 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2498 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2503 vals
[i
] = call1 (fn
, dummy
);
2506 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2508 /* Single-byte string. */
2509 for (i
= 0; i
< leni
; i
++)
2511 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2512 vals
[i
] = call1 (fn
, dummy
);
2515 else if (STRINGP (seq
))
2517 /* Multi-byte string. */
2520 for (i
= 0, i_byte
= 0; i
< leni
;)
2525 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2526 XSETFASTINT (dummy
, c
);
2527 vals
[i_before
] = call1 (fn
, dummy
);
2530 else /* Must be a list, since Flength did not get an error */
2533 for (i
= 0; i
< leni
; i
++)
2535 vals
[i
] = call1 (fn
, Fcar (tail
));
2543 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2544 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2545 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2546 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2547 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2548 (function
, sequence
, separator
)
2549 Lisp_Object function
, sequence
, separator
;
2554 register Lisp_Object
*args
;
2556 struct gcpro gcpro1
;
2558 len
= Flength (sequence
);
2560 nargs
= leni
+ leni
- 1;
2561 if (nargs
< 0) return build_string ("");
2563 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2566 mapcar1 (leni
, args
, function
, sequence
);
2569 for (i
= leni
- 1; i
>= 0; i
--)
2570 args
[i
+ i
] = args
[i
];
2572 for (i
= 1; i
< nargs
; i
+= 2)
2573 args
[i
] = separator
;
2575 return Fconcat (nargs
, args
);
2578 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2579 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2580 The result is a list just as long as SEQUENCE.\n\
2581 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2582 (function
, sequence
)
2583 Lisp_Object function
, sequence
;
2585 register Lisp_Object len
;
2587 register Lisp_Object
*args
;
2589 len
= Flength (sequence
);
2590 leni
= XFASTINT (len
);
2591 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2593 mapcar1 (leni
, args
, function
, sequence
);
2595 return Flist (leni
, args
);
2598 /* Anything that calls this function must protect from GC! */
2600 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2601 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2602 Takes one argument, which is the string to display to ask the question.\n\
2603 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2604 No confirmation of the answer is requested; a single character is enough.\n\
2605 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2606 the bindings in `query-replace-map'; see the documentation of that variable\n\
2607 for more information. In this case, the useful bindings are `act', `skip',\n\
2608 `recenter', and `quit'.\)\n\
2610 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2615 register Lisp_Object obj
, key
, def
, map
;
2616 register int answer
;
2617 Lisp_Object xprompt
;
2618 Lisp_Object args
[2];
2619 struct gcpro gcpro1
, gcpro2
;
2620 int count
= specpdl_ptr
- specpdl
;
2622 specbind (Qcursor_in_echo_area
, Qt
);
2624 map
= Fsymbol_value (intern ("query-replace-map"));
2626 CHECK_STRING (prompt
, 0);
2628 GCPRO2 (prompt
, xprompt
);
2630 #ifdef HAVE_X_WINDOWS
2631 if (display_busy_cursor_p
)
2632 cancel_busy_cursor ();
2639 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2643 Lisp_Object pane
, menu
;
2644 redisplay_preserve_echo_area ();
2645 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2646 Fcons (Fcons (build_string ("No"), Qnil
),
2648 menu
= Fcons (prompt
, pane
);
2649 obj
= Fx_popup_dialog (Qt
, menu
);
2650 answer
= !NILP (obj
);
2653 #endif /* HAVE_MENUS */
2654 cursor_in_echo_area
= 1;
2655 choose_minibuf_frame ();
2656 message_with_string ("%s(y or n) ", xprompt
, 0);
2658 if (minibuffer_auto_raise
)
2660 Lisp_Object mini_frame
;
2662 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2664 Fraise_frame (mini_frame
);
2667 obj
= read_filtered_event (1, 0, 0, 0);
2668 cursor_in_echo_area
= 0;
2669 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2672 key
= Fmake_vector (make_number (1), obj
);
2673 def
= Flookup_key (map
, key
, Qt
);
2675 if (EQ (def
, intern ("skip")))
2680 else if (EQ (def
, intern ("act")))
2685 else if (EQ (def
, intern ("recenter")))
2691 else if (EQ (def
, intern ("quit")))
2693 /* We want to exit this command for exit-prefix,
2694 and this is the only way to do it. */
2695 else if (EQ (def
, intern ("exit-prefix")))
2700 /* If we don't clear this, then the next call to read_char will
2701 return quit_char again, and we'll enter an infinite loop. */
2706 if (EQ (xprompt
, prompt
))
2708 args
[0] = build_string ("Please answer y or n. ");
2710 xprompt
= Fconcat (2, args
);
2715 if (! noninteractive
)
2717 cursor_in_echo_area
= -1;
2718 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2722 unbind_to (count
, Qnil
);
2723 return answer
? Qt
: Qnil
;
2726 /* This is how C code calls `yes-or-no-p' and allows the user
2729 Anything that calls this function must protect from GC! */
2732 do_yes_or_no_p (prompt
)
2735 return call1 (intern ("yes-or-no-p"), prompt
);
2738 /* Anything that calls this function must protect from GC! */
2740 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2741 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2742 Takes one argument, which is the string to display to ask the question.\n\
2743 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2744 The user must confirm the answer with RET,\n\
2745 and can edit it until it has been confirmed.\n\
2747 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2752 register Lisp_Object ans
;
2753 Lisp_Object args
[2];
2754 struct gcpro gcpro1
;
2756 CHECK_STRING (prompt
, 0);
2759 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2763 Lisp_Object pane
, menu
, obj
;
2764 redisplay_preserve_echo_area ();
2765 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2766 Fcons (Fcons (build_string ("No"), Qnil
),
2769 menu
= Fcons (prompt
, pane
);
2770 obj
= Fx_popup_dialog (Qt
, menu
);
2774 #endif /* HAVE_MENUS */
2777 args
[1] = build_string ("(yes or no) ");
2778 prompt
= Fconcat (2, args
);
2784 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2785 Qyes_or_no_p_history
, Qnil
,
2787 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2792 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2800 message ("Please answer yes or no.");
2801 Fsleep_for (make_number (2), Qnil
);
2805 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2806 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2807 Each of the three load averages is multiplied by 100,\n\
2808 then converted to integer.\n\
2809 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2810 These floats are not multiplied by 100.\n\n\
2811 If the 5-minute or 15-minute load averages are not available, return a\n\
2812 shortened list, containing only those averages which are available.")
2814 Lisp_Object use_floats
;
2817 int loads
= getloadavg (load_ave
, 3);
2818 Lisp_Object ret
= Qnil
;
2821 error ("load-average not implemented for this operating system");
2825 Lisp_Object load
= (NILP (use_floats
) ?
2826 make_number ((int) (100.0 * load_ave
[loads
]))
2827 : make_float (load_ave
[loads
]));
2828 ret
= Fcons (load
, ret
);
2834 Lisp_Object Vfeatures
;
2836 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2837 "Returns t if FEATURE is present in this Emacs.\n\
2838 Use this to conditionalize execution of lisp code based on the presence or\n\
2839 absence of emacs or environment extensions.\n\
2840 Use `provide' to declare that a feature is available.\n\
2841 This function looks at the value of the variable `features'.")
2843 Lisp_Object feature
;
2845 register Lisp_Object tem
;
2846 CHECK_SYMBOL (feature
, 0);
2847 tem
= Fmemq (feature
, Vfeatures
);
2848 return (NILP (tem
)) ? Qnil
: Qt
;
2851 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2852 "Announce that FEATURE is a feature of the current Emacs.")
2854 Lisp_Object feature
;
2856 register Lisp_Object tem
;
2857 CHECK_SYMBOL (feature
, 0);
2858 if (!NILP (Vautoload_queue
))
2859 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2860 tem
= Fmemq (feature
, Vfeatures
);
2862 Vfeatures
= Fcons (feature
, Vfeatures
);
2863 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2867 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2868 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2869 If FEATURE is not a member of the list `features', then the feature\n\
2870 is not loaded; so load the file FILENAME.\n\
2871 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2872 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2873 If the optional third argument NOERROR is non-nil,\n\
2874 then return nil if the file is not found.\n\
2875 Normally the return value is FEATURE.")
2876 (feature
, file_name
, noerror
)
2877 Lisp_Object feature
, file_name
, noerror
;
2879 register Lisp_Object tem
;
2880 CHECK_SYMBOL (feature
, 0);
2881 tem
= Fmemq (feature
, Vfeatures
);
2882 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2885 int count
= specpdl_ptr
- specpdl
;
2887 /* Value saved here is to be restored into Vautoload_queue */
2888 record_unwind_protect (un_autoload
, Vautoload_queue
);
2889 Vautoload_queue
= Qt
;
2891 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2892 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2893 /* If load failed entirely, return nil. */
2895 return unbind_to (count
, Qnil
);
2897 tem
= Fmemq (feature
, Vfeatures
);
2899 error ("Required feature %s was not provided",
2900 XSYMBOL (feature
)->name
->data
);
2902 /* Once loading finishes, don't undo it. */
2903 Vautoload_queue
= Qt
;
2904 feature
= unbind_to (count
, feature
);
2909 /* Primitives for work of the "widget" library.
2910 In an ideal world, this section would not have been necessary.
2911 However, lisp function calls being as slow as they are, it turns
2912 out that some functions in the widget library (wid-edit.el) are the
2913 bottleneck of Widget operation. Here is their translation to C,
2914 for the sole reason of efficiency. */
2916 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2917 "Return non-nil if PLIST has the property PROP.\n\
2918 PLIST is a property list, which is a list of the form\n\
2919 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2920 Unlike `plist-get', this allows you to distinguish between a missing\n\
2921 property and a property with the value nil.\n\
2922 The value is actually the tail of PLIST whose car is PROP.")
2924 Lisp_Object plist
, prop
;
2926 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2929 plist
= XCDR (plist
);
2930 plist
= CDR (plist
);
2935 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2936 "In WIDGET, set PROPERTY to VALUE.\n\
2937 The value can later be retrieved with `widget-get'.")
2938 (widget
, property
, value
)
2939 Lisp_Object widget
, property
, value
;
2941 CHECK_CONS (widget
, 1);
2942 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2946 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2947 "In WIDGET, get the value of PROPERTY.\n\
2948 The value could either be specified when the widget was created, or\n\
2949 later with `widget-put'.")
2951 Lisp_Object widget
, property
;
2959 CHECK_CONS (widget
, 1);
2960 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2966 tmp
= XCAR (widget
);
2969 widget
= Fget (tmp
, Qwidget_type
);
2973 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2974 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2975 ARGS are passed as extra arguments to the function.")
2980 /* This function can GC. */
2981 Lisp_Object newargs
[3];
2982 struct gcpro gcpro1
, gcpro2
;
2985 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2986 newargs
[1] = args
[0];
2987 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2988 GCPRO2 (newargs
[0], newargs
[2]);
2989 result
= Fapply (3, newargs
);
2994 /* base64 encode/decode functions.
2995 Based on code from GNU recode. */
2997 #define MIME_LINE_LENGTH 76
2999 #define IS_ASCII(Character) \
3001 #define IS_BASE64(Character) \
3002 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3003 #define IS_BASE64_IGNORABLE(Character) \
3004 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3005 || (Character) == '\f' || (Character) == '\r')
3007 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3008 character or return retval if there are no characters left to
3010 #define READ_QUADRUPLET_BYTE(retval) \
3017 while (IS_BASE64_IGNORABLE (c))
3019 /* Don't use alloca for regions larger than this, lest we overflow
3021 #define MAX_ALLOCA 16*1024
3023 /* Table of characters coding the 64 values. */
3024 static char base64_value_to_char
[64] =
3026 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3027 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3028 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3029 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3030 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3031 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3032 '8', '9', '+', '/' /* 60-63 */
3035 /* Table of base64 values for first 128 characters. */
3036 static short base64_char_to_value
[128] =
3038 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3039 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3040 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3041 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3042 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3043 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3044 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3045 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3046 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3047 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3048 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3049 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3050 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3053 /* The following diagram shows the logical steps by which three octets
3054 get transformed into four base64 characters.
3056 .--------. .--------. .--------.
3057 |aaaaaabb| |bbbbcccc| |ccdddddd|
3058 `--------' `--------' `--------'
3060 .--------+--------+--------+--------.
3061 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3062 `--------+--------+--------+--------'
3064 .--------+--------+--------+--------.
3065 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3066 `--------+--------+--------+--------'
3068 The octets are divided into 6 bit chunks, which are then encoded into
3069 base64 characters. */
3072 static int base64_encode_1
P_ ((const char *, char *, int, int));
3073 static int base64_decode_1
P_ ((const char *, char *, int));
3075 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3077 "Base64-encode the region between BEG and END.\n\
3078 Return the length of the encoded text.\n\
3079 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3080 into shorter lines.")
3081 (beg
, end
, no_line_break
)
3082 Lisp_Object beg
, end
, no_line_break
;
3085 int allength
, length
;
3086 int ibeg
, iend
, encoded_length
;
3089 validate_region (&beg
, &end
);
3091 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3092 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3093 move_gap_both (XFASTINT (beg
), ibeg
);
3095 /* We need to allocate enough room for encoding the text.
3096 We need 33 1/3% more space, plus a newline every 76
3097 characters, and then we round up. */
3098 length
= iend
- ibeg
;
3099 allength
= length
+ length
/3 + 1;
3100 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3102 if (allength
<= MAX_ALLOCA
)
3103 encoded
= (char *) alloca (allength
);
3105 encoded
= (char *) xmalloc (allength
);
3106 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3107 NILP (no_line_break
));
3108 if (encoded_length
> allength
)
3111 /* Now we have encoded the region, so we insert the new contents
3112 and delete the old. (Insert first in order to preserve markers.) */
3113 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3114 insert (encoded
, encoded_length
);
3115 if (allength
> MAX_ALLOCA
)
3117 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3119 /* If point was outside of the region, restore it exactly; else just
3120 move to the beginning of the region. */
3121 if (old_pos
>= XFASTINT (end
))
3122 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3123 else if (old_pos
> XFASTINT (beg
))
3124 old_pos
= XFASTINT (beg
);
3127 /* We return the length of the encoded text. */
3128 return make_number (encoded_length
);
3131 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3133 "Base64-encode STRING and return the result.\n\
3134 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3135 into shorter lines.")
3136 (string
, no_line_break
)
3137 Lisp_Object string
, no_line_break
;
3139 int allength
, length
, encoded_length
;
3141 Lisp_Object encoded_string
;
3143 CHECK_STRING (string
, 1);
3145 /* We need to allocate enough room for encoding the text.
3146 We need 33 1/3% more space, plus a newline every 76
3147 characters, and then we round up. */
3148 length
= STRING_BYTES (XSTRING (string
));
3149 allength
= length
+ length
/3 + 1;
3150 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3152 /* We need to allocate enough room for decoding the text. */
3153 if (allength
<= MAX_ALLOCA
)
3154 encoded
= (char *) alloca (allength
);
3156 encoded
= (char *) xmalloc (allength
);
3158 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3159 encoded
, length
, NILP (no_line_break
));
3160 if (encoded_length
> allength
)
3163 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3164 if (allength
> MAX_ALLOCA
)
3167 return encoded_string
;
3171 base64_encode_1 (from
, to
, length
, line_break
)
3177 int counter
= 0, i
= 0;
3186 /* Wrap line every 76 characters. */
3190 if (counter
< MIME_LINE_LENGTH
/ 4)
3199 /* Process first byte of a triplet. */
3201 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3202 value
= (0x03 & c
) << 4;
3204 /* Process second byte of a triplet. */
3208 *e
++ = base64_value_to_char
[value
];
3216 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3217 value
= (0x0f & c
) << 2;
3219 /* Process third byte of a triplet. */
3223 *e
++ = base64_value_to_char
[value
];
3230 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3231 *e
++ = base64_value_to_char
[0x3f & c
];
3238 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3240 "Base64-decode the region between BEG and END.\n\
3241 Return the length of the decoded text.\n\
3242 If the region can't be decoded, return nil and don't modify the buffer.")
3244 Lisp_Object beg
, end
;
3246 int ibeg
, iend
, length
;
3252 validate_region (&beg
, &end
);
3254 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3255 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3257 length
= iend
- ibeg
;
3258 /* We need to allocate enough room for decoding the text. */
3259 if (length
<= MAX_ALLOCA
)
3260 decoded
= (char *) alloca (length
);
3262 decoded
= (char *) xmalloc (length
);
3264 move_gap_both (XFASTINT (beg
), ibeg
);
3265 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3266 if (decoded_length
> length
)
3269 if (decoded_length
< 0)
3271 /* The decoding wasn't possible. */
3272 if (length
> MAX_ALLOCA
)
3277 /* Now we have decoded the region, so we insert the new contents
3278 and delete the old. (Insert first in order to preserve markers.) */
3279 /* We insert two spaces, then insert the decoded text in between
3280 them, at last, delete those extra two spaces. This is to avoid
3281 byte combining while inserting. */
3282 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3283 insert_1_both (" ", 2, 2, 0, 1, 0);
3284 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3285 insert (decoded
, decoded_length
);
3286 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3287 if (length
> MAX_ALLOCA
)
3289 /* At first delete the original text. This never cause byte
3291 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3292 iend
+ decoded_length
+ 2, 1);
3293 /* Next delete the extra spaces. This will cause byte combining
3295 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3296 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3297 inserted_chars
= PT
- XFASTINT (beg
);
3299 /* If point was outside of the region, restore it exactly; else just
3300 move to the beginning of the region. */
3301 if (old_pos
>= XFASTINT (end
))
3302 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3303 else if (old_pos
> XFASTINT (beg
))
3304 old_pos
= XFASTINT (beg
);
3305 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3307 return make_number (inserted_chars
);
3310 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3312 "Base64-decode STRING and return the result.")
3317 int length
, decoded_length
;
3318 Lisp_Object decoded_string
;
3320 CHECK_STRING (string
, 1);
3322 length
= STRING_BYTES (XSTRING (string
));
3323 /* We need to allocate enough room for decoding the text. */
3324 if (length
<= MAX_ALLOCA
)
3325 decoded
= (char *) alloca (length
);
3327 decoded
= (char *) xmalloc (length
);
3329 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3330 if (decoded_length
> length
)
3333 if (decoded_length
< 0)
3334 /* The decoding wasn't possible. */
3335 decoded_string
= Qnil
;
3337 decoded_string
= make_string (decoded
, decoded_length
);
3339 if (length
> MAX_ALLOCA
)
3342 return decoded_string
;
3346 base64_decode_1 (from
, to
, length
)
3354 unsigned long value
;
3358 /* Process first byte of a quadruplet. */
3360 READ_QUADRUPLET_BYTE (e
-to
);
3364 value
= base64_char_to_value
[c
] << 18;
3366 /* Process second byte of a quadruplet. */
3368 READ_QUADRUPLET_BYTE (-1);
3372 value
|= base64_char_to_value
[c
] << 12;
3374 *e
++ = (unsigned char) (value
>> 16);
3376 /* Process third byte of a quadruplet. */
3378 READ_QUADRUPLET_BYTE (-1);
3382 READ_QUADRUPLET_BYTE (-1);
3391 value
|= base64_char_to_value
[c
] << 6;
3393 *e
++ = (unsigned char) (0xff & value
>> 8);
3395 /* Process fourth byte of a quadruplet. */
3397 READ_QUADRUPLET_BYTE (-1);
3404 value
|= base64_char_to_value
[c
];
3406 *e
++ = (unsigned char) (0xff & value
);
3412 /***********************************************************************
3414 ***** Hash Tables *****
3416 ***********************************************************************/
3418 /* Implemented by gerd@gnu.org. This hash table implementation was
3419 inspired by CMUCL hash tables. */
3423 1. For small tables, association lists are probably faster than
3424 hash tables because they have lower overhead.
3426 For uses of hash tables where the O(1) behavior of table
3427 operations is not a requirement, it might therefore be a good idea
3428 not to hash. Instead, we could just do a linear search in the
3429 key_and_value vector of the hash table. This could be done
3430 if a `:linear-search t' argument is given to make-hash-table. */
3433 /* Return the contents of vector V at index IDX. */
3435 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3437 /* Value is the key part of entry IDX in hash table H. */
3439 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3441 /* Value is the value part of entry IDX in hash table H. */
3443 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3445 /* Value is the index of the next entry following the one at IDX
3448 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3450 /* Value is the hash code computed for entry IDX in hash table H. */
3452 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3454 /* Value is the index of the element in hash table H that is the
3455 start of the collision list at index IDX in the index vector of H. */
3457 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3459 /* Value is the size of hash table H. */
3461 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3463 /* The list of all weak hash tables. Don't staticpro this one. */
3465 Lisp_Object Vweak_hash_tables
;
3467 /* Various symbols. */
3469 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3470 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3471 Lisp_Object Qhash_table_test
;
3473 /* Function prototypes. */
3475 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3476 static int next_almost_prime
P_ ((int));
3477 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3478 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3479 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3480 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3481 Lisp_Object
, unsigned));
3482 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3483 Lisp_Object
, unsigned));
3484 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3485 unsigned, Lisp_Object
, unsigned));
3486 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3487 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3488 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3489 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3491 static unsigned sxhash_string
P_ ((unsigned char *, int));
3492 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3493 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3494 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3495 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3499 /***********************************************************************
3501 ***********************************************************************/
3503 /* If OBJ is a Lisp hash table, return a pointer to its struct
3504 Lisp_Hash_Table. Otherwise, signal an error. */
3506 static struct Lisp_Hash_Table
*
3507 check_hash_table (obj
)
3510 CHECK_HASH_TABLE (obj
, 0);
3511 return XHASH_TABLE (obj
);
3515 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3519 next_almost_prime (n
)
3532 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3533 which USED[I] is non-zero. If found at index I in ARGS, set
3534 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3535 -1. This function is used to extract a keyword/argument pair from
3536 a DEFUN parameter list. */
3539 get_key_arg (key
, nargs
, args
, used
)
3547 for (i
= 0; i
< nargs
- 1; ++i
)
3548 if (!used
[i
] && EQ (args
[i
], key
))
3563 /* Return a Lisp vector which has the same contents as VEC but has
3564 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3565 vector that are not copied from VEC are set to INIT. */
3568 larger_vector (vec
, new_size
, init
)
3573 struct Lisp_Vector
*v
;
3576 xassert (VECTORP (vec
));
3577 old_size
= XVECTOR (vec
)->size
;
3578 xassert (new_size
>= old_size
);
3580 v
= allocate_vectorlike (new_size
);
3582 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3583 old_size
* sizeof *v
->contents
);
3584 for (i
= old_size
; i
< new_size
; ++i
)
3585 v
->contents
[i
] = init
;
3586 XSETVECTOR (vec
, v
);
3591 /***********************************************************************
3593 ***********************************************************************/
3595 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3596 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3597 KEY2 are the same. */
3600 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3601 struct Lisp_Hash_Table
*h
;
3602 Lisp_Object key1
, key2
;
3603 unsigned hash1
, hash2
;
3605 return (FLOATP (key1
)
3607 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3611 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3612 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3613 KEY2 are the same. */
3616 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3617 struct Lisp_Hash_Table
*h
;
3618 Lisp_Object key1
, key2
;
3619 unsigned hash1
, hash2
;
3621 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3625 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3626 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3627 if KEY1 and KEY2 are the same. */
3630 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3631 struct Lisp_Hash_Table
*h
;
3632 Lisp_Object key1
, key2
;
3633 unsigned hash1
, hash2
;
3637 Lisp_Object args
[3];
3639 args
[0] = h
->user_cmp_function
;
3642 return !NILP (Ffuncall (3, args
));
3649 /* Value is a hash code for KEY for use in hash table H which uses
3650 `eq' to compare keys. The hash code returned is guaranteed to fit
3651 in a Lisp integer. */
3655 struct Lisp_Hash_Table
*h
;
3658 /* Lisp strings can change their address. Don't try to compute a
3659 hash code for a string from its address. */
3661 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3663 return XUINT (key
) ^ XGCTYPE (key
);
3667 /* Value is a hash code for KEY for use in hash table H which uses
3668 `eql' to compare keys. The hash code returned is guaranteed to fit
3669 in a Lisp integer. */
3673 struct Lisp_Hash_Table
*h
;
3676 /* Lisp strings can change their address. Don't try to compute a
3677 hash code for a string from its address. */
3679 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3680 else if (FLOATP (key
))
3681 return sxhash (key
, 0);
3683 return XUINT (key
) ^ XGCTYPE (key
);
3687 /* Value is a hash code for KEY for use in hash table H which uses
3688 `equal' to compare keys. The hash code returned is guaranteed to fit
3689 in a Lisp integer. */
3692 hashfn_equal (h
, key
)
3693 struct Lisp_Hash_Table
*h
;
3696 return sxhash (key
, 0);
3700 /* Value is a hash code for KEY for use in hash table H which uses as
3701 user-defined function to compare keys. The hash code returned is
3702 guaranteed to fit in a Lisp integer. */
3705 hashfn_user_defined (h
, key
)
3706 struct Lisp_Hash_Table
*h
;
3709 Lisp_Object args
[2], hash
;
3711 args
[0] = h
->user_hash_function
;
3713 hash
= Ffuncall (2, args
);
3714 if (!INTEGERP (hash
))
3716 list2 (build_string ("Illegal hash code returned from \
3717 user-supplied hash function"),
3719 return XUINT (hash
);
3723 /* Create and initialize a new hash table.
3725 TEST specifies the test the hash table will use to compare keys.
3726 It must be either one of the predefined tests `eq', `eql' or
3727 `equal' or a symbol denoting a user-defined test named TEST with
3728 test and hash functions USER_TEST and USER_HASH.
3730 Give the table initial capacity SIZE, SIZE > 0, an integer.
3732 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3733 new size when it becomes full is computed by adding REHASH_SIZE to
3734 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3735 table's new size is computed by multiplying its old size with
3738 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3739 be resized when the ratio of (number of entries in the table) /
3740 (table size) is >= REHASH_THRESHOLD.
3742 WEAK specifies the weakness of the table. If non-nil, it must be
3743 one of the symbols `key', `value' or t. */
3746 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3747 user_test
, user_hash
)
3748 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3749 Lisp_Object user_test
, user_hash
;
3751 struct Lisp_Hash_Table
*h
;
3752 struct Lisp_Vector
*v
;
3754 int index_size
, i
, len
, sz
;
3756 /* Preconditions. */
3757 xassert (SYMBOLP (test
));
3758 xassert (INTEGERP (size
) && XINT (size
) > 0);
3759 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3760 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3761 xassert (FLOATP (rehash_threshold
)
3762 && XFLOATINT (rehash_threshold
) > 0
3763 && XFLOATINT (rehash_threshold
) <= 1.0);
3765 /* Allocate a vector, and initialize it. */
3766 len
= VECSIZE (struct Lisp_Hash_Table
);
3767 v
= allocate_vectorlike (len
);
3769 for (i
= 0; i
< len
; ++i
)
3770 v
->contents
[i
] = Qnil
;
3772 /* Initialize hash table slots. */
3773 sz
= XFASTINT (size
);
3774 h
= (struct Lisp_Hash_Table
*) v
;
3777 if (EQ (test
, Qeql
))
3779 h
->cmpfn
= cmpfn_eql
;
3780 h
->hashfn
= hashfn_eql
;
3782 else if (EQ (test
, Qeq
))
3785 h
->hashfn
= hashfn_eq
;
3787 else if (EQ (test
, Qequal
))
3789 h
->cmpfn
= cmpfn_equal
;
3790 h
->hashfn
= hashfn_equal
;
3794 h
->user_cmp_function
= user_test
;
3795 h
->user_hash_function
= user_hash
;
3796 h
->cmpfn
= cmpfn_user_defined
;
3797 h
->hashfn
= hashfn_user_defined
;
3801 h
->rehash_threshold
= rehash_threshold
;
3802 h
->rehash_size
= rehash_size
;
3803 h
->count
= make_number (0);
3804 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3805 h
->hash
= Fmake_vector (size
, Qnil
);
3806 h
->next
= Fmake_vector (size
, Qnil
);
3807 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3808 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3810 /* Set up the free list. */
3811 for (i
= 0; i
< sz
- 1; ++i
)
3812 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3813 h
->next_free
= make_number (0);
3815 XSET_HASH_TABLE (table
, h
);
3816 xassert (HASH_TABLE_P (table
));
3817 xassert (XHASH_TABLE (table
) == h
);
3819 /* Maybe add this hash table to the list of all weak hash tables. */
3821 h
->next_weak
= Qnil
;
3824 h
->next_weak
= Vweak_hash_tables
;
3825 Vweak_hash_tables
= table
;
3832 /* Return a copy of hash table H1. Keys and values are not copied,
3833 only the table itself is. */
3836 copy_hash_table (h1
)
3837 struct Lisp_Hash_Table
*h1
;
3840 struct Lisp_Hash_Table
*h2
;
3841 struct Lisp_Vector
*v
, *next
;
3844 len
= VECSIZE (struct Lisp_Hash_Table
);
3845 v
= allocate_vectorlike (len
);
3846 h2
= (struct Lisp_Hash_Table
*) v
;
3847 next
= h2
->vec_next
;
3848 bcopy (h1
, h2
, sizeof *h2
);
3849 h2
->vec_next
= next
;
3850 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3851 h2
->hash
= Fcopy_sequence (h1
->hash
);
3852 h2
->next
= Fcopy_sequence (h1
->next
);
3853 h2
->index
= Fcopy_sequence (h1
->index
);
3854 XSET_HASH_TABLE (table
, h2
);
3856 /* Maybe add this hash table to the list of all weak hash tables. */
3857 if (!NILP (h2
->weak
))
3859 h2
->next_weak
= Vweak_hash_tables
;
3860 Vweak_hash_tables
= table
;
3867 /* Resize hash table H if it's too full. If H cannot be resized
3868 because it's already too large, throw an error. */
3871 maybe_resize_hash_table (h
)
3872 struct Lisp_Hash_Table
*h
;
3874 if (NILP (h
->next_free
))
3876 int old_size
= HASH_TABLE_SIZE (h
);
3877 int i
, new_size
, index_size
;
3879 if (INTEGERP (h
->rehash_size
))
3880 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3882 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3883 new_size
= max (old_size
+ 1, new_size
);
3884 index_size
= next_almost_prime (new_size
3885 / XFLOATINT (h
->rehash_threshold
));
3886 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3887 error ("Hash table too large to resize");
3889 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3890 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3891 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3892 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3894 /* Update the free list. Do it so that new entries are added at
3895 the end of the free list. This makes some operations like
3897 for (i
= old_size
; i
< new_size
- 1; ++i
)
3898 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3900 if (!NILP (h
->next_free
))
3902 Lisp_Object last
, next
;
3904 last
= h
->next_free
;
3905 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3909 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3912 XSETFASTINT (h
->next_free
, old_size
);
3915 for (i
= 0; i
< old_size
; ++i
)
3916 if (!NILP (HASH_HASH (h
, i
)))
3918 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3919 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3920 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3921 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3927 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3928 the hash code of KEY. Value is the index of the entry in H
3929 matching KEY, or -1 if not found. */
3932 hash_lookup (h
, key
, hash
)
3933 struct Lisp_Hash_Table
*h
;
3938 int start_of_bucket
;
3941 hash_code
= h
->hashfn (h
, key
);
3945 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3946 idx
= HASH_INDEX (h
, start_of_bucket
);
3950 int i
= XFASTINT (idx
);
3951 if (EQ (key
, HASH_KEY (h
, i
))
3953 && h
->cmpfn (h
, key
, hash_code
,
3954 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3956 idx
= HASH_NEXT (h
, i
);
3959 return NILP (idx
) ? -1 : XFASTINT (idx
);
3963 /* Put an entry into hash table H that associates KEY with VALUE.
3964 HASH is a previously computed hash code of KEY.
3965 Value is the index of the entry in H matching KEY. */
3968 hash_put (h
, key
, value
, hash
)
3969 struct Lisp_Hash_Table
*h
;
3970 Lisp_Object key
, value
;
3973 int start_of_bucket
, i
;
3975 xassert ((hash
& ~VALMASK
) == 0);
3977 /* Increment count after resizing because resizing may fail. */
3978 maybe_resize_hash_table (h
);
3979 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3981 /* Store key/value in the key_and_value vector. */
3982 i
= XFASTINT (h
->next_free
);
3983 h
->next_free
= HASH_NEXT (h
, i
);
3984 HASH_KEY (h
, i
) = key
;
3985 HASH_VALUE (h
, i
) = value
;
3987 /* Remember its hash code. */
3988 HASH_HASH (h
, i
) = make_number (hash
);
3990 /* Add new entry to its collision chain. */
3991 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3992 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3993 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3998 /* Remove the entry matching KEY from hash table H, if there is one. */
4001 hash_remove (h
, key
)
4002 struct Lisp_Hash_Table
*h
;
4006 int start_of_bucket
;
4007 Lisp_Object idx
, prev
;
4009 hash_code
= h
->hashfn (h
, key
);
4010 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4011 idx
= HASH_INDEX (h
, start_of_bucket
);
4016 int i
= XFASTINT (idx
);
4018 if (EQ (key
, HASH_KEY (h
, i
))
4020 && h
->cmpfn (h
, key
, hash_code
,
4021 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
4023 /* Take entry out of collision chain. */
4025 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4027 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4029 /* Clear slots in key_and_value and add the slots to
4031 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4032 HASH_NEXT (h
, i
) = h
->next_free
;
4033 h
->next_free
= make_number (i
);
4034 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4035 xassert (XINT (h
->count
) >= 0);
4041 idx
= HASH_NEXT (h
, i
);
4047 /* Clear hash table H. */
4051 struct Lisp_Hash_Table
*h
;
4053 if (XFASTINT (h
->count
) > 0)
4055 int i
, size
= HASH_TABLE_SIZE (h
);
4057 for (i
= 0; i
< size
; ++i
)
4059 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4060 HASH_KEY (h
, i
) = Qnil
;
4061 HASH_VALUE (h
, i
) = Qnil
;
4062 HASH_HASH (h
, i
) = Qnil
;
4065 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4066 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4068 h
->next_free
= make_number (0);
4069 h
->count
= make_number (0);
4075 /************************************************************************
4077 ************************************************************************/
4079 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4080 entries from the table that don't survive the current GC.
4081 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4082 non-zero if anything was marked. */
4085 sweep_weak_table (h
, remove_entries_p
)
4086 struct Lisp_Hash_Table
*h
;
4087 int remove_entries_p
;
4089 int bucket
, n
, marked
;
4091 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4094 for (bucket
= 0; bucket
< n
; ++bucket
)
4096 Lisp_Object idx
, prev
;
4098 /* Follow collision chain, removing entries that
4099 don't survive this garbage collection. */
4100 idx
= HASH_INDEX (h
, bucket
);
4102 while (!GC_NILP (idx
))
4105 int i
= XFASTINT (idx
);
4108 if (EQ (h
->weak
, Qkey
))
4109 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
4110 else if (EQ (h
->weak
, Qvalue
))
4111 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
4112 else if (EQ (h
->weak
, Qt
))
4113 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
4114 || !survives_gc_p (HASH_VALUE (h
, i
)));
4118 next
= HASH_NEXT (h
, i
);
4120 if (remove_entries_p
)
4124 /* Take out of collision chain. */
4126 HASH_INDEX (h
, i
) = next
;
4128 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4130 /* Add to free list. */
4131 HASH_NEXT (h
, i
) = h
->next_free
;
4134 /* Clear key, value, and hash. */
4135 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4136 HASH_HASH (h
, i
) = Qnil
;
4138 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4145 /* Make sure key and value survive. */
4146 mark_object (&HASH_KEY (h
, i
));
4147 mark_object (&HASH_VALUE (h
, i
));
4159 /* Remove elements from weak hash tables that don't survive the
4160 current garbage collection. Remove weak tables that don't survive
4161 from Vweak_hash_tables. Called from gc_sweep. */
4164 sweep_weak_hash_tables ()
4167 struct Lisp_Hash_Table
*h
, *prev
;
4170 /* Mark all keys and values that are in use. Keep on marking until
4171 there is no more change. This is necessary for cases like
4172 value-weak table A containing an entry X -> Y, where Y is used in a
4173 key-weak table B, Z -> Y. If B comes after A in the list of weak
4174 tables, X -> Y might be removed from A, although when looking at B
4175 one finds that it shouldn't. */
4179 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4181 h
= XHASH_TABLE (table
);
4182 if (h
->size
& ARRAY_MARK_FLAG
)
4183 marked
|= sweep_weak_table (h
, 0);
4188 /* Remove tables and entries that aren't used. */
4190 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4193 h
= XHASH_TABLE (table
);
4195 if (h
->size
& ARRAY_MARK_FLAG
)
4197 if (XFASTINT (h
->count
) > 0)
4198 sweep_weak_table (h
, 1);
4202 /* Table is not marked, and will thus be freed.
4203 Take it out of the list of weak hash tables. */
4205 prev
->next_weak
= h
->next_weak
;
4207 Vweak_hash_tables
= h
->next_weak
;
4214 /***********************************************************************
4215 Hash Code Computation
4216 ***********************************************************************/
4218 /* Maximum depth up to which to dive into Lisp structures. */
4220 #define SXHASH_MAX_DEPTH 3
4222 /* Maximum length up to which to take list and vector elements into
4225 #define SXHASH_MAX_LEN 7
4227 /* Combine two integers X and Y for hashing. */
4229 #define SXHASH_COMBINE(X, Y) \
4230 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4234 /* Return a hash for string PTR which has length LEN. */
4237 sxhash_string (ptr
, len
)
4241 unsigned char *p
= ptr
;
4242 unsigned char *end
= p
+ len
;
4251 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4254 return hash
& 07777777777;
4258 /* Return a hash for list LIST. DEPTH is the current depth in the
4259 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4262 sxhash_list (list
, depth
)
4269 if (depth
< SXHASH_MAX_DEPTH
)
4271 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4272 list
= XCDR (list
), ++i
)
4274 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4275 hash
= SXHASH_COMBINE (hash
, hash2
);
4282 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4283 the Lisp structure. */
4286 sxhash_vector (vec
, depth
)
4290 unsigned hash
= XVECTOR (vec
)->size
;
4293 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4294 for (i
= 0; i
< n
; ++i
)
4296 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4297 hash
= SXHASH_COMBINE (hash
, hash2
);
4304 /* Return a hash for bool-vector VECTOR. */
4307 sxhash_bool_vector (vec
)
4310 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4313 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4314 for (i
= 0; i
< n
; ++i
)
4315 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4321 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4322 structure. Value is an unsigned integer clipped to VALMASK. */
4331 if (depth
> SXHASH_MAX_DEPTH
)
4334 switch (XTYPE (obj
))
4341 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4342 XSYMBOL (obj
)->name
->size
);
4350 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4353 /* This can be everything from a vector to an overlay. */
4354 case Lisp_Vectorlike
:
4356 /* According to the CL HyperSpec, two arrays are equal only if
4357 they are `eq', except for strings and bit-vectors. In
4358 Emacs, this works differently. We have to compare element
4360 hash
= sxhash_vector (obj
, depth
);
4361 else if (BOOL_VECTOR_P (obj
))
4362 hash
= sxhash_bool_vector (obj
);
4364 /* Others are `equal' if they are `eq', so let's take their
4370 hash
= sxhash_list (obj
, depth
);
4375 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4376 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4377 for (hash
= 0; p
< e
; ++p
)
4378 hash
= SXHASH_COMBINE (hash
, *p
);
4386 return hash
& VALMASK
;
4391 /***********************************************************************
4393 ***********************************************************************/
4396 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4397 "Compute a hash code for OBJ and return it as integer.")
4401 unsigned hash
= sxhash (obj
, 0);;
4402 return make_number (hash
);
4406 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4407 "Create and return a new hash table.\n\
4408 Arguments are specified as keyword/argument pairs. The following\n\
4409 arguments are defined:\n\
4411 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4412 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4413 User-supplied test and hash functions can be specified via\n\
4414 `define-hash-table-test'.\n\
4416 :SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
4419 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4420 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4421 If it is a float, it must be > 1.0, and the new size is computed by\n\
4422 multiplying the old size with that factor. Default is 1.5.\n\
4424 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4425 Resize the hash table when ratio of the number of entries in the table.\n\
4428 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4429 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4430 pairs are removed from a weak hash table when their key, value or both\n\
4431 (WEAK t) are otherwise unreferenced. Default is nil.")
4436 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4437 Lisp_Object user_test
, user_hash
;
4441 /* The vector `used' is used to keep track of arguments that
4442 have been consumed. */
4443 used
= (char *) alloca (nargs
* sizeof *used
);
4444 bzero (used
, nargs
* sizeof *used
);
4446 /* See if there's a `:test TEST' among the arguments. */
4447 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4448 test
= i
< 0 ? Qeql
: args
[i
];
4449 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4451 /* See if it is a user-defined test. */
4454 prop
= Fget (test
, Qhash_table_test
);
4455 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4456 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4458 user_test
= Fnth (make_number (0), prop
);
4459 user_hash
= Fnth (make_number (1), prop
);
4462 user_test
= user_hash
= Qnil
;
4464 /* See if there's a `:size SIZE' argument. */
4465 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4466 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4467 if (!INTEGERP (size
) || XINT (size
) <= 0)
4469 list2 (build_string ("Illegal hash table size"),
4472 /* Look for `:rehash-size SIZE'. */
4473 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4474 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4475 if (!NUMBERP (rehash_size
)
4476 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4477 || XFLOATINT (rehash_size
) <= 1.0)
4479 list2 (build_string ("Illegal hash table rehash size"),
4482 /* Look for `:rehash-threshold THRESHOLD'. */
4483 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4484 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4485 if (!FLOATP (rehash_threshold
)
4486 || XFLOATINT (rehash_threshold
) <= 0.0
4487 || XFLOATINT (rehash_threshold
) > 1.0)
4489 list2 (build_string ("Illegal hash table rehash threshold"),
4492 /* Look for `:weakness WEAK'. */
4493 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4494 weak
= i
< 0 ? Qnil
: args
[i
];
4498 && !EQ (weak
, Qvalue
))
4499 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4502 /* Now, all args should have been used up, or there's a problem. */
4503 for (i
= 0; i
< nargs
; ++i
)
4506 list2 (build_string ("Invalid argument list"), args
[i
]));
4508 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4509 user_test
, user_hash
);
4513 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4514 "Return a copy of hash table TABLE.")
4518 return copy_hash_table (check_hash_table (table
));
4522 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4523 "Create a new hash table.\n\
4524 Optional first argument TEST specifies how to compare keys in\n\
4525 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4526 is `eql'. New tests can be defined with `define-hash-table-test'.")
4530 Lisp_Object args
[2];
4533 return Fmake_hash_table (2, args
);
4537 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4538 "Return the number of elements in TABLE.")
4542 return check_hash_table (table
)->count
;
4546 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4547 Shash_table_rehash_size
, 1, 1, 0,
4548 "Return the current rehash size of TABLE.")
4552 return check_hash_table (table
)->rehash_size
;
4556 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4557 Shash_table_rehash_threshold
, 1, 1, 0,
4558 "Return the current rehash threshold of TABLE.")
4562 return check_hash_table (table
)->rehash_threshold
;
4566 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4567 "Return the size of TABLE.\n\
4568 The size can be used as an argument to `make-hash-table' to create\n\
4569 a hash table than can hold as many elements of TABLE holds\n\
4570 without need for resizing.")
4574 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4575 return make_number (HASH_TABLE_SIZE (h
));
4579 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4580 "Return the test TABLE uses.")
4584 return check_hash_table (table
)->test
;
4588 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4590 "Return the weakness of TABLE.")
4594 return check_hash_table (table
)->weak
;
4598 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4599 "Return t if OBJ is a Lisp hash table object.")
4603 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4607 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4608 "Clear hash table TABLE.")
4612 hash_clear (check_hash_table (table
));
4617 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4618 "Look up KEY in TABLE and return its associated value.\n\
4619 If KEY is not found, return DFLT which defaults to nil.")
4621 Lisp_Object key
, table
, dflt
;
4623 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4624 int i
= hash_lookup (h
, key
, NULL
);
4625 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4629 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4630 "Associate KEY with VALUE is hash table TABLE.\n\
4631 If KEY is already present in table, replace its current value with\n\
4634 Lisp_Object key
, value
, table
;
4636 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4640 i
= hash_lookup (h
, key
, &hash
);
4642 HASH_VALUE (h
, i
) = value
;
4644 hash_put (h
, key
, value
, hash
);
4650 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4651 "Remove KEY from TABLE.")
4653 Lisp_Object key
, table
;
4655 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4656 hash_remove (h
, key
);
4661 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4662 "Call FUNCTION for all entries in hash table TABLE.\n\
4663 FUNCTION is called with 2 arguments KEY and VALUE.")
4665 Lisp_Object function
, table
;
4667 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4668 Lisp_Object args
[3];
4671 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4672 if (!NILP (HASH_HASH (h
, i
)))
4675 args
[1] = HASH_KEY (h
, i
);
4676 args
[2] = HASH_VALUE (h
, i
);
4684 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4685 Sdefine_hash_table_test
, 3, 3, 0,
4686 "Define a new hash table test with name NAME, a symbol.\n\
4687 In hash tables create with NAME specified as test, use TEST to compare\n\
4688 keys, and HASH for computing hash codes of keys.\n\
4690 TEST must be a function taking two arguments and returning non-nil\n\
4691 if both arguments are the same. HASH must be a function taking\n\
4692 one argument and return an integer that is the hash code of the\n\
4693 argument. Hash code computation should use the whole value range of\n\
4694 integers, including negative integers.")
4696 Lisp_Object name
, test
, hash
;
4698 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4707 /* Hash table stuff. */
4708 Qhash_table_p
= intern ("hash-table-p");
4709 staticpro (&Qhash_table_p
);
4710 Qeq
= intern ("eq");
4712 Qeql
= intern ("eql");
4714 Qequal
= intern ("equal");
4715 staticpro (&Qequal
);
4716 QCtest
= intern (":test");
4717 staticpro (&QCtest
);
4718 QCsize
= intern (":size");
4719 staticpro (&QCsize
);
4720 QCrehash_size
= intern (":rehash-size");
4721 staticpro (&QCrehash_size
);
4722 QCrehash_threshold
= intern (":rehash-threshold");
4723 staticpro (&QCrehash_threshold
);
4724 QCweakness
= intern (":weakness");
4725 staticpro (&QCweakness
);
4726 Qkey
= intern ("key");
4728 Qvalue
= intern ("value");
4729 staticpro (&Qvalue
);
4730 Qhash_table_test
= intern ("hash-table-test");
4731 staticpro (&Qhash_table_test
);
4734 defsubr (&Smake_hash_table
);
4735 defsubr (&Scopy_hash_table
);
4736 defsubr (&Smakehash
);
4737 defsubr (&Shash_table_count
);
4738 defsubr (&Shash_table_rehash_size
);
4739 defsubr (&Shash_table_rehash_threshold
);
4740 defsubr (&Shash_table_size
);
4741 defsubr (&Shash_table_test
);
4742 defsubr (&Shash_table_weakness
);
4743 defsubr (&Shash_table_p
);
4744 defsubr (&Sclrhash
);
4745 defsubr (&Sgethash
);
4746 defsubr (&Sputhash
);
4747 defsubr (&Sremhash
);
4748 defsubr (&Smaphash
);
4749 defsubr (&Sdefine_hash_table_test
);
4751 Qstring_lessp
= intern ("string-lessp");
4752 staticpro (&Qstring_lessp
);
4753 Qprovide
= intern ("provide");
4754 staticpro (&Qprovide
);
4755 Qrequire
= intern ("require");
4756 staticpro (&Qrequire
);
4757 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4758 staticpro (&Qyes_or_no_p_history
);
4759 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4760 staticpro (&Qcursor_in_echo_area
);
4761 Qwidget_type
= intern ("widget-type");
4762 staticpro (&Qwidget_type
);
4764 staticpro (&string_char_byte_cache_string
);
4765 string_char_byte_cache_string
= Qnil
;
4767 Fset (Qyes_or_no_p_history
, Qnil
);
4769 DEFVAR_LISP ("features", &Vfeatures
,
4770 "A list of symbols which are the features of the executing emacs.\n\
4771 Used by `featurep' and `require', and altered by `provide'.");
4774 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4775 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4776 This applies to y-or-n and yes-or-no questions asked by commands\n\
4777 invoked by mouse clicks and mouse menu items.");
4780 defsubr (&Sidentity
);
4783 defsubr (&Ssafe_length
);
4784 defsubr (&Sstring_bytes
);
4785 defsubr (&Sstring_equal
);
4786 defsubr (&Scompare_strings
);
4787 defsubr (&Sstring_lessp
);
4790 defsubr (&Svconcat
);
4791 defsubr (&Scopy_sequence
);
4792 defsubr (&Sstring_make_multibyte
);
4793 defsubr (&Sstring_make_unibyte
);
4794 defsubr (&Sstring_as_multibyte
);
4795 defsubr (&Sstring_as_unibyte
);
4796 defsubr (&Scopy_alist
);
4797 defsubr (&Ssubstring
);
4809 defsubr (&Snreverse
);
4810 defsubr (&Sreverse
);
4812 defsubr (&Splist_get
);
4814 defsubr (&Splist_put
);
4817 defsubr (&Sfillarray
);
4818 defsubr (&Schar_table_subtype
);
4819 defsubr (&Schar_table_parent
);
4820 defsubr (&Sset_char_table_parent
);
4821 defsubr (&Schar_table_extra_slot
);
4822 defsubr (&Sset_char_table_extra_slot
);
4823 defsubr (&Schar_table_range
);
4824 defsubr (&Sset_char_table_range
);
4825 defsubr (&Sset_char_table_default
);
4826 defsubr (&Soptimize_char_table
);
4827 defsubr (&Smap_char_table
);
4830 defsubr (&Smapconcat
);
4831 defsubr (&Sy_or_n_p
);
4832 defsubr (&Syes_or_no_p
);
4833 defsubr (&Sload_average
);
4834 defsubr (&Sfeaturep
);
4835 defsubr (&Srequire
);
4836 defsubr (&Sprovide
);
4837 defsubr (&Swidget_plist_member
);
4838 defsubr (&Swidget_put
);
4839 defsubr (&Swidget_get
);
4840 defsubr (&Swidget_apply
);
4841 defsubr (&Sbase64_encode_region
);
4842 defsubr (&Sbase64_decode_region
);
4843 defsubr (&Sbase64_encode_string
);
4844 defsubr (&Sbase64_decode_string
);
4851 Vweak_hash_tables
= Qnil
;