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
);
2266 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2267 character or group of characters that share a value.
2268 DEPTH is the current depth in the originally specified
2269 chartable, and INDICES contains the vector indices
2270 for the levels our callers have descended.
2272 ARG is passed to C_FUNCTION when that is called. */
2275 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2276 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2277 Lisp_Object function
, subtable
, arg
, *indices
;
2284 /* At first, handle ASCII and 8-bit European characters. */
2285 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2287 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2289 (*c_function
) (arg
, make_number (i
), elt
);
2291 call2 (function
, make_number (i
), elt
);
2293 #if 0 /* If the char table has entries for higher characters,
2294 we should report them. */
2295 if (NILP (current_buffer
->enable_multibyte_characters
))
2298 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2303 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2308 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2310 XSETFASTINT (indices
[depth
], i
);
2312 if (SUB_CHAR_TABLE_P (elt
))
2315 error ("Too deep char table");
2316 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2320 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2322 if (CHARSET_DEFINED_P (charset
))
2324 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2325 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2326 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2328 (*c_function
) (arg
, make_number (c
), elt
);
2330 call2 (function
, make_number (c
), elt
);
2336 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2338 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2339 FUNCTION is called with two arguments--a key and a value.\n\
2340 The key is always a possible IDX argument to `aref'.")
2341 (function
, char_table
)
2342 Lisp_Object function
, char_table
;
2344 /* The depth of char table is at most 3. */
2345 Lisp_Object indices
[3];
2347 CHECK_CHAR_TABLE (char_table
, 1);
2349 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2359 Lisp_Object args
[2];
2362 return Fnconc (2, args
);
2364 return Fnconc (2, &s1
);
2365 #endif /* NO_ARG_ARRAY */
2368 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2369 "Concatenate any number of lists by altering them.\n\
2370 Only the last argument is not altered, and need not be a list.")
2375 register int argnum
;
2376 register Lisp_Object tail
, tem
, val
;
2380 for (argnum
= 0; argnum
< nargs
; argnum
++)
2383 if (NILP (tem
)) continue;
2388 if (argnum
+ 1 == nargs
) break;
2391 tem
= wrong_type_argument (Qlistp
, tem
);
2400 tem
= args
[argnum
+ 1];
2401 Fsetcdr (tail
, tem
);
2403 args
[argnum
+ 1] = tail
;
2409 /* This is the guts of all mapping functions.
2410 Apply FN to each element of SEQ, one by one,
2411 storing the results into elements of VALS, a C vector of Lisp_Objects.
2412 LENI is the length of VALS, which should also be the length of SEQ. */
2415 mapcar1 (leni
, vals
, fn
, seq
)
2418 Lisp_Object fn
, seq
;
2420 register Lisp_Object tail
;
2423 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2425 /* Don't let vals contain any garbage when GC happens. */
2426 for (i
= 0; i
< leni
; i
++)
2429 GCPRO3 (dummy
, fn
, seq
);
2431 gcpro1
.nvars
= leni
;
2432 /* We need not explicitly protect `tail' because it is used only on lists, and
2433 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2437 for (i
= 0; i
< leni
; i
++)
2439 dummy
= XVECTOR (seq
)->contents
[i
];
2440 vals
[i
] = call1 (fn
, dummy
);
2443 else if (BOOL_VECTOR_P (seq
))
2445 for (i
= 0; i
< leni
; i
++)
2448 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2449 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2454 vals
[i
] = call1 (fn
, dummy
);
2457 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2459 /* Single-byte string. */
2460 for (i
= 0; i
< leni
; i
++)
2462 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2463 vals
[i
] = call1 (fn
, dummy
);
2466 else if (STRINGP (seq
))
2468 /* Multi-byte string. */
2471 for (i
= 0, i_byte
= 0; i
< leni
;)
2476 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2477 XSETFASTINT (dummy
, c
);
2478 vals
[i_before
] = call1 (fn
, dummy
);
2481 else /* Must be a list, since Flength did not get an error */
2484 for (i
= 0; i
< leni
; i
++)
2486 vals
[i
] = call1 (fn
, Fcar (tail
));
2494 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2495 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2496 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2497 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2498 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2499 (function
, sequence
, separator
)
2500 Lisp_Object function
, sequence
, separator
;
2505 register Lisp_Object
*args
;
2507 struct gcpro gcpro1
;
2509 len
= Flength (sequence
);
2511 nargs
= leni
+ leni
- 1;
2512 if (nargs
< 0) return build_string ("");
2514 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2517 mapcar1 (leni
, args
, function
, sequence
);
2520 for (i
= leni
- 1; i
>= 0; i
--)
2521 args
[i
+ i
] = args
[i
];
2523 for (i
= 1; i
< nargs
; i
+= 2)
2524 args
[i
] = separator
;
2526 return Fconcat (nargs
, args
);
2529 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2530 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2531 The result is a list just as long as SEQUENCE.\n\
2532 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2533 (function
, sequence
)
2534 Lisp_Object function
, sequence
;
2536 register Lisp_Object len
;
2538 register Lisp_Object
*args
;
2540 len
= Flength (sequence
);
2541 leni
= XFASTINT (len
);
2542 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2544 mapcar1 (leni
, args
, function
, sequence
);
2546 return Flist (leni
, args
);
2549 /* Anything that calls this function must protect from GC! */
2551 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2552 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2553 Takes one argument, which is the string to display to ask the question.\n\
2554 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2555 No confirmation of the answer is requested; a single character is enough.\n\
2556 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2557 the bindings in `query-replace-map'; see the documentation of that variable\n\
2558 for more information. In this case, the useful bindings are `act', `skip',\n\
2559 `recenter', and `quit'.\)\n\
2561 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2566 register Lisp_Object obj
, key
, def
, map
;
2567 register int answer
;
2568 Lisp_Object xprompt
;
2569 Lisp_Object args
[2];
2570 struct gcpro gcpro1
, gcpro2
;
2571 int count
= specpdl_ptr
- specpdl
;
2573 specbind (Qcursor_in_echo_area
, Qt
);
2575 map
= Fsymbol_value (intern ("query-replace-map"));
2577 CHECK_STRING (prompt
, 0);
2579 GCPRO2 (prompt
, xprompt
);
2585 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2589 Lisp_Object pane
, menu
;
2590 redisplay_preserve_echo_area ();
2591 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2592 Fcons (Fcons (build_string ("No"), Qnil
),
2594 menu
= Fcons (prompt
, pane
);
2595 obj
= Fx_popup_dialog (Qt
, menu
);
2596 answer
= !NILP (obj
);
2599 #endif /* HAVE_MENUS */
2600 cursor_in_echo_area
= 1;
2601 choose_minibuf_frame ();
2602 message_with_string ("%s(y or n) ", xprompt
, 0);
2604 if (minibuffer_auto_raise
)
2606 Lisp_Object mini_frame
;
2608 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2610 Fraise_frame (mini_frame
);
2613 obj
= read_filtered_event (1, 0, 0, 0);
2614 cursor_in_echo_area
= 0;
2615 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2618 key
= Fmake_vector (make_number (1), obj
);
2619 def
= Flookup_key (map
, key
, Qt
);
2621 if (EQ (def
, intern ("skip")))
2626 else if (EQ (def
, intern ("act")))
2631 else if (EQ (def
, intern ("recenter")))
2637 else if (EQ (def
, intern ("quit")))
2639 /* We want to exit this command for exit-prefix,
2640 and this is the only way to do it. */
2641 else if (EQ (def
, intern ("exit-prefix")))
2646 /* If we don't clear this, then the next call to read_char will
2647 return quit_char again, and we'll enter an infinite loop. */
2652 if (EQ (xprompt
, prompt
))
2654 args
[0] = build_string ("Please answer y or n. ");
2656 xprompt
= Fconcat (2, args
);
2661 if (! noninteractive
)
2663 cursor_in_echo_area
= -1;
2664 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2668 unbind_to (count
, Qnil
);
2669 return answer
? Qt
: Qnil
;
2672 /* This is how C code calls `yes-or-no-p' and allows the user
2675 Anything that calls this function must protect from GC! */
2678 do_yes_or_no_p (prompt
)
2681 return call1 (intern ("yes-or-no-p"), prompt
);
2684 /* Anything that calls this function must protect from GC! */
2686 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2687 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2688 Takes one argument, which is the string to display to ask the question.\n\
2689 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2690 The user must confirm the answer with RET,\n\
2691 and can edit it until it has been confirmed.\n\
2693 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2698 register Lisp_Object ans
;
2699 Lisp_Object args
[2];
2700 struct gcpro gcpro1
;
2702 CHECK_STRING (prompt
, 0);
2705 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2709 Lisp_Object pane
, menu
, obj
;
2710 redisplay_preserve_echo_area ();
2711 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2712 Fcons (Fcons (build_string ("No"), Qnil
),
2715 menu
= Fcons (prompt
, pane
);
2716 obj
= Fx_popup_dialog (Qt
, menu
);
2720 #endif /* HAVE_MENUS */
2723 args
[1] = build_string ("(yes or no) ");
2724 prompt
= Fconcat (2, args
);
2730 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2731 Qyes_or_no_p_history
, Qnil
,
2733 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2738 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2746 message ("Please answer yes or no.");
2747 Fsleep_for (make_number (2), Qnil
);
2751 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2752 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2753 Each of the three load averages is multiplied by 100,\n\
2754 then converted to integer.\n\
2755 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2756 These floats are not multiplied by 100.\n\n\
2757 If the 5-minute or 15-minute load averages are not available, return a\n\
2758 shortened list, containing only those averages which are available.")
2760 Lisp_Object use_floats
;
2763 int loads
= getloadavg (load_ave
, 3);
2764 Lisp_Object ret
= Qnil
;
2767 error ("load-average not implemented for this operating system");
2771 Lisp_Object load
= (NILP (use_floats
) ?
2772 make_number ((int) (100.0 * load_ave
[loads
]))
2773 : make_float (load_ave
[loads
]));
2774 ret
= Fcons (load
, ret
);
2780 Lisp_Object Vfeatures
;
2782 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2783 "Returns t if FEATURE is present in this Emacs.\n\
2784 Use this to conditionalize execution of lisp code based on the presence or\n\
2785 absence of emacs or environment extensions.\n\
2786 Use `provide' to declare that a feature is available.\n\
2787 This function looks at the value of the variable `features'.")
2789 Lisp_Object feature
;
2791 register Lisp_Object tem
;
2792 CHECK_SYMBOL (feature
, 0);
2793 tem
= Fmemq (feature
, Vfeatures
);
2794 return (NILP (tem
)) ? Qnil
: Qt
;
2797 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2798 "Announce that FEATURE is a feature of the current Emacs.")
2800 Lisp_Object feature
;
2802 register Lisp_Object tem
;
2803 CHECK_SYMBOL (feature
, 0);
2804 if (!NILP (Vautoload_queue
))
2805 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2806 tem
= Fmemq (feature
, Vfeatures
);
2808 Vfeatures
= Fcons (feature
, Vfeatures
);
2809 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2813 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2814 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2815 If FEATURE is not a member of the list `features', then the feature\n\
2816 is not loaded; so load the file FILENAME.\n\
2817 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2818 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2819 If the optional third argument NOERROR is non-nil,\n\
2820 then return nil if the file is not found.\n\
2821 Normally the return value is FEATURE.")
2822 (feature
, file_name
, noerror
)
2823 Lisp_Object feature
, file_name
, noerror
;
2825 register Lisp_Object tem
;
2826 CHECK_SYMBOL (feature
, 0);
2827 tem
= Fmemq (feature
, Vfeatures
);
2828 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2831 int count
= specpdl_ptr
- specpdl
;
2833 /* Value saved here is to be restored into Vautoload_queue */
2834 record_unwind_protect (un_autoload
, Vautoload_queue
);
2835 Vautoload_queue
= Qt
;
2837 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2838 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2839 /* If load failed entirely, return nil. */
2841 return unbind_to (count
, Qnil
);
2843 tem
= Fmemq (feature
, Vfeatures
);
2845 error ("Required feature %s was not provided",
2846 XSYMBOL (feature
)->name
->data
);
2848 /* Once loading finishes, don't undo it. */
2849 Vautoload_queue
= Qt
;
2850 feature
= unbind_to (count
, feature
);
2855 /* Primitives for work of the "widget" library.
2856 In an ideal world, this section would not have been necessary.
2857 However, lisp function calls being as slow as they are, it turns
2858 out that some functions in the widget library (wid-edit.el) are the
2859 bottleneck of Widget operation. Here is their translation to C,
2860 for the sole reason of efficiency. */
2862 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2863 "Return non-nil if PLIST has the property PROP.\n\
2864 PLIST is a property list, which is a list of the form\n\
2865 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2866 Unlike `plist-get', this allows you to distinguish between a missing\n\
2867 property and a property with the value nil.\n\
2868 The value is actually the tail of PLIST whose car is PROP.")
2870 Lisp_Object plist
, prop
;
2872 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2875 plist
= XCDR (plist
);
2876 plist
= CDR (plist
);
2881 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2882 "In WIDGET, set PROPERTY to VALUE.\n\
2883 The value can later be retrieved with `widget-get'.")
2884 (widget
, property
, value
)
2885 Lisp_Object widget
, property
, value
;
2887 CHECK_CONS (widget
, 1);
2888 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2892 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2893 "In WIDGET, get the value of PROPERTY.\n\
2894 The value could either be specified when the widget was created, or\n\
2895 later with `widget-put'.")
2897 Lisp_Object widget
, property
;
2905 CHECK_CONS (widget
, 1);
2906 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2912 tmp
= XCAR (widget
);
2915 widget
= Fget (tmp
, Qwidget_type
);
2919 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2920 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2921 ARGS are passed as extra arguments to the function.")
2926 /* This function can GC. */
2927 Lisp_Object newargs
[3];
2928 struct gcpro gcpro1
, gcpro2
;
2931 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2932 newargs
[1] = args
[0];
2933 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2934 GCPRO2 (newargs
[0], newargs
[2]);
2935 result
= Fapply (3, newargs
);
2940 /* base64 encode/decode functions.
2941 Based on code from GNU recode. */
2943 #define MIME_LINE_LENGTH 76
2945 #define IS_ASCII(Character) \
2947 #define IS_BASE64(Character) \
2948 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2949 #define IS_BASE64_IGNORABLE(Character) \
2950 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2951 || (Character) == '\f' || (Character) == '\r')
2953 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2954 character or return retval if there are no characters left to
2956 #define READ_QUADRUPLET_BYTE(retval) \
2963 while (IS_BASE64_IGNORABLE (c))
2965 /* Don't use alloca for regions larger than this, lest we overflow
2967 #define MAX_ALLOCA 16*1024
2969 /* Table of characters coding the 64 values. */
2970 static char base64_value_to_char
[64] =
2972 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2973 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2974 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2975 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2976 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2977 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2978 '8', '9', '+', '/' /* 60-63 */
2981 /* Table of base64 values for first 128 characters. */
2982 static short base64_char_to_value
[128] =
2984 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2985 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2986 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2987 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2988 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2989 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2990 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2991 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2992 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2993 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2994 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2995 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2996 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2999 /* The following diagram shows the logical steps by which three octets
3000 get transformed into four base64 characters.
3002 .--------. .--------. .--------.
3003 |aaaaaabb| |bbbbcccc| |ccdddddd|
3004 `--------' `--------' `--------'
3006 .--------+--------+--------+--------.
3007 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3008 `--------+--------+--------+--------'
3010 .--------+--------+--------+--------.
3011 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3012 `--------+--------+--------+--------'
3014 The octets are divided into 6 bit chunks, which are then encoded into
3015 base64 characters. */
3018 static int base64_encode_1
P_ ((const char *, char *, int, int));
3019 static int base64_decode_1
P_ ((const char *, char *, int));
3021 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3023 "Base64-encode the region between BEG and END.\n\
3024 Return the length of the encoded text.\n\
3025 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3026 into shorter lines.")
3027 (beg
, end
, no_line_break
)
3028 Lisp_Object beg
, end
, no_line_break
;
3031 int allength
, length
;
3032 int ibeg
, iend
, encoded_length
;
3035 validate_region (&beg
, &end
);
3037 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3038 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3039 move_gap_both (XFASTINT (beg
), ibeg
);
3041 /* We need to allocate enough room for encoding the text.
3042 We need 33 1/3% more space, plus a newline every 76
3043 characters, and then we round up. */
3044 length
= iend
- ibeg
;
3045 allength
= length
+ length
/3 + 1;
3046 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3048 if (allength
<= MAX_ALLOCA
)
3049 encoded
= (char *) alloca (allength
);
3051 encoded
= (char *) xmalloc (allength
);
3052 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3053 NILP (no_line_break
));
3054 if (encoded_length
> allength
)
3057 /* Now we have encoded the region, so we insert the new contents
3058 and delete the old. (Insert first in order to preserve markers.) */
3059 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3060 insert (encoded
, encoded_length
);
3061 if (allength
> MAX_ALLOCA
)
3063 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3065 /* If point was outside of the region, restore it exactly; else just
3066 move to the beginning of the region. */
3067 if (old_pos
>= XFASTINT (end
))
3068 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3069 else if (old_pos
> XFASTINT (beg
))
3070 old_pos
= XFASTINT (beg
);
3073 /* We return the length of the encoded text. */
3074 return make_number (encoded_length
);
3077 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3079 "Base64-encode STRING and return the result.\n\
3080 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3081 into shorter lines.")
3082 (string
, no_line_break
)
3083 Lisp_Object string
, no_line_break
;
3085 int allength
, length
, encoded_length
;
3087 Lisp_Object encoded_string
;
3089 CHECK_STRING (string
, 1);
3091 /* We need to allocate enough room for encoding the text.
3092 We need 33 1/3% more space, plus a newline every 76
3093 characters, and then we round up. */
3094 length
= STRING_BYTES (XSTRING (string
));
3095 allength
= length
+ length
/3 + 1;
3096 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3098 /* We need to allocate enough room for decoding the text. */
3099 if (allength
<= MAX_ALLOCA
)
3100 encoded
= (char *) alloca (allength
);
3102 encoded
= (char *) xmalloc (allength
);
3104 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3105 encoded
, length
, NILP (no_line_break
));
3106 if (encoded_length
> allength
)
3109 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3110 if (allength
> MAX_ALLOCA
)
3113 return encoded_string
;
3117 base64_encode_1 (from
, to
, length
, line_break
)
3123 int counter
= 0, i
= 0;
3132 /* Wrap line every 76 characters. */
3136 if (counter
< MIME_LINE_LENGTH
/ 4)
3145 /* Process first byte of a triplet. */
3147 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3148 value
= (0x03 & c
) << 4;
3150 /* Process second byte of a triplet. */
3154 *e
++ = base64_value_to_char
[value
];
3162 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3163 value
= (0x0f & c
) << 2;
3165 /* Process third byte of a triplet. */
3169 *e
++ = base64_value_to_char
[value
];
3176 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3177 *e
++ = base64_value_to_char
[0x3f & c
];
3184 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3186 "Base64-decode the region between BEG and END.\n\
3187 Return the length of the decoded text.\n\
3188 If the region can't be decoded, return nil and don't modify the buffer.")
3190 Lisp_Object beg
, end
;
3192 int ibeg
, iend
, length
;
3198 validate_region (&beg
, &end
);
3200 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3201 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3203 length
= iend
- ibeg
;
3204 /* We need to allocate enough room for decoding the text. */
3205 if (length
<= MAX_ALLOCA
)
3206 decoded
= (char *) alloca (length
);
3208 decoded
= (char *) xmalloc (length
);
3210 move_gap_both (XFASTINT (beg
), ibeg
);
3211 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3212 if (decoded_length
> length
)
3215 if (decoded_length
< 0)
3217 /* The decoding wasn't possible. */
3218 if (length
> MAX_ALLOCA
)
3223 /* Now we have decoded the region, so we insert the new contents
3224 and delete the old. (Insert first in order to preserve markers.) */
3225 /* We insert two spaces, then insert the decoded text in between
3226 them, at last, delete those extra two spaces. This is to avoid
3227 byte combining while inserting. */
3228 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3229 insert_1_both (" ", 2, 2, 0, 1, 0);
3230 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3231 insert (decoded
, decoded_length
);
3232 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3233 if (length
> MAX_ALLOCA
)
3235 /* At first delete the original text. This never cause byte
3237 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3238 iend
+ decoded_length
+ 2, 1);
3239 /* Next delete the extra spaces. This will cause byte combining
3241 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3242 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3243 inserted_chars
= PT
- XFASTINT (beg
);
3245 /* If point was outside of the region, restore it exactly; else just
3246 move to the beginning of the region. */
3247 if (old_pos
>= XFASTINT (end
))
3248 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3249 else if (old_pos
> XFASTINT (beg
))
3250 old_pos
= XFASTINT (beg
);
3251 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3253 return make_number (inserted_chars
);
3256 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3258 "Base64-decode STRING and return the result.")
3263 int length
, decoded_length
;
3264 Lisp_Object decoded_string
;
3266 CHECK_STRING (string
, 1);
3268 length
= STRING_BYTES (XSTRING (string
));
3269 /* We need to allocate enough room for decoding the text. */
3270 if (length
<= MAX_ALLOCA
)
3271 decoded
= (char *) alloca (length
);
3273 decoded
= (char *) xmalloc (length
);
3275 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3276 if (decoded_length
> length
)
3279 if (decoded_length
< 0)
3280 /* The decoding wasn't possible. */
3281 decoded_string
= Qnil
;
3283 decoded_string
= make_string (decoded
, decoded_length
);
3285 if (length
> MAX_ALLOCA
)
3288 return decoded_string
;
3292 base64_decode_1 (from
, to
, length
)
3300 unsigned long value
;
3304 /* Process first byte of a quadruplet. */
3306 READ_QUADRUPLET_BYTE (e
-to
);
3310 value
= base64_char_to_value
[c
] << 18;
3312 /* Process second byte of a quadruplet. */
3314 READ_QUADRUPLET_BYTE (-1);
3318 value
|= base64_char_to_value
[c
] << 12;
3320 *e
++ = (unsigned char) (value
>> 16);
3322 /* Process third byte of a quadruplet. */
3324 READ_QUADRUPLET_BYTE (-1);
3328 READ_QUADRUPLET_BYTE (-1);
3337 value
|= base64_char_to_value
[c
] << 6;
3339 *e
++ = (unsigned char) (0xff & value
>> 8);
3341 /* Process fourth byte of a quadruplet. */
3343 READ_QUADRUPLET_BYTE (-1);
3350 value
|= base64_char_to_value
[c
];
3352 *e
++ = (unsigned char) (0xff & value
);
3358 /***********************************************************************
3360 ***** Hash Tables *****
3362 ***********************************************************************/
3364 /* Implemented by gerd@gnu.org. This hash table implementation was
3365 inspired by CMUCL hash tables. */
3369 1. For small tables, association lists are probably faster than
3370 hash tables because they have lower overhead.
3372 For uses of hash tables where the O(1) behavior of table
3373 operations is not a requirement, it might therefore be a good idea
3374 not to hash. Instead, we could just do a linear search in the
3375 key_and_value vector of the hash table. This could be done
3376 if a `:linear-search t' argument is given to make-hash-table. */
3379 /* Return the contents of vector V at index IDX. */
3381 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3383 /* Value is the key part of entry IDX in hash table H. */
3385 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3387 /* Value is the value part of entry IDX in hash table H. */
3389 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3391 /* Value is the index of the next entry following the one at IDX
3394 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3396 /* Value is the hash code computed for entry IDX in hash table H. */
3398 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3400 /* Value is the index of the element in hash table H that is the
3401 start of the collision list at index IDX in the index vector of H. */
3403 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3405 /* Value is the size of hash table H. */
3407 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3409 /* The list of all weak hash tables. Don't staticpro this one. */
3411 Lisp_Object Vweak_hash_tables
;
3413 /* Various symbols. */
3415 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3416 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3417 Lisp_Object Qhash_table_test
;
3419 /* Function prototypes. */
3421 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3422 static int next_almost_prime
P_ ((int));
3423 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3424 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3425 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3426 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3427 Lisp_Object
, unsigned));
3428 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3429 Lisp_Object
, unsigned));
3430 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3431 unsigned, Lisp_Object
, unsigned));
3432 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3433 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3434 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3435 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3437 static unsigned sxhash_string
P_ ((unsigned char *, int));
3438 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3439 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3440 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3441 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3445 /***********************************************************************
3447 ***********************************************************************/
3449 /* If OBJ is a Lisp hash table, return a pointer to its struct
3450 Lisp_Hash_Table. Otherwise, signal an error. */
3452 static struct Lisp_Hash_Table
*
3453 check_hash_table (obj
)
3456 CHECK_HASH_TABLE (obj
, 0);
3457 return XHASH_TABLE (obj
);
3461 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3465 next_almost_prime (n
)
3478 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3479 which USED[I] is non-zero. If found at index I in ARGS, set
3480 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3481 -1. This function is used to extract a keyword/argument pair from
3482 a DEFUN parameter list. */
3485 get_key_arg (key
, nargs
, args
, used
)
3493 for (i
= 0; i
< nargs
- 1; ++i
)
3494 if (!used
[i
] && EQ (args
[i
], key
))
3509 /* Return a Lisp vector which has the same contents as VEC but has
3510 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3511 vector that are not copied from VEC are set to INIT. */
3514 larger_vector (vec
, new_size
, init
)
3519 struct Lisp_Vector
*v
;
3522 xassert (VECTORP (vec
));
3523 old_size
= XVECTOR (vec
)->size
;
3524 xassert (new_size
>= old_size
);
3526 v
= allocate_vectorlike (new_size
);
3528 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3529 old_size
* sizeof *v
->contents
);
3530 for (i
= old_size
; i
< new_size
; ++i
)
3531 v
->contents
[i
] = init
;
3532 XSETVECTOR (vec
, v
);
3537 /***********************************************************************
3539 ***********************************************************************/
3541 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3542 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3543 KEY2 are the same. */
3546 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3547 struct Lisp_Hash_Table
*h
;
3548 Lisp_Object key1
, key2
;
3549 unsigned hash1
, hash2
;
3551 return (FLOATP (key1
)
3553 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3557 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3558 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3559 KEY2 are the same. */
3562 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3563 struct Lisp_Hash_Table
*h
;
3564 Lisp_Object key1
, key2
;
3565 unsigned hash1
, hash2
;
3567 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3571 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3572 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3573 if KEY1 and KEY2 are the same. */
3576 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3577 struct Lisp_Hash_Table
*h
;
3578 Lisp_Object key1
, key2
;
3579 unsigned hash1
, hash2
;
3583 Lisp_Object args
[3];
3585 args
[0] = h
->user_cmp_function
;
3588 return !NILP (Ffuncall (3, args
));
3595 /* Value is a hash code for KEY for use in hash table H which uses
3596 `eq' to compare keys. The hash code returned is guaranteed to fit
3597 in a Lisp integer. */
3601 struct Lisp_Hash_Table
*h
;
3604 /* Lisp strings can change their address. Don't try to compute a
3605 hash code for a string from its address. */
3607 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3609 return XUINT (key
) ^ XGCTYPE (key
);
3613 /* Value is a hash code for KEY for use in hash table H which uses
3614 `eql' to compare keys. The hash code returned is guaranteed to fit
3615 in a Lisp integer. */
3619 struct Lisp_Hash_Table
*h
;
3622 /* Lisp strings can change their address. Don't try to compute a
3623 hash code for a string from its address. */
3625 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3626 else if (FLOATP (key
))
3627 return sxhash (key
, 0);
3629 return XUINT (key
) ^ XGCTYPE (key
);
3633 /* Value is a hash code for KEY for use in hash table H which uses
3634 `equal' to compare keys. The hash code returned is guaranteed to fit
3635 in a Lisp integer. */
3638 hashfn_equal (h
, key
)
3639 struct Lisp_Hash_Table
*h
;
3642 return sxhash (key
, 0);
3646 /* Value is a hash code for KEY for use in hash table H which uses as
3647 user-defined function to compare keys. The hash code returned is
3648 guaranteed to fit in a Lisp integer. */
3651 hashfn_user_defined (h
, key
)
3652 struct Lisp_Hash_Table
*h
;
3655 Lisp_Object args
[2], hash
;
3657 args
[0] = h
->user_hash_function
;
3659 hash
= Ffuncall (2, args
);
3660 if (!INTEGERP (hash
))
3662 list2 (build_string ("Illegal hash code returned from \
3663 user-supplied hash function"),
3665 return XUINT (hash
);
3669 /* Create and initialize a new hash table.
3671 TEST specifies the test the hash table will use to compare keys.
3672 It must be either one of the predefined tests `eq', `eql' or
3673 `equal' or a symbol denoting a user-defined test named TEST with
3674 test and hash functions USER_TEST and USER_HASH.
3676 Give the table initial capacity SIZE, SIZE > 0, an integer.
3678 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3679 new size when it becomes full is computed by adding REHASH_SIZE to
3680 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3681 table's new size is computed by multiplying its old size with
3684 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3685 be resized when the ratio of (number of entries in the table) /
3686 (table size) is >= REHASH_THRESHOLD.
3688 WEAK specifies the weakness of the table. If non-nil, it must be
3689 one of the symbols `key', `value' or t. */
3692 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3693 user_test
, user_hash
)
3694 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3695 Lisp_Object user_test
, user_hash
;
3697 struct Lisp_Hash_Table
*h
;
3698 struct Lisp_Vector
*v
;
3700 int index_size
, i
, len
, sz
;
3702 /* Preconditions. */
3703 xassert (SYMBOLP (test
));
3704 xassert (INTEGERP (size
) && XINT (size
) > 0);
3705 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3706 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3707 xassert (FLOATP (rehash_threshold
)
3708 && XFLOATINT (rehash_threshold
) > 0
3709 && XFLOATINT (rehash_threshold
) <= 1.0);
3711 /* Allocate a vector, and initialize it. */
3712 len
= VECSIZE (struct Lisp_Hash_Table
);
3713 v
= allocate_vectorlike (len
);
3715 for (i
= 0; i
< len
; ++i
)
3716 v
->contents
[i
] = Qnil
;
3718 /* Initialize hash table slots. */
3719 sz
= XFASTINT (size
);
3720 h
= (struct Lisp_Hash_Table
*) v
;
3723 if (EQ (test
, Qeql
))
3725 h
->cmpfn
= cmpfn_eql
;
3726 h
->hashfn
= hashfn_eql
;
3728 else if (EQ (test
, Qeq
))
3731 h
->hashfn
= hashfn_eq
;
3733 else if (EQ (test
, Qequal
))
3735 h
->cmpfn
= cmpfn_equal
;
3736 h
->hashfn
= hashfn_equal
;
3740 h
->user_cmp_function
= user_test
;
3741 h
->user_hash_function
= user_hash
;
3742 h
->cmpfn
= cmpfn_user_defined
;
3743 h
->hashfn
= hashfn_user_defined
;
3747 h
->rehash_threshold
= rehash_threshold
;
3748 h
->rehash_size
= rehash_size
;
3749 h
->count
= make_number (0);
3750 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3751 h
->hash
= Fmake_vector (size
, Qnil
);
3752 h
->next
= Fmake_vector (size
, Qnil
);
3753 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3754 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3756 /* Set up the free list. */
3757 for (i
= 0; i
< sz
- 1; ++i
)
3758 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3759 h
->next_free
= make_number (0);
3761 XSET_HASH_TABLE (table
, h
);
3762 xassert (HASH_TABLE_P (table
));
3763 xassert (XHASH_TABLE (table
) == h
);
3765 /* Maybe add this hash table to the list of all weak hash tables. */
3767 h
->next_weak
= Qnil
;
3770 h
->next_weak
= Vweak_hash_tables
;
3771 Vweak_hash_tables
= table
;
3778 /* Return a copy of hash table H1. Keys and values are not copied,
3779 only the table itself is. */
3782 copy_hash_table (h1
)
3783 struct Lisp_Hash_Table
*h1
;
3786 struct Lisp_Hash_Table
*h2
;
3787 struct Lisp_Vector
*v
, *next
;
3790 len
= VECSIZE (struct Lisp_Hash_Table
);
3791 v
= allocate_vectorlike (len
);
3792 h2
= (struct Lisp_Hash_Table
*) v
;
3793 next
= h2
->vec_next
;
3794 bcopy (h1
, h2
, sizeof *h2
);
3795 h2
->vec_next
= next
;
3796 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3797 h2
->hash
= Fcopy_sequence (h1
->hash
);
3798 h2
->next
= Fcopy_sequence (h1
->next
);
3799 h2
->index
= Fcopy_sequence (h1
->index
);
3800 XSET_HASH_TABLE (table
, h2
);
3802 /* Maybe add this hash table to the list of all weak hash tables. */
3803 if (!NILP (h2
->weak
))
3805 h2
->next_weak
= Vweak_hash_tables
;
3806 Vweak_hash_tables
= table
;
3813 /* Resize hash table H if it's too full. If H cannot be resized
3814 because it's already too large, throw an error. */
3817 maybe_resize_hash_table (h
)
3818 struct Lisp_Hash_Table
*h
;
3820 if (NILP (h
->next_free
))
3822 int old_size
= HASH_TABLE_SIZE (h
);
3823 int i
, new_size
, index_size
;
3825 if (INTEGERP (h
->rehash_size
))
3826 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3828 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3829 new_size
= max (old_size
+ 1, new_size
);
3830 index_size
= next_almost_prime (new_size
3831 / XFLOATINT (h
->rehash_threshold
));
3832 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3833 error ("Hash table too large to resize");
3835 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3836 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3837 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3838 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3840 /* Update the free list. Do it so that new entries are added at
3841 the end of the free list. This makes some operations like
3843 for (i
= old_size
; i
< new_size
- 1; ++i
)
3844 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3846 if (!NILP (h
->next_free
))
3848 Lisp_Object last
, next
;
3850 last
= h
->next_free
;
3851 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3855 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3858 XSETFASTINT (h
->next_free
, old_size
);
3861 for (i
= 0; i
< old_size
; ++i
)
3862 if (!NILP (HASH_HASH (h
, i
)))
3864 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3865 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3866 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3867 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3873 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3874 the hash code of KEY. Value is the index of the entry in H
3875 matching KEY, or -1 if not found. */
3878 hash_lookup (h
, key
, hash
)
3879 struct Lisp_Hash_Table
*h
;
3884 int start_of_bucket
;
3887 hash_code
= h
->hashfn (h
, key
);
3891 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3892 idx
= HASH_INDEX (h
, start_of_bucket
);
3896 int i
= XFASTINT (idx
);
3897 if (EQ (key
, HASH_KEY (h
, i
))
3899 && h
->cmpfn (h
, key
, hash_code
,
3900 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3902 idx
= HASH_NEXT (h
, i
);
3905 return NILP (idx
) ? -1 : XFASTINT (idx
);
3909 /* Put an entry into hash table H that associates KEY with VALUE.
3910 HASH is a previously computed hash code of KEY.
3911 Value is the index of the entry in H matching KEY. */
3914 hash_put (h
, key
, value
, hash
)
3915 struct Lisp_Hash_Table
*h
;
3916 Lisp_Object key
, value
;
3919 int start_of_bucket
, i
;
3921 xassert ((hash
& ~VALMASK
) == 0);
3923 /* Increment count after resizing because resizing may fail. */
3924 maybe_resize_hash_table (h
);
3925 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3927 /* Store key/value in the key_and_value vector. */
3928 i
= XFASTINT (h
->next_free
);
3929 h
->next_free
= HASH_NEXT (h
, i
);
3930 HASH_KEY (h
, i
) = key
;
3931 HASH_VALUE (h
, i
) = value
;
3933 /* Remember its hash code. */
3934 HASH_HASH (h
, i
) = make_number (hash
);
3936 /* Add new entry to its collision chain. */
3937 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3938 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3939 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3944 /* Remove the entry matching KEY from hash table H, if there is one. */
3947 hash_remove (h
, key
)
3948 struct Lisp_Hash_Table
*h
;
3952 int start_of_bucket
;
3953 Lisp_Object idx
, prev
;
3955 hash_code
= h
->hashfn (h
, key
);
3956 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3957 idx
= HASH_INDEX (h
, start_of_bucket
);
3962 int i
= XFASTINT (idx
);
3964 if (EQ (key
, HASH_KEY (h
, i
))
3966 && h
->cmpfn (h
, key
, hash_code
,
3967 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3969 /* Take entry out of collision chain. */
3971 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3973 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3975 /* Clear slots in key_and_value and add the slots to
3977 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3978 HASH_NEXT (h
, i
) = h
->next_free
;
3979 h
->next_free
= make_number (i
);
3980 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3981 xassert (XINT (h
->count
) >= 0);
3987 idx
= HASH_NEXT (h
, i
);
3993 /* Clear hash table H. */
3997 struct Lisp_Hash_Table
*h
;
3999 if (XFASTINT (h
->count
) > 0)
4001 int i
, size
= HASH_TABLE_SIZE (h
);
4003 for (i
= 0; i
< size
; ++i
)
4005 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4006 HASH_KEY (h
, i
) = Qnil
;
4007 HASH_VALUE (h
, i
) = Qnil
;
4008 HASH_HASH (h
, i
) = Qnil
;
4011 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4012 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4014 h
->next_free
= make_number (0);
4015 h
->count
= make_number (0);
4021 /************************************************************************
4023 ************************************************************************/
4025 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4026 entries from the table that don't survive the current GC.
4027 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4028 non-zero if anything was marked. */
4031 sweep_weak_table (h
, remove_entries_p
)
4032 struct Lisp_Hash_Table
*h
;
4033 int remove_entries_p
;
4035 int bucket
, n
, marked
;
4037 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4040 for (bucket
= 0; bucket
< n
; ++bucket
)
4042 Lisp_Object idx
, prev
;
4044 /* Follow collision chain, removing entries that
4045 don't survive this garbage collection. */
4046 idx
= HASH_INDEX (h
, bucket
);
4048 while (!GC_NILP (idx
))
4051 int i
= XFASTINT (idx
);
4054 if (EQ (h
->weak
, Qkey
))
4055 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
4056 else if (EQ (h
->weak
, Qvalue
))
4057 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
4058 else if (EQ (h
->weak
, Qt
))
4059 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
4060 || !survives_gc_p (HASH_VALUE (h
, i
)));
4064 next
= HASH_NEXT (h
, i
);
4066 if (remove_entries_p
)
4070 /* Take out of collision chain. */
4072 HASH_INDEX (h
, i
) = next
;
4074 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4076 /* Add to free list. */
4077 HASH_NEXT (h
, i
) = h
->next_free
;
4080 /* Clear key, value, and hash. */
4081 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4082 HASH_HASH (h
, i
) = Qnil
;
4084 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4091 /* Make sure key and value survive. */
4092 mark_object (&HASH_KEY (h
, i
));
4093 mark_object (&HASH_VALUE (h
, i
));
4105 /* Remove elements from weak hash tables that don't survive the
4106 current garbage collection. Remove weak tables that don't survive
4107 from Vweak_hash_tables. Called from gc_sweep. */
4110 sweep_weak_hash_tables ()
4113 struct Lisp_Hash_Table
*h
, *prev
;
4116 /* Mark all keys and values that are in use. Keep on marking until
4117 there is no more change. This is necessary for cases like
4118 value-weak table A containing an entry X -> Y, where Y is used in a
4119 key-weak table B, Z -> Y. If B comes after A in the list of weak
4120 tables, X -> Y might be removed from A, although when looking at B
4121 one finds that it shouldn't. */
4125 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4127 h
= XHASH_TABLE (table
);
4128 if (h
->size
& ARRAY_MARK_FLAG
)
4129 marked
|= sweep_weak_table (h
, 0);
4134 /* Remove tables and entries that aren't used. */
4136 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4139 h
= XHASH_TABLE (table
);
4141 if (h
->size
& ARRAY_MARK_FLAG
)
4143 if (XFASTINT (h
->count
) > 0)
4144 sweep_weak_table (h
, 1);
4148 /* Table is not marked, and will thus be freed.
4149 Take it out of the list of weak hash tables. */
4151 prev
->next_weak
= h
->next_weak
;
4153 Vweak_hash_tables
= h
->next_weak
;
4160 /***********************************************************************
4161 Hash Code Computation
4162 ***********************************************************************/
4164 /* Maximum depth up to which to dive into Lisp structures. */
4166 #define SXHASH_MAX_DEPTH 3
4168 /* Maximum length up to which to take list and vector elements into
4171 #define SXHASH_MAX_LEN 7
4173 /* Combine two integers X and Y for hashing. */
4175 #define SXHASH_COMBINE(X, Y) \
4176 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4180 /* Return a hash for string PTR which has length LEN. */
4183 sxhash_string (ptr
, len
)
4187 unsigned char *p
= ptr
;
4188 unsigned char *end
= p
+ len
;
4197 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4200 return hash
& 07777777777;
4204 /* Return a hash for list LIST. DEPTH is the current depth in the
4205 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4208 sxhash_list (list
, depth
)
4215 if (depth
< SXHASH_MAX_DEPTH
)
4217 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4218 list
= XCDR (list
), ++i
)
4220 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4221 hash
= SXHASH_COMBINE (hash
, hash2
);
4228 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4229 the Lisp structure. */
4232 sxhash_vector (vec
, depth
)
4236 unsigned hash
= XVECTOR (vec
)->size
;
4239 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4240 for (i
= 0; i
< n
; ++i
)
4242 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4243 hash
= SXHASH_COMBINE (hash
, hash2
);
4250 /* Return a hash for bool-vector VECTOR. */
4253 sxhash_bool_vector (vec
)
4256 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4259 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4260 for (i
= 0; i
< n
; ++i
)
4261 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4267 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4268 structure. Value is an unsigned integer clipped to VALMASK. */
4277 if (depth
> SXHASH_MAX_DEPTH
)
4280 switch (XTYPE (obj
))
4287 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4288 XSYMBOL (obj
)->name
->size
);
4296 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4299 /* This can be everything from a vector to an overlay. */
4300 case Lisp_Vectorlike
:
4302 /* According to the CL HyperSpec, two arrays are equal only if
4303 they are `eq', except for strings and bit-vectors. In
4304 Emacs, this works differently. We have to compare element
4306 hash
= sxhash_vector (obj
, depth
);
4307 else if (BOOL_VECTOR_P (obj
))
4308 hash
= sxhash_bool_vector (obj
);
4310 /* Others are `equal' if they are `eq', so let's take their
4316 hash
= sxhash_list (obj
, depth
);
4321 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4322 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4323 for (hash
= 0; p
< e
; ++p
)
4324 hash
= SXHASH_COMBINE (hash
, *p
);
4332 return hash
& VALMASK
;
4337 /***********************************************************************
4339 ***********************************************************************/
4342 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4343 "Compute a hash code for OBJ and return it as integer.")
4347 unsigned hash
= sxhash (obj
, 0);;
4348 return make_number (hash
);
4352 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4353 "Create and return a new hash table.\n\
4354 Arguments are specified as keyword/argument pairs. The following\n\
4355 arguments are defined:\n\
4357 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4358 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4359 User-supplied test and hash functions can be specified via\n\
4360 `define-hash-table-test'.\n\
4362 :SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
4365 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4366 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4367 If it is a float, it must be > 1.0, and the new size is computed by\n\
4368 multiplying the old size with that factor. Default is 1.5.\n\
4370 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4371 Resize the hash table when ratio of the number of entries in the table.\n\
4374 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4375 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4376 pairs are removed from a weak hash table when their key, value or both\n\
4377 (WEAK t) are otherwise unreferenced. Default is nil.")
4382 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4383 Lisp_Object user_test
, user_hash
;
4387 /* The vector `used' is used to keep track of arguments that
4388 have been consumed. */
4389 used
= (char *) alloca (nargs
* sizeof *used
);
4390 bzero (used
, nargs
* sizeof *used
);
4392 /* See if there's a `:test TEST' among the arguments. */
4393 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4394 test
= i
< 0 ? Qeql
: args
[i
];
4395 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4397 /* See if it is a user-defined test. */
4400 prop
= Fget (test
, Qhash_table_test
);
4401 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4402 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4404 user_test
= Fnth (make_number (0), prop
);
4405 user_hash
= Fnth (make_number (1), prop
);
4408 user_test
= user_hash
= Qnil
;
4410 /* See if there's a `:size SIZE' argument. */
4411 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4412 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4413 if (!INTEGERP (size
) || XINT (size
) <= 0)
4415 list2 (build_string ("Illegal hash table size"),
4418 /* Look for `:rehash-size SIZE'. */
4419 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4420 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4421 if (!NUMBERP (rehash_size
)
4422 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4423 || XFLOATINT (rehash_size
) <= 1.0)
4425 list2 (build_string ("Illegal hash table rehash size"),
4428 /* Look for `:rehash-threshold THRESHOLD'. */
4429 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4430 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4431 if (!FLOATP (rehash_threshold
)
4432 || XFLOATINT (rehash_threshold
) <= 0.0
4433 || XFLOATINT (rehash_threshold
) > 1.0)
4435 list2 (build_string ("Illegal hash table rehash threshold"),
4438 /* Look for `:weakness WEAK'. */
4439 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4440 weak
= i
< 0 ? Qnil
: args
[i
];
4444 && !EQ (weak
, Qvalue
))
4445 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4448 /* Now, all args should have been used up, or there's a problem. */
4449 for (i
= 0; i
< nargs
; ++i
)
4452 list2 (build_string ("Invalid argument list"), args
[i
]));
4454 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4455 user_test
, user_hash
);
4459 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4460 "Return a copy of hash table TABLE.")
4464 return copy_hash_table (check_hash_table (table
));
4468 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4469 "Create a new hash table.\n\
4470 Optional first argument TEST specifies how to compare keys in\n\
4471 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4472 is `eql'. New tests can be defined with `define-hash-table-test'.")
4476 Lisp_Object args
[2];
4479 return Fmake_hash_table (2, args
);
4483 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4484 "Return the number of elements in TABLE.")
4488 return check_hash_table (table
)->count
;
4492 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4493 Shash_table_rehash_size
, 1, 1, 0,
4494 "Return the current rehash size of TABLE.")
4498 return check_hash_table (table
)->rehash_size
;
4502 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4503 Shash_table_rehash_threshold
, 1, 1, 0,
4504 "Return the current rehash threshold of TABLE.")
4508 return check_hash_table (table
)->rehash_threshold
;
4512 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4513 "Return the size of TABLE.\n\
4514 The size can be used as an argument to `make-hash-table' to create\n\
4515 a hash table than can hold as many elements of TABLE holds\n\
4516 without need for resizing.")
4520 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4521 return make_number (HASH_TABLE_SIZE (h
));
4525 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4526 "Return the test TABLE uses.")
4530 return check_hash_table (table
)->test
;
4534 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4536 "Return the weakness of TABLE.")
4540 return check_hash_table (table
)->weak
;
4544 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4545 "Return t if OBJ is a Lisp hash table object.")
4549 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4553 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4554 "Clear hash table TABLE.")
4558 hash_clear (check_hash_table (table
));
4563 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4564 "Look up KEY in TABLE and return its associated value.\n\
4565 If KEY is not found, return DFLT which defaults to nil.")
4567 Lisp_Object key
, table
, dflt
;
4569 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4570 int i
= hash_lookup (h
, key
, NULL
);
4571 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4575 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4576 "Associate KEY with VALUE is hash table TABLE.\n\
4577 If KEY is already present in table, replace its current value with\n\
4580 Lisp_Object key
, value
, table
;
4582 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4586 i
= hash_lookup (h
, key
, &hash
);
4588 HASH_VALUE (h
, i
) = value
;
4590 hash_put (h
, key
, value
, hash
);
4596 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4597 "Remove KEY from TABLE.")
4599 Lisp_Object key
, table
;
4601 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4602 hash_remove (h
, key
);
4607 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4608 "Call FUNCTION for all entries in hash table TABLE.\n\
4609 FUNCTION is called with 2 arguments KEY and VALUE.")
4611 Lisp_Object function
, table
;
4613 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4614 Lisp_Object args
[3];
4617 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4618 if (!NILP (HASH_HASH (h
, i
)))
4621 args
[1] = HASH_KEY (h
, i
);
4622 args
[2] = HASH_VALUE (h
, i
);
4630 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4631 Sdefine_hash_table_test
, 3, 3, 0,
4632 "Define a new hash table test with name NAME, a symbol.\n\
4633 In hash tables create with NAME specified as test, use TEST to compare\n\
4634 keys, and HASH for computing hash codes of keys.\n\
4636 TEST must be a function taking two arguments and returning non-nil\n\
4637 if both arguments are the same. HASH must be a function taking\n\
4638 one argument and return an integer that is the hash code of the\n\
4639 argument. Hash code computation should use the whole value range of\n\
4640 integers, including negative integers.")
4642 Lisp_Object name
, test
, hash
;
4644 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4653 /* Hash table stuff. */
4654 Qhash_table_p
= intern ("hash-table-p");
4655 staticpro (&Qhash_table_p
);
4656 Qeq
= intern ("eq");
4658 Qeql
= intern ("eql");
4660 Qequal
= intern ("equal");
4661 staticpro (&Qequal
);
4662 QCtest
= intern (":test");
4663 staticpro (&QCtest
);
4664 QCsize
= intern (":size");
4665 staticpro (&QCsize
);
4666 QCrehash_size
= intern (":rehash-size");
4667 staticpro (&QCrehash_size
);
4668 QCrehash_threshold
= intern (":rehash-threshold");
4669 staticpro (&QCrehash_threshold
);
4670 QCweakness
= intern (":weakness");
4671 staticpro (&QCweakness
);
4672 Qkey
= intern ("key");
4674 Qvalue
= intern ("value");
4675 staticpro (&Qvalue
);
4676 Qhash_table_test
= intern ("hash-table-test");
4677 staticpro (&Qhash_table_test
);
4680 defsubr (&Smake_hash_table
);
4681 defsubr (&Scopy_hash_table
);
4682 defsubr (&Smakehash
);
4683 defsubr (&Shash_table_count
);
4684 defsubr (&Shash_table_rehash_size
);
4685 defsubr (&Shash_table_rehash_threshold
);
4686 defsubr (&Shash_table_size
);
4687 defsubr (&Shash_table_test
);
4688 defsubr (&Shash_table_weakness
);
4689 defsubr (&Shash_table_p
);
4690 defsubr (&Sclrhash
);
4691 defsubr (&Sgethash
);
4692 defsubr (&Sputhash
);
4693 defsubr (&Sremhash
);
4694 defsubr (&Smaphash
);
4695 defsubr (&Sdefine_hash_table_test
);
4697 Qstring_lessp
= intern ("string-lessp");
4698 staticpro (&Qstring_lessp
);
4699 Qprovide
= intern ("provide");
4700 staticpro (&Qprovide
);
4701 Qrequire
= intern ("require");
4702 staticpro (&Qrequire
);
4703 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4704 staticpro (&Qyes_or_no_p_history
);
4705 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4706 staticpro (&Qcursor_in_echo_area
);
4707 Qwidget_type
= intern ("widget-type");
4708 staticpro (&Qwidget_type
);
4710 staticpro (&string_char_byte_cache_string
);
4711 string_char_byte_cache_string
= Qnil
;
4713 Fset (Qyes_or_no_p_history
, Qnil
);
4715 DEFVAR_LISP ("features", &Vfeatures
,
4716 "A list of symbols which are the features of the executing emacs.\n\
4717 Used by `featurep' and `require', and altered by `provide'.");
4720 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4721 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4722 This applies to y-or-n and yes-or-no questions asked by commands\n\
4723 invoked by mouse clicks and mouse menu items.");
4726 defsubr (&Sidentity
);
4729 defsubr (&Ssafe_length
);
4730 defsubr (&Sstring_bytes
);
4731 defsubr (&Sstring_equal
);
4732 defsubr (&Scompare_strings
);
4733 defsubr (&Sstring_lessp
);
4736 defsubr (&Svconcat
);
4737 defsubr (&Scopy_sequence
);
4738 defsubr (&Sstring_make_multibyte
);
4739 defsubr (&Sstring_make_unibyte
);
4740 defsubr (&Sstring_as_multibyte
);
4741 defsubr (&Sstring_as_unibyte
);
4742 defsubr (&Scopy_alist
);
4743 defsubr (&Ssubstring
);
4755 defsubr (&Snreverse
);
4756 defsubr (&Sreverse
);
4758 defsubr (&Splist_get
);
4760 defsubr (&Splist_put
);
4763 defsubr (&Sfillarray
);
4764 defsubr (&Schar_table_subtype
);
4765 defsubr (&Schar_table_parent
);
4766 defsubr (&Sset_char_table_parent
);
4767 defsubr (&Schar_table_extra_slot
);
4768 defsubr (&Sset_char_table_extra_slot
);
4769 defsubr (&Schar_table_range
);
4770 defsubr (&Sset_char_table_range
);
4771 defsubr (&Sset_char_table_default
);
4772 defsubr (&Smap_char_table
);
4775 defsubr (&Smapconcat
);
4776 defsubr (&Sy_or_n_p
);
4777 defsubr (&Syes_or_no_p
);
4778 defsubr (&Sload_average
);
4779 defsubr (&Sfeaturep
);
4780 defsubr (&Srequire
);
4781 defsubr (&Sprovide
);
4782 defsubr (&Swidget_plist_member
);
4783 defsubr (&Swidget_put
);
4784 defsubr (&Swidget_get
);
4785 defsubr (&Swidget_apply
);
4786 defsubr (&Sbase64_encode_region
);
4787 defsubr (&Sbase64_decode_region
);
4788 defsubr (&Sbase64_encode_string
);
4789 defsubr (&Sbase64_decode_string
);
4796 Vweak_hash_tables
= Qnil
;