1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 1999 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
52 #define min(a, b) ((a) < (b) ? (a) : (b))
53 #define max(a, b) ((a) > (b) ? (a) : (b))
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 extern int minibuffer_auto_raise
;
61 extern Lisp_Object minibuf_window
;
63 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
64 Lisp_Object Qyes_or_no_p_history
;
65 Lisp_Object Qcursor_in_echo_area
;
66 Lisp_Object Qwidget_type
;
68 extern Lisp_Object Qinput_method_function
;
70 static int internal_equal ();
72 extern long get_random ();
73 extern void seed_random ();
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 "Return the argument unchanged.")
87 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
88 "Return a pseudo-random number.\n\
89 All integers representable in Lisp are equally likely.\n\
90 On most systems, this is 28 bits' worth.\n\
91 With positive integer argument N, return random number in interval [0,N).\n\
92 With argument t, set the random number seed from the current time and pid.")
97 Lisp_Object lispy_val
;
98 unsigned long denominator
;
101 seed_random (getpid () + time (NULL
));
102 if (NATNUMP (n
) && XFASTINT (n
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. We do this by using the
107 quotient rather than the remainder. At the high end of the RNG
108 it's possible to get a quotient larger than n; discarding
109 these values eliminates the bias that would otherwise appear
110 when using a large n. */
111 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
113 val
= get_random () / denominator
;
114 while (val
>= XFASTINT (n
));
118 XSETINT (lispy_val
, val
);
122 /* Random data-structure functions */
124 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
125 "Return the length of vector, list or string SEQUENCE.\n\
126 A byte-code function object is also allowed.\n\
127 If the string contains multibyte characters, this is not the necessarily\n\
128 the number of bytes in the string; it is the number of characters.\n\
129 To get the number of bytes, use `string-bytes'")
131 register Lisp_Object sequence
;
133 register Lisp_Object tail
, val
;
137 if (STRINGP (sequence
))
138 XSETFASTINT (val
, XSTRING (sequence
)->size
);
139 else if (VECTORP (sequence
))
140 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
141 else if (CHAR_TABLE_P (sequence
))
142 XSETFASTINT (val
, (MIN_CHAR_COMPOSITION
143 + (CHAR_FIELD2_MASK
| CHAR_FIELD3_MASK
)
145 else if (BOOL_VECTOR_P (sequence
))
146 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
147 else if (COMPILEDP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
149 else if (CONSP (sequence
))
151 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
157 XSETFASTINT (val
, i
);
159 else if (NILP (sequence
))
160 XSETFASTINT (val
, 0);
163 sequence
= wrong_type_argument (Qsequencep
, sequence
);
169 /* This does not check for quits. That is safe
170 since it must terminate. */
172 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
173 "Return the length of a list, but avoid error or infinite loop.\n\
174 This function never gets an error. If LIST is not really a list,\n\
175 it returns 0. If LIST is circular, it returns a finite value\n\
176 which is at least the number of distinct elements.")
180 Lisp_Object tail
, halftail
, length
;
183 /* halftail is used to detect circular lists. */
185 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
187 if (EQ (tail
, halftail
) && len
!= 0)
191 halftail
= XCDR (halftail
);
194 XSETINT (length
, len
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 "Return the number of bytes in STRING.\n\
200 If STRING is a multibyte string, this is greater than the length of STRING.")
204 CHECK_STRING (string
, 1);
205 return make_number (STRING_BYTES (XSTRING (string
)));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 "Return t if two strings have identical contents.\n\
210 Case is significant, but text properties are ignored.\n\
211 Symbols are also allowed; their print names are used instead.")
213 register Lisp_Object s1
, s2
;
216 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
218 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
219 CHECK_STRING (s1
, 0);
220 CHECK_STRING (s2
, 1);
222 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
223 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
224 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
229 DEFUN ("compare-strings", Fcompare_strings
,
230 Scompare_strings
, 6, 7, 0,
231 "Compare the contents of two strings, converting to multibyte if needed.\n\
232 In string STR1, skip the first START1 characters and stop at END1.\n\
233 In string STR2, skip the first START2 characters and stop at END2.\n\
234 END1 and END2 default to the full lengths of the respective strings.\n\
236 Case is significant in this comparison if IGNORE-CASE is nil.\n\
237 Unibyte strings are converted to multibyte for comparison.\n\
239 The value is t if the strings (or specified portions) match.\n\
240 If string STR1 is less, the value is a negative number N;\n\
241 - 1 - N is the number of characters that match at the beginning.\n\
242 If string STR1 is greater, the value is a positive number N;\n\
243 N - 1 is the number of characters that match at the beginning.")
244 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
245 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
247 register int end1_char
, end2_char
;
248 register int i1
, i1_byte
, i2
, i2_byte
;
250 CHECK_STRING (str1
, 0);
251 CHECK_STRING (str2
, 1);
253 start1
= make_number (0);
255 start2
= make_number (0);
256 CHECK_NATNUM (start1
, 2);
257 CHECK_NATNUM (start2
, 3);
259 CHECK_NATNUM (end1
, 4);
261 CHECK_NATNUM (end2
, 4);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 end1_char
= XSTRING (str1
)->size
;
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
273 end2_char
= XSTRING (str2
)->size
;
274 if (! NILP (end2
) && end2_char
> XINT (end2
))
275 end2_char
= XINT (end2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
287 c1
= XSTRING (str1
)->data
[i1
++];
288 c1
= unibyte_char_to_multibyte (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
295 c2
= XSTRING (str2
)->data
[i2
++];
296 c2
= unibyte_char_to_multibyte (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
);
321 return make_number (i1
);
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 "Return t if first arg string is less than second in lexicographic order.\n\
334 Case is significant.\n\
335 Symbols are also allowed; their print names are used instead.")
337 register Lisp_Object s1
, s2
;
340 register int i1
, i1_byte
, i2
, i2_byte
;
343 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
345 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
346 CHECK_STRING (s1
, 0);
347 CHECK_STRING (s2
, 1);
349 i1
= i1_byte
= i2
= i2_byte
= 0;
351 end
= XSTRING (s1
)->size
;
352 if (end
> XSTRING (s2
)->size
)
353 end
= XSTRING (s2
)->size
;
357 /* When we find a mismatch, we must compare the
358 characters, not just the bytes. */
361 if (STRING_MULTIBYTE (s1
))
362 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
364 c1
= XSTRING (s1
)->data
[i1
++];
366 if (STRING_MULTIBYTE (s2
))
367 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
369 c2
= XSTRING (s2
)->data
[i2
++];
372 return c1
< c2
? Qt
: Qnil
;
374 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
377 static Lisp_Object
concat ();
388 return concat (2, args
, Lisp_String
, 0);
390 return concat (2, &s1
, Lisp_String
, 0);
391 #endif /* NO_ARG_ARRAY */
397 Lisp_Object s1
, s2
, s3
;
404 return concat (3, args
, Lisp_String
, 0);
406 return concat (3, &s1
, Lisp_String
, 0);
407 #endif /* NO_ARG_ARRAY */
410 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
411 "Concatenate all the arguments and make the result a list.\n\
412 The result is a list whose elements are the elements of all the arguments.\n\
413 Each argument may be a list, vector or string.\n\
414 The last argument is not copied, just used as the tail of the new list.")
419 return concat (nargs
, args
, Lisp_Cons
, 1);
422 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
423 "Concatenate all the arguments and make the result a string.\n\
424 The result is a string whose elements are the elements of all the arguments.\n\
425 Each argument may be a string or a list or vector of characters (integers).\n\
427 Do not use individual integers as arguments!\n\
428 The behavior of `concat' in that case will be changed later!\n\
429 If your program passes an integer as an argument to `concat',\n\
430 you should change it right away not to do so.")
435 return concat (nargs
, args
, Lisp_String
, 0);
438 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
439 "Concatenate all the arguments and make the result a vector.\n\
440 The result is a vector whose elements are the elements of all the arguments.\n\
441 Each argument may be a list, vector or string.")
446 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
449 /* Retrun a copy of a sub char table ARG. The elements except for a
450 nested sub char table are not copied. */
452 copy_sub_char_table (arg
)
455 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
458 /* Copy all the contents. */
459 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
460 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
461 /* Recursively copy any sub char-tables in the ordinary slots. */
462 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
463 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
464 XCHAR_TABLE (copy
)->contents
[i
]
465 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
471 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
472 "Return a copy of a list, vector or string.\n\
473 The elements of a list or vector are not copied; they are shared\n\
478 if (NILP (arg
)) return arg
;
480 if (CHAR_TABLE_P (arg
))
485 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
486 /* Copy all the slots, including the extra ones. */
487 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
488 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
489 * sizeof (Lisp_Object
)));
491 /* Recursively copy any sub char tables in the ordinary slots
492 for multibyte characters. */
493 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
494 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
495 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
496 XCHAR_TABLE (copy
)->contents
[i
]
497 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
502 if (BOOL_VECTOR_P (arg
))
506 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
508 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
509 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
514 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
515 arg
= wrong_type_argument (Qsequencep
, arg
);
516 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
519 /* In string STR of length LEN, see if bytes before STR[I] combine
520 with bytes after STR[I] to form a single character. If so, return
521 the number of bytes after STR[I] which combine in this way.
522 Otherwize, return 0. */
525 count_combining (str
, len
, i
)
529 int j
= i
- 1, bytes
;
531 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
533 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
534 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
536 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
537 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
540 /* This structure holds information of an argument of `concat' that is
541 a string and has text properties to be copied. */
544 int argnum
; /* refer to ARGS (arguments of `concat') */
545 int from
; /* refer to ARGS[argnum] (argument string) */
546 int to
; /* refer to VAL (the target string) */
550 concat (nargs
, args
, target_type
, last_special
)
553 enum Lisp_Type target_type
;
557 register Lisp_Object tail
;
558 register Lisp_Object
this;
561 register int result_len
;
562 register int result_len_byte
;
564 Lisp_Object last_tail
;
567 /* When we make a multibyte string, we can't copy text properties
568 while concatinating each string because the length of resulting
569 string can't be decided until we finish the whole concatination.
570 So, we record strings that have text properties to be copied
571 here, and copy the text properties after the concatination. */
572 struct textprop_rec
*textprops
;
573 /* Number of elments in textprops. */
574 int num_textprops
= 0;
576 /* In append, the last arg isn't treated like the others */
577 if (last_special
&& nargs
> 0)
580 last_tail
= args
[nargs
];
585 /* Canonicalize each argument. */
586 for (argnum
= 0; argnum
< nargs
; argnum
++)
589 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
590 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
593 args
[argnum
] = Fnumber_to_string (this);
595 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
599 /* Compute total length in chars of arguments in RESULT_LEN.
600 If desired output is a string, also compute length in bytes
601 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
602 whether the result should be a multibyte string. */
606 for (argnum
= 0; argnum
< nargs
; argnum
++)
610 len
= XFASTINT (Flength (this));
611 if (target_type
== Lisp_String
)
613 /* We must count the number of bytes needed in the string
614 as well as the number of characters. */
620 for (i
= 0; i
< len
; i
++)
622 ch
= XVECTOR (this)->contents
[i
];
624 wrong_type_argument (Qintegerp
, ch
);
625 this_len_byte
= CHAR_BYTES (XINT (ch
));
626 result_len_byte
+= this_len_byte
;
627 if (this_len_byte
> 1)
630 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
631 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
632 else if (CONSP (this))
633 for (; CONSP (this); this = XCDR (this))
637 wrong_type_argument (Qintegerp
, ch
);
638 this_len_byte
= CHAR_BYTES (XINT (ch
));
639 result_len_byte
+= this_len_byte
;
640 if (this_len_byte
> 1)
643 else if (STRINGP (this))
645 if (STRING_MULTIBYTE (this))
648 result_len_byte
+= STRING_BYTES (XSTRING (this));
651 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
652 XSTRING (this)->size
);
659 if (! some_multibyte
)
660 result_len_byte
= result_len
;
662 /* Create the output object. */
663 if (target_type
== Lisp_Cons
)
664 val
= Fmake_list (make_number (result_len
), Qnil
);
665 else if (target_type
== Lisp_Vectorlike
)
666 val
= Fmake_vector (make_number (result_len
), Qnil
);
667 else if (some_multibyte
)
668 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
670 val
= make_uninit_string (result_len
);
672 /* In `append', if all but last arg are nil, return last arg. */
673 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
676 /* Copy the contents of the args into the result. */
678 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
680 toindex
= 0, toindex_byte
= 0;
685 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
687 for (argnum
= 0; argnum
< nargs
; argnum
++)
691 register unsigned int thisindex
= 0;
692 register unsigned int thisindex_byte
= 0;
696 thislen
= Flength (this), thisleni
= XINT (thislen
);
698 /* Between strings of the same kind, copy fast. */
699 if (STRINGP (this) && STRINGP (val
)
700 && STRING_MULTIBYTE (this) == some_multibyte
)
702 int thislen_byte
= STRING_BYTES (XSTRING (this));
705 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
706 STRING_BYTES (XSTRING (this)));
707 combined
= (some_multibyte
&& toindex_byte
> 0
708 ? count_combining (XSTRING (val
)->data
,
709 toindex_byte
+ thislen_byte
,
712 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
714 textprops
[num_textprops
].argnum
= argnum
;
715 /* We ignore text properties on characters being combined. */
716 textprops
[num_textprops
].from
= combined
;
717 textprops
[num_textprops
++].to
= toindex
;
719 toindex_byte
+= thislen_byte
;
720 toindex
+= thisleni
- combined
;
721 XSTRING (val
)->size
-= combined
;
723 /* Copy a single-byte string to a multibyte string. */
724 else if (STRINGP (this) && STRINGP (val
))
726 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
728 textprops
[num_textprops
].argnum
= argnum
;
729 textprops
[num_textprops
].from
= 0;
730 textprops
[num_textprops
++].to
= toindex
;
732 toindex_byte
+= copy_text (XSTRING (this)->data
,
733 XSTRING (val
)->data
+ toindex_byte
,
734 XSTRING (this)->size
, 0, 1);
738 /* Copy element by element. */
741 register Lisp_Object elt
;
743 /* Fetch next element of `this' arg into `elt', or break if
744 `this' is exhausted. */
745 if (NILP (this)) break;
747 elt
= XCAR (this), this = XCDR (this);
748 else if (thisindex
>= thisleni
)
750 else if (STRINGP (this))
753 if (STRING_MULTIBYTE (this))
755 FETCH_STRING_CHAR_ADVANCE (c
, this,
758 XSETFASTINT (elt
, c
);
762 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
764 && (XINT (elt
) >= 0240
765 || (XINT (elt
) >= 0200
766 && ! NILP (Vnonascii_translation_table
)))
767 && XINT (elt
) < 0400)
769 c
= unibyte_char_to_multibyte (XINT (elt
));
774 else if (BOOL_VECTOR_P (this))
777 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
778 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
785 elt
= XVECTOR (this)->contents
[thisindex
++];
787 /* Store this element into the result. */
794 else if (VECTORP (val
))
795 XVECTOR (val
)->contents
[toindex
++] = elt
;
798 CHECK_NUMBER (elt
, 0);
799 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
801 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
804 && count_combining (XSTRING (val
)->data
,
805 toindex_byte
, toindex_byte
- 1))
806 XSTRING (val
)->size
--;
811 /* If we have any multibyte characters,
812 we already decided to make a multibyte string. */
815 unsigned char work
[4], *str
;
816 int i
= CHAR_STRING (c
, work
, str
);
818 /* P exists as a variable
819 to avoid a bug on the Masscomp C compiler. */
820 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
829 XCDR (prev
) = last_tail
;
831 if (num_textprops
> 0)
833 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
835 this = args
[textprops
[argnum
].argnum
];
836 copy_text_properties (make_number (textprops
[argnum
].from
),
837 XSTRING (this)->size
, this,
838 make_number (textprops
[argnum
].to
), val
, Qnil
);
844 static Lisp_Object string_char_byte_cache_string
;
845 static int string_char_byte_cache_charpos
;
846 static int string_char_byte_cache_bytepos
;
849 clear_string_char_byte_cache ()
851 string_char_byte_cache_string
= Qnil
;
854 /* Return the character index corresponding to CHAR_INDEX in STRING. */
857 string_char_to_byte (string
, char_index
)
862 int best_below
, best_below_byte
;
863 int best_above
, best_above_byte
;
865 if (! STRING_MULTIBYTE (string
))
868 best_below
= best_below_byte
= 0;
869 best_above
= XSTRING (string
)->size
;
870 best_above_byte
= STRING_BYTES (XSTRING (string
));
872 if (EQ (string
, string_char_byte_cache_string
))
874 if (string_char_byte_cache_charpos
< char_index
)
876 best_below
= string_char_byte_cache_charpos
;
877 best_below_byte
= string_char_byte_cache_bytepos
;
881 best_above
= string_char_byte_cache_charpos
;
882 best_above_byte
= string_char_byte_cache_bytepos
;
886 if (char_index
- best_below
< best_above
- char_index
)
888 while (best_below
< char_index
)
891 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
894 i_byte
= best_below_byte
;
898 while (best_above
> char_index
)
900 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
901 unsigned char *pbeg
= pend
- best_above_byte
;
902 unsigned char *p
= pend
- 1;
905 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
906 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
907 if (bytes
== pend
- p
)
908 best_above_byte
-= bytes
;
909 else if (bytes
> pend
- p
)
910 best_above_byte
-= (pend
- p
);
916 i_byte
= best_above_byte
;
919 string_char_byte_cache_bytepos
= i_byte
;
920 string_char_byte_cache_charpos
= i
;
921 string_char_byte_cache_string
= string
;
926 /* Return the character index corresponding to BYTE_INDEX in STRING. */
929 string_byte_to_char (string
, byte_index
)
934 int best_below
, best_below_byte
;
935 int best_above
, best_above_byte
;
937 if (! STRING_MULTIBYTE (string
))
940 best_below
= best_below_byte
= 0;
941 best_above
= XSTRING (string
)->size
;
942 best_above_byte
= STRING_BYTES (XSTRING (string
));
944 if (EQ (string
, string_char_byte_cache_string
))
946 if (string_char_byte_cache_bytepos
< byte_index
)
948 best_below
= string_char_byte_cache_charpos
;
949 best_below_byte
= string_char_byte_cache_bytepos
;
953 best_above
= string_char_byte_cache_charpos
;
954 best_above_byte
= string_char_byte_cache_bytepos
;
958 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
960 while (best_below_byte
< byte_index
)
963 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
966 i_byte
= best_below_byte
;
970 while (best_above_byte
> byte_index
)
972 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
973 unsigned char *pbeg
= pend
- best_above_byte
;
974 unsigned char *p
= pend
- 1;
977 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
978 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
979 if (bytes
== pend
- p
)
980 best_above_byte
-= bytes
;
981 else if (bytes
> pend
- p
)
982 best_above_byte
-= (pend
- p
);
988 i_byte
= best_above_byte
;
991 string_char_byte_cache_bytepos
= i_byte
;
992 string_char_byte_cache_charpos
= i
;
993 string_char_byte_cache_string
= string
;
998 /* Convert STRING to a multibyte string.
999 Single-byte characters 0240 through 0377 are converted
1000 by adding nonascii_insert_offset to each. */
1003 string_make_multibyte (string
)
1009 if (STRING_MULTIBYTE (string
))
1012 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1013 XSTRING (string
)->size
);
1014 /* If all the chars are ASCII, they won't need any more bytes
1015 once converted. In that case, we can return STRING itself. */
1016 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1019 buf
= (unsigned char *) alloca (nbytes
);
1020 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1023 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1026 /* Convert STRING to a single-byte string. */
1029 string_make_unibyte (string
)
1034 if (! STRING_MULTIBYTE (string
))
1037 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1039 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1042 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1045 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1047 "Return the multibyte equivalent of STRING.\n\
1048 The function `unibyte-char-to-multibyte' is used to convert\n\
1049 each unibyte character to a multibyte character.")
1053 CHECK_STRING (string
, 0);
1055 return string_make_multibyte (string
);
1058 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1060 "Return the unibyte equivalent of STRING.\n\
1061 Multibyte character codes are converted to unibyte\n\
1062 by using just the low 8 bits.")
1066 CHECK_STRING (string
, 0);
1068 return string_make_unibyte (string
);
1071 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1073 "Return a unibyte string with the same individual bytes as STRING.\n\
1074 If STRING is unibyte, the result is STRING itself.\n\
1075 Otherwise it is a newly created string, with no text properties.")
1079 CHECK_STRING (string
, 0);
1081 if (STRING_MULTIBYTE (string
))
1083 string
= Fcopy_sequence (string
);
1084 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1085 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1086 SET_STRING_BYTES (XSTRING (string
), -1);
1091 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1093 "Return a multibyte string with the same individual bytes as STRING.\n\
1094 If STRING is multibyte, the result is STRING itself.\n\
1095 Otherwise it is a newly created string, with no text properties.")
1099 CHECK_STRING (string
, 0);
1101 if (! STRING_MULTIBYTE (string
))
1103 int nbytes
= STRING_BYTES (XSTRING (string
));
1104 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1106 string
= Fcopy_sequence (string
);
1107 XSTRING (string
)->size
= newlen
;
1108 XSTRING (string
)->size_byte
= nbytes
;
1109 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1114 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1115 "Return a copy of ALIST.\n\
1116 This is an alist which represents the same mapping from objects to objects,\n\
1117 but does not share the alist structure with ALIST.\n\
1118 The objects mapped (cars and cdrs of elements of the alist)\n\
1119 are shared, however.\n\
1120 Elements of ALIST that are not conses are also shared.")
1124 register Lisp_Object tem
;
1126 CHECK_LIST (alist
, 0);
1129 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1130 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1132 register Lisp_Object car
;
1136 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1141 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1142 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1143 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1144 If FROM or TO is negative, it counts from the end.\n\
1146 This function allows vectors as well as strings.")
1149 register Lisp_Object from
, to
;
1154 int from_char
, to_char
;
1155 int from_byte
, to_byte
;
1157 if (! (STRINGP (string
) || VECTORP (string
)))
1158 wrong_type_argument (Qarrayp
, string
);
1160 CHECK_NUMBER (from
, 1);
1162 if (STRINGP (string
))
1164 size
= XSTRING (string
)->size
;
1165 size_byte
= STRING_BYTES (XSTRING (string
));
1168 size
= XVECTOR (string
)->size
;
1173 to_byte
= size_byte
;
1177 CHECK_NUMBER (to
, 2);
1179 to_char
= XINT (to
);
1183 if (STRINGP (string
))
1184 to_byte
= string_char_to_byte (string
, to_char
);
1187 from_char
= XINT (from
);
1190 if (STRINGP (string
))
1191 from_byte
= string_char_to_byte (string
, from_char
);
1193 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1194 args_out_of_range_3 (string
, make_number (from_char
),
1195 make_number (to_char
));
1197 if (STRINGP (string
))
1199 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1200 to_char
- from_char
, to_byte
- from_byte
,
1201 STRING_MULTIBYTE (string
));
1202 copy_text_properties (make_number (from_char
), make_number (to_char
),
1203 string
, make_number (0), res
, Qnil
);
1206 res
= Fvector (to_char
- from_char
,
1207 XVECTOR (string
)->contents
+ from_char
);
1212 /* Extract a substring of STRING, giving start and end positions
1213 both in characters and in bytes. */
1216 substring_both (string
, from
, from_byte
, to
, to_byte
)
1218 int from
, from_byte
, to
, to_byte
;
1224 if (! (STRINGP (string
) || VECTORP (string
)))
1225 wrong_type_argument (Qarrayp
, string
);
1227 if (STRINGP (string
))
1229 size
= XSTRING (string
)->size
;
1230 size_byte
= STRING_BYTES (XSTRING (string
));
1233 size
= XVECTOR (string
)->size
;
1235 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1236 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1238 if (STRINGP (string
))
1240 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1241 to
- from
, to_byte
- from_byte
,
1242 STRING_MULTIBYTE (string
));
1243 copy_text_properties (make_number (from
), make_number (to
),
1244 string
, make_number (0), res
, Qnil
);
1247 res
= Fvector (to
- from
,
1248 XVECTOR (string
)->contents
+ from
);
1253 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1254 "Take cdr N times on LIST, returns the result.")
1257 register Lisp_Object list
;
1259 register int i
, num
;
1260 CHECK_NUMBER (n
, 0);
1262 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1270 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1271 "Return the Nth element of LIST.\n\
1272 N counts from zero. If LIST is not that long, nil is returned.")
1274 Lisp_Object n
, list
;
1276 return Fcar (Fnthcdr (n
, list
));
1279 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1280 "Return element of SEQUENCE at index N.")
1282 register Lisp_Object sequence
, n
;
1284 CHECK_NUMBER (n
, 0);
1287 if (CONSP (sequence
) || NILP (sequence
))
1288 return Fcar (Fnthcdr (n
, sequence
));
1289 else if (STRINGP (sequence
) || VECTORP (sequence
)
1290 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1291 return Faref (sequence
, n
);
1293 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1297 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1298 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1299 The value is actually the tail of LIST whose car is ELT.")
1301 register Lisp_Object elt
;
1304 register Lisp_Object tail
;
1305 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1307 register Lisp_Object tem
;
1309 if (! NILP (Fequal (elt
, tem
)))
1316 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1317 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1318 The value is actually the tail of LIST whose car is ELT.")
1320 register Lisp_Object elt
;
1323 register Lisp_Object tail
;
1324 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1326 register Lisp_Object tem
;
1328 if (EQ (elt
, tem
)) return tail
;
1334 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1335 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1336 The value is actually the element of LIST whose car is KEY.\n\
1337 Elements of LIST that are not conses are ignored.")
1339 register Lisp_Object key
;
1342 register Lisp_Object tail
;
1343 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1345 register Lisp_Object elt
, tem
;
1347 if (!CONSP (elt
)) continue;
1349 if (EQ (key
, tem
)) return elt
;
1355 /* Like Fassq but never report an error and do not allow quits.
1356 Use only on lists known never to be circular. */
1359 assq_no_quit (key
, list
)
1360 register Lisp_Object key
;
1363 register Lisp_Object tail
;
1364 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1366 register Lisp_Object elt
, tem
;
1368 if (!CONSP (elt
)) continue;
1370 if (EQ (key
, tem
)) return elt
;
1375 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1376 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1377 The value is actually the element of LIST whose car equals KEY.")
1379 register Lisp_Object key
;
1382 register Lisp_Object tail
;
1383 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1385 register Lisp_Object elt
, tem
;
1387 if (!CONSP (elt
)) continue;
1388 tem
= Fequal (XCAR (elt
), key
);
1389 if (!NILP (tem
)) return elt
;
1395 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1396 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1397 The value is actually the element of LIST whose cdr is ELT.")
1399 register Lisp_Object key
;
1402 register Lisp_Object tail
;
1403 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1405 register Lisp_Object elt
, tem
;
1407 if (!CONSP (elt
)) continue;
1409 if (EQ (key
, tem
)) return elt
;
1415 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1416 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1417 The value is actually the element of LIST whose cdr equals KEY.")
1419 register Lisp_Object key
;
1422 register Lisp_Object tail
;
1423 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1425 register Lisp_Object elt
, tem
;
1427 if (!CONSP (elt
)) continue;
1428 tem
= Fequal (XCDR (elt
), key
);
1429 if (!NILP (tem
)) return elt
;
1435 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1436 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1437 The modified LIST is returned. Comparison is done with `eq'.\n\
1438 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1439 therefore, write `(setq foo (delq element foo))'\n\
1440 to be sure of changing the value of `foo'.")
1442 register Lisp_Object elt
;
1445 register Lisp_Object tail
, prev
;
1446 register Lisp_Object tem
;
1450 while (!NILP (tail
))
1458 Fsetcdr (prev
, XCDR (tail
));
1468 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1469 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1470 The modified LIST is returned. Comparison is done with `equal'.\n\
1471 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1472 it is simply using a different list.\n\
1473 Therefore, write `(setq foo (delete element foo))'\n\
1474 to be sure of changing the value of `foo'.")
1476 register Lisp_Object elt
;
1479 register Lisp_Object tail
, prev
;
1480 register Lisp_Object tem
;
1484 while (!NILP (tail
))
1487 if (! NILP (Fequal (elt
, tem
)))
1492 Fsetcdr (prev
, XCDR (tail
));
1502 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1503 "Reverse LIST by modifying cdr pointers.\n\
1504 Returns the beginning of the reversed list.")
1508 register Lisp_Object prev
, tail
, next
;
1510 if (NILP (list
)) return list
;
1513 while (!NILP (tail
))
1517 Fsetcdr (tail
, prev
);
1524 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1525 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1526 See also the function `nreverse', which is used more often.")
1532 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1533 new = Fcons (XCAR (list
), new);
1535 wrong_type_argument (Qconsp
, list
);
1539 Lisp_Object
merge ();
1541 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1542 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1543 Returns the sorted list. LIST is modified by side effects.\n\
1544 PREDICATE is called with two elements of LIST, and should return T\n\
1545 if the first element is \"less\" than the second.")
1547 Lisp_Object list
, predicate
;
1549 Lisp_Object front
, back
;
1550 register Lisp_Object len
, tem
;
1551 struct gcpro gcpro1
, gcpro2
;
1552 register int length
;
1555 len
= Flength (list
);
1556 length
= XINT (len
);
1560 XSETINT (len
, (length
/ 2) - 1);
1561 tem
= Fnthcdr (len
, list
);
1563 Fsetcdr (tem
, Qnil
);
1565 GCPRO2 (front
, back
);
1566 front
= Fsort (front
, predicate
);
1567 back
= Fsort (back
, predicate
);
1569 return merge (front
, back
, predicate
);
1573 merge (org_l1
, org_l2
, pred
)
1574 Lisp_Object org_l1
, org_l2
;
1578 register Lisp_Object tail
;
1580 register Lisp_Object l1
, l2
;
1581 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1588 /* It is sufficient to protect org_l1 and org_l2.
1589 When l1 and l2 are updated, we copy the new values
1590 back into the org_ vars. */
1591 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1611 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1627 Fsetcdr (tail
, tem
);
1633 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1634 "Extract a value from a property list.\n\
1635 PLIST is a property list, which is a list of the form\n\
1636 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1637 corresponding to the given PROP, or nil if PROP is not\n\
1638 one of the properties on the list.")
1641 register Lisp_Object prop
;
1643 register Lisp_Object tail
;
1644 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1646 register Lisp_Object tem
;
1649 return Fcar (XCDR (tail
));
1654 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1655 "Return the value of SYMBOL's PROPNAME property.\n\
1656 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1658 Lisp_Object symbol
, propname
;
1660 CHECK_SYMBOL (symbol
, 0);
1661 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1664 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1665 "Change value in PLIST of PROP to VAL.\n\
1666 PLIST is a property list, which is a list of the form\n\
1667 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1668 If PROP is already a property on the list, its value is set to VAL,\n\
1669 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1670 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1671 The PLIST is modified by side effects.")
1674 register Lisp_Object prop
;
1677 register Lisp_Object tail
, prev
;
1678 Lisp_Object newcell
;
1680 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1681 tail
= XCDR (XCDR (tail
)))
1683 if (EQ (prop
, XCAR (tail
)))
1685 Fsetcar (XCDR (tail
), val
);
1690 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1694 Fsetcdr (XCDR (prev
), newcell
);
1698 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1699 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1700 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1701 (symbol
, propname
, value
)
1702 Lisp_Object symbol
, propname
, value
;
1704 CHECK_SYMBOL (symbol
, 0);
1705 XSYMBOL (symbol
)->plist
1706 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1710 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1711 "Return t if two Lisp objects have similar structure and contents.\n\
1712 They must have the same data type.\n\
1713 Conses are compared by comparing the cars and the cdrs.\n\
1714 Vectors and strings are compared element by element.\n\
1715 Numbers are compared by value, but integers cannot equal floats.\n\
1716 (Use `=' if you want integers and floats to be able to be equal.)\n\
1717 Symbols must match exactly.")
1719 register Lisp_Object o1
, o2
;
1721 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1725 internal_equal (o1
, o2
, depth
)
1726 register Lisp_Object o1
, o2
;
1730 error ("Stack overflow in equal");
1736 if (XTYPE (o1
) != XTYPE (o2
))
1741 #ifdef LISP_FLOAT_TYPE
1743 return (extract_float (o1
) == extract_float (o2
));
1747 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1754 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1758 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1760 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1763 o1
= XOVERLAY (o1
)->plist
;
1764 o2
= XOVERLAY (o2
)->plist
;
1769 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1770 && (XMARKER (o1
)->buffer
== 0
1771 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1775 case Lisp_Vectorlike
:
1777 register int i
, size
;
1778 size
= XVECTOR (o1
)->size
;
1779 /* Pseudovectors have the type encoded in the size field, so this test
1780 actually checks that the objects have the same type as well as the
1782 if (XVECTOR (o2
)->size
!= size
)
1784 /* Boolvectors are compared much like strings. */
1785 if (BOOL_VECTOR_P (o1
))
1788 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1790 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1792 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1797 if (WINDOW_CONFIGURATIONP (o1
))
1798 return compare_window_configurations (o1
, o2
, 0);
1800 /* Aside from them, only true vectors, char-tables, and compiled
1801 functions are sensible to compare, so eliminate the others now. */
1802 if (size
& PSEUDOVECTOR_FLAG
)
1804 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1806 size
&= PSEUDOVECTOR_SIZE_MASK
;
1808 for (i
= 0; i
< size
; i
++)
1811 v1
= XVECTOR (o1
)->contents
[i
];
1812 v2
= XVECTOR (o2
)->contents
[i
];
1813 if (!internal_equal (v1
, v2
, depth
+ 1))
1821 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1823 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1825 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1826 STRING_BYTES (XSTRING (o1
))))
1833 extern Lisp_Object
Fmake_char_internal ();
1835 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1836 "Store each element of ARRAY with ITEM.\n\
1837 ARRAY is a vector, string, char-table, or bool-vector.")
1839 Lisp_Object array
, item
;
1841 register int size
, index
, charval
;
1843 if (VECTORP (array
))
1845 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1846 size
= XVECTOR (array
)->size
;
1847 for (index
= 0; index
< size
; index
++)
1850 else if (CHAR_TABLE_P (array
))
1852 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1853 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1854 for (index
= 0; index
< size
; index
++)
1856 XCHAR_TABLE (array
)->defalt
= Qnil
;
1858 else if (STRINGP (array
))
1860 register unsigned char *p
= XSTRING (array
)->data
;
1861 CHECK_NUMBER (item
, 1);
1862 charval
= XINT (item
);
1863 size
= XSTRING (array
)->size
;
1864 if (STRING_MULTIBYTE (array
))
1866 unsigned char workbuf
[4], *str
;
1867 int len
= CHAR_STRING (charval
, workbuf
, str
);
1868 int size_byte
= STRING_BYTES (XSTRING (array
));
1869 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1872 if (size
!= size_byte
)
1875 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1876 if (len
!= this_len
)
1877 error ("Attempt to change byte length of a string");
1880 for (i
= 0; i
< size_byte
; i
++)
1881 *p
++ = str
[i
% len
];
1884 for (index
= 0; index
< size
; index
++)
1887 else if (BOOL_VECTOR_P (array
))
1889 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1891 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1893 charval
= (! NILP (item
) ? -1 : 0);
1894 for (index
= 0; index
< size_in_chars
; index
++)
1899 array
= wrong_type_argument (Qarrayp
, array
);
1905 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1907 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1909 Lisp_Object char_table
;
1911 CHECK_CHAR_TABLE (char_table
, 0);
1913 return XCHAR_TABLE (char_table
)->purpose
;
1916 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1918 "Return the parent char-table of CHAR-TABLE.\n\
1919 The value is either nil or another char-table.\n\
1920 If CHAR-TABLE holds nil for a given character,\n\
1921 then the actual applicable value is inherited from the parent char-table\n\
1922 \(or from its parents, if necessary).")
1924 Lisp_Object char_table
;
1926 CHECK_CHAR_TABLE (char_table
, 0);
1928 return XCHAR_TABLE (char_table
)->parent
;
1931 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1933 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1934 PARENT must be either nil or another char-table.")
1935 (char_table
, parent
)
1936 Lisp_Object char_table
, parent
;
1940 CHECK_CHAR_TABLE (char_table
, 0);
1944 CHECK_CHAR_TABLE (parent
, 0);
1946 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1947 if (EQ (temp
, char_table
))
1948 error ("Attempt to make a chartable be its own parent");
1951 XCHAR_TABLE (char_table
)->parent
= parent
;
1956 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1958 "Return the value of CHAR-TABLE's extra-slot number N.")
1960 Lisp_Object char_table
, n
;
1962 CHECK_CHAR_TABLE (char_table
, 1);
1963 CHECK_NUMBER (n
, 2);
1965 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1966 args_out_of_range (char_table
, n
);
1968 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1971 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1972 Sset_char_table_extra_slot
,
1974 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1975 (char_table
, n
, value
)
1976 Lisp_Object char_table
, n
, value
;
1978 CHECK_CHAR_TABLE (char_table
, 1);
1979 CHECK_NUMBER (n
, 2);
1981 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1982 args_out_of_range (char_table
, n
);
1984 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1987 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1989 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1990 RANGE should be nil (for the default value)\n\
1991 a vector which identifies a character set or a row of a character set,\n\
1992 a character set name, or a character code.")
1994 Lisp_Object char_table
, range
;
1998 CHECK_CHAR_TABLE (char_table
, 0);
2000 if (EQ (range
, Qnil
))
2001 return XCHAR_TABLE (char_table
)->defalt
;
2002 else if (INTEGERP (range
))
2003 return Faref (char_table
, range
);
2004 else if (SYMBOLP (range
))
2006 Lisp_Object charset_info
;
2008 charset_info
= Fget (range
, Qcharset
);
2009 CHECK_VECTOR (charset_info
, 0);
2011 return Faref (char_table
,
2012 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2015 else if (VECTORP (range
))
2017 if (XVECTOR (range
)->size
== 1)
2018 return Faref (char_table
,
2019 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2022 int size
= XVECTOR (range
)->size
;
2023 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2024 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2025 size
<= 1 ? Qnil
: val
[1],
2026 size
<= 2 ? Qnil
: val
[2]);
2027 return Faref (char_table
, ch
);
2031 error ("Invalid RANGE argument to `char-table-range'");
2034 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2036 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2037 RANGE should be t (for all characters), nil (for the default value)\n\
2038 a vector which identifies a character set or a row of a character set,\n\
2039 a coding system, or a character code.")
2040 (char_table
, range
, value
)
2041 Lisp_Object char_table
, range
, value
;
2045 CHECK_CHAR_TABLE (char_table
, 0);
2048 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2049 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2050 else if (EQ (range
, Qnil
))
2051 XCHAR_TABLE (char_table
)->defalt
= value
;
2052 else if (SYMBOLP (range
))
2054 Lisp_Object charset_info
;
2056 charset_info
= Fget (range
, Qcharset
);
2057 CHECK_VECTOR (charset_info
, 0);
2059 return Faset (char_table
,
2060 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2064 else if (INTEGERP (range
))
2065 Faset (char_table
, range
, value
);
2066 else if (VECTORP (range
))
2068 if (XVECTOR (range
)->size
== 1)
2069 return Faset (char_table
,
2070 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2074 int size
= XVECTOR (range
)->size
;
2075 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2076 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2077 size
<= 1 ? Qnil
: val
[1],
2078 size
<= 2 ? Qnil
: val
[2]);
2079 return Faset (char_table
, ch
, value
);
2083 error ("Invalid RANGE argument to `set-char-table-range'");
2088 DEFUN ("set-char-table-default", Fset_char_table_default
,
2089 Sset_char_table_default
, 3, 3, 0,
2090 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2091 The generic character specifies the group of characters.\n\
2092 See also the documentation of make-char.")
2093 (char_table
, ch
, value
)
2094 Lisp_Object char_table
, ch
, value
;
2096 int c
, i
, charset
, code1
, code2
;
2099 CHECK_CHAR_TABLE (char_table
, 0);
2100 CHECK_NUMBER (ch
, 1);
2103 SPLIT_CHAR (c
, charset
, code1
, code2
);
2105 /* Since we may want to set the default value for a character set
2106 not yet defined, we check only if the character set is in the
2107 valid range or not, instead of it is already defined or not. */
2108 if (! CHARSET_VALID_P (charset
))
2109 invalid_character (c
);
2111 if (charset
== CHARSET_ASCII
)
2112 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2114 /* Even if C is not a generic char, we had better behave as if a
2115 generic char is specified. */
2116 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2118 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2121 if (SUB_CHAR_TABLE_P (temp
))
2122 XCHAR_TABLE (temp
)->defalt
= value
;
2124 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2128 if (! SUB_CHAR_TABLE_P (char_table
))
2129 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2130 = make_sub_char_table (temp
));
2131 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2132 if (SUB_CHAR_TABLE_P (temp
))
2133 XCHAR_TABLE (temp
)->defalt
= value
;
2135 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2139 /* Look up the element in TABLE at index CH,
2140 and return it as an integer.
2141 If the element is nil, return CH itself.
2142 (Actually we do that for any non-integer.) */
2145 char_table_translate (table
, ch
)
2150 value
= Faref (table
, make_number (ch
));
2151 if (! INTEGERP (value
))
2153 return XINT (value
);
2156 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2157 character or group of characters that share a value.
2158 DEPTH is the current depth in the originally specified
2159 chartable, and INDICES contains the vector indices
2160 for the levels our callers have descended.
2162 ARG is passed to C_FUNCTION when that is called. */
2165 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2166 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2167 Lisp_Object function
, subtable
, arg
, *indices
;
2174 /* At first, handle ASCII and 8-bit European characters. */
2175 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2177 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2179 (*c_function
) (arg
, make_number (i
), elt
);
2181 call2 (function
, make_number (i
), elt
);
2183 #if 0 /* If the char table has entries for higher characters,
2184 we should report them. */
2185 if (NILP (current_buffer
->enable_multibyte_characters
))
2188 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2193 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2198 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2200 XSETFASTINT (indices
[depth
], i
);
2202 if (SUB_CHAR_TABLE_P (elt
))
2205 error ("Too deep char table");
2206 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2210 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2212 if (CHARSET_DEFINED_P (charset
))
2214 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2215 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2216 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2218 (*c_function
) (arg
, make_number (c
), elt
);
2220 call2 (function
, make_number (c
), elt
);
2226 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2228 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2229 FUNCTION is called with two arguments--a key and a value.\n\
2230 The key is always a possible IDX argument to `aref'.")
2231 (function
, char_table
)
2232 Lisp_Object function
, char_table
;
2234 /* The depth of char table is at most 3. */
2235 Lisp_Object indices
[3];
2237 CHECK_CHAR_TABLE (char_table
, 1);
2239 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2249 Lisp_Object args
[2];
2252 return Fnconc (2, args
);
2254 return Fnconc (2, &s1
);
2255 #endif /* NO_ARG_ARRAY */
2258 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2259 "Concatenate any number of lists by altering them.\n\
2260 Only the last argument is not altered, and need not be a list.")
2265 register int argnum
;
2266 register Lisp_Object tail
, tem
, val
;
2270 for (argnum
= 0; argnum
< nargs
; argnum
++)
2273 if (NILP (tem
)) continue;
2278 if (argnum
+ 1 == nargs
) break;
2281 tem
= wrong_type_argument (Qlistp
, tem
);
2290 tem
= args
[argnum
+ 1];
2291 Fsetcdr (tail
, tem
);
2293 args
[argnum
+ 1] = tail
;
2299 /* This is the guts of all mapping functions.
2300 Apply FN to each element of SEQ, one by one,
2301 storing the results into elements of VALS, a C vector of Lisp_Objects.
2302 LENI is the length of VALS, which should also be the length of SEQ. */
2305 mapcar1 (leni
, vals
, fn
, seq
)
2308 Lisp_Object fn
, seq
;
2310 register Lisp_Object tail
;
2313 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2315 /* Don't let vals contain any garbage when GC happens. */
2316 for (i
= 0; i
< leni
; i
++)
2319 GCPRO3 (dummy
, fn
, seq
);
2321 gcpro1
.nvars
= leni
;
2322 /* We need not explicitly protect `tail' because it is used only on lists, and
2323 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2327 for (i
= 0; i
< leni
; i
++)
2329 dummy
= XVECTOR (seq
)->contents
[i
];
2330 vals
[i
] = call1 (fn
, dummy
);
2333 else if (BOOL_VECTOR_P (seq
))
2335 for (i
= 0; i
< leni
; i
++)
2338 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2339 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2344 vals
[i
] = call1 (fn
, dummy
);
2347 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2349 /* Single-byte string. */
2350 for (i
= 0; i
< leni
; i
++)
2352 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2353 vals
[i
] = call1 (fn
, dummy
);
2356 else if (STRINGP (seq
))
2358 /* Multi-byte string. */
2359 int len_byte
= STRING_BYTES (XSTRING (seq
));
2362 for (i
= 0, i_byte
= 0; i
< leni
;)
2367 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2368 XSETFASTINT (dummy
, c
);
2369 vals
[i_before
] = call1 (fn
, dummy
);
2372 else /* Must be a list, since Flength did not get an error */
2375 for (i
= 0; i
< leni
; i
++)
2377 vals
[i
] = call1 (fn
, Fcar (tail
));
2385 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2386 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2387 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2388 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2389 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2390 (function
, sequence
, separator
)
2391 Lisp_Object function
, sequence
, separator
;
2396 register Lisp_Object
*args
;
2398 struct gcpro gcpro1
;
2400 len
= Flength (sequence
);
2402 nargs
= leni
+ leni
- 1;
2403 if (nargs
< 0) return build_string ("");
2405 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2408 mapcar1 (leni
, args
, function
, sequence
);
2411 for (i
= leni
- 1; i
>= 0; i
--)
2412 args
[i
+ i
] = args
[i
];
2414 for (i
= 1; i
< nargs
; i
+= 2)
2415 args
[i
] = separator
;
2417 return Fconcat (nargs
, args
);
2420 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2421 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2422 The result is a list just as long as SEQUENCE.\n\
2423 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2424 (function
, sequence
)
2425 Lisp_Object function
, sequence
;
2427 register Lisp_Object len
;
2429 register Lisp_Object
*args
;
2431 len
= Flength (sequence
);
2432 leni
= XFASTINT (len
);
2433 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2435 mapcar1 (leni
, args
, function
, sequence
);
2437 return Flist (leni
, args
);
2440 /* Anything that calls this function must protect from GC! */
2442 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2443 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2444 Takes one argument, which is the string to display to ask the question.\n\
2445 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2446 No confirmation of the answer is requested; a single character is enough.\n\
2447 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2448 the bindings in query-replace-map; see the documentation of that variable\n\
2449 for more information. In this case, the useful bindings are `act', `skip',\n\
2450 `recenter', and `quit'.\)\n\
2452 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2457 register Lisp_Object obj
, key
, def
, map
;
2458 register int answer
;
2459 Lisp_Object xprompt
;
2460 Lisp_Object args
[2];
2461 struct gcpro gcpro1
, gcpro2
;
2462 int count
= specpdl_ptr
- specpdl
;
2464 specbind (Qcursor_in_echo_area
, Qt
);
2466 map
= Fsymbol_value (intern ("query-replace-map"));
2468 CHECK_STRING (prompt
, 0);
2470 GCPRO2 (prompt
, xprompt
);
2476 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2480 Lisp_Object pane
, menu
;
2481 redisplay_preserve_echo_area ();
2482 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2483 Fcons (Fcons (build_string ("No"), Qnil
),
2485 menu
= Fcons (prompt
, pane
);
2486 obj
= Fx_popup_dialog (Qt
, menu
);
2487 answer
= !NILP (obj
);
2490 #endif /* HAVE_MENUS */
2491 cursor_in_echo_area
= 1;
2492 choose_minibuf_frame ();
2493 message_with_string ("%s(y or n) ", xprompt
, 0);
2495 if (minibuffer_auto_raise
)
2497 Lisp_Object mini_frame
;
2499 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2501 Fraise_frame (mini_frame
);
2504 obj
= read_filtered_event (1, 0, 0, 0);
2505 cursor_in_echo_area
= 0;
2506 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2509 key
= Fmake_vector (make_number (1), obj
);
2510 def
= Flookup_key (map
, key
, Qt
);
2512 if (EQ (def
, intern ("skip")))
2517 else if (EQ (def
, intern ("act")))
2522 else if (EQ (def
, intern ("recenter")))
2528 else if (EQ (def
, intern ("quit")))
2530 /* We want to exit this command for exit-prefix,
2531 and this is the only way to do it. */
2532 else if (EQ (def
, intern ("exit-prefix")))
2537 /* If we don't clear this, then the next call to read_char will
2538 return quit_char again, and we'll enter an infinite loop. */
2543 if (EQ (xprompt
, prompt
))
2545 args
[0] = build_string ("Please answer y or n. ");
2547 xprompt
= Fconcat (2, args
);
2552 if (! noninteractive
)
2554 cursor_in_echo_area
= -1;
2555 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2559 unbind_to (count
, Qnil
);
2560 return answer
? Qt
: Qnil
;
2563 /* This is how C code calls `yes-or-no-p' and allows the user
2566 Anything that calls this function must protect from GC! */
2569 do_yes_or_no_p (prompt
)
2572 return call1 (intern ("yes-or-no-p"), prompt
);
2575 /* Anything that calls this function must protect from GC! */
2577 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2578 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2579 Takes one argument, which is the string to display to ask the question.\n\
2580 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2581 The user must confirm the answer with RET,\n\
2582 and can edit it until it has been confirmed.\n\
2584 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2589 register Lisp_Object ans
;
2590 Lisp_Object args
[2];
2591 struct gcpro gcpro1
;
2594 CHECK_STRING (prompt
, 0);
2597 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2601 Lisp_Object pane
, menu
, obj
;
2602 redisplay_preserve_echo_area ();
2603 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2604 Fcons (Fcons (build_string ("No"), Qnil
),
2607 menu
= Fcons (prompt
, pane
);
2608 obj
= Fx_popup_dialog (Qt
, menu
);
2612 #endif /* HAVE_MENUS */
2615 args
[1] = build_string ("(yes or no) ");
2616 prompt
= Fconcat (2, args
);
2622 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2623 Qyes_or_no_p_history
, Qnil
,
2625 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2630 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2638 message ("Please answer yes or no.");
2639 Fsleep_for (make_number (2), Qnil
);
2643 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2644 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2645 Each of the three load averages is multiplied by 100,\n\
2646 then converted to integer.\n\
2647 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2648 These floats are not multiplied by 100.\n\n\
2649 If the 5-minute or 15-minute load averages are not available, return a\n\
2650 shortened list, containing only those averages which are available.")
2652 Lisp_Object use_floats
;
2655 int loads
= getloadavg (load_ave
, 3);
2656 Lisp_Object ret
= Qnil
;
2659 error ("load-average not implemented for this operating system");
2663 Lisp_Object load
= (NILP (use_floats
) ?
2664 make_number ((int) (100.0 * load_ave
[loads
]))
2665 : make_float (load_ave
[loads
]));
2666 ret
= Fcons (load
, ret
);
2672 Lisp_Object Vfeatures
;
2674 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2675 "Returns t if FEATURE is present in this Emacs.\n\
2676 Use this to conditionalize execution of lisp code based on the presence or\n\
2677 absence of emacs or environment extensions.\n\
2678 Use `provide' to declare that a feature is available.\n\
2679 This function looks at the value of the variable `features'.")
2681 Lisp_Object feature
;
2683 register Lisp_Object tem
;
2684 CHECK_SYMBOL (feature
, 0);
2685 tem
= Fmemq (feature
, Vfeatures
);
2686 return (NILP (tem
)) ? Qnil
: Qt
;
2689 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2690 "Announce that FEATURE is a feature of the current Emacs.")
2692 Lisp_Object feature
;
2694 register Lisp_Object tem
;
2695 CHECK_SYMBOL (feature
, 0);
2696 if (!NILP (Vautoload_queue
))
2697 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2698 tem
= Fmemq (feature
, Vfeatures
);
2700 Vfeatures
= Fcons (feature
, Vfeatures
);
2701 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2705 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2706 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2707 If FEATURE is not a member of the list `features', then the feature\n\
2708 is not loaded; so load the file FILENAME.\n\
2709 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2710 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2711 If the optional third argument NOERROR is non-nil,\n\
2712 then return nil if the file is not found.\n\
2713 Normally the return value is FEATURE.")
2714 (feature
, file_name
, noerror
)
2715 Lisp_Object feature
, file_name
, noerror
;
2717 register Lisp_Object tem
;
2718 CHECK_SYMBOL (feature
, 0);
2719 tem
= Fmemq (feature
, Vfeatures
);
2720 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2723 int count
= specpdl_ptr
- specpdl
;
2725 /* Value saved here is to be restored into Vautoload_queue */
2726 record_unwind_protect (un_autoload
, Vautoload_queue
);
2727 Vautoload_queue
= Qt
;
2729 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2730 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2731 /* If load failed entirely, return nil. */
2733 return unbind_to (count
, Qnil
);
2735 tem
= Fmemq (feature
, Vfeatures
);
2737 error ("Required feature %s was not provided",
2738 XSYMBOL (feature
)->name
->data
);
2740 /* Once loading finishes, don't undo it. */
2741 Vautoload_queue
= Qt
;
2742 feature
= unbind_to (count
, feature
);
2747 /* Primitives for work of the "widget" library.
2748 In an ideal world, this section would not have been necessary.
2749 However, lisp function calls being as slow as they are, it turns
2750 out that some functions in the widget library (wid-edit.el) are the
2751 bottleneck of Widget operation. Here is their translation to C,
2752 for the sole reason of efficiency. */
2754 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2755 "Return non-nil if PLIST has the property PROP.\n\
2756 PLIST is a property list, which is a list of the form\n\
2757 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2758 Unlike `plist-get', this allows you to distinguish between a missing\n\
2759 property and a property with the value nil.\n\
2760 The value is actually the tail of PLIST whose car is PROP.")
2762 Lisp_Object plist
, prop
;
2764 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2767 plist
= XCDR (plist
);
2768 plist
= CDR (plist
);
2773 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2774 "In WIDGET, set PROPERTY to VALUE.\n\
2775 The value can later be retrieved with `widget-get'.")
2776 (widget
, property
, value
)
2777 Lisp_Object widget
, property
, value
;
2779 CHECK_CONS (widget
, 1);
2780 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2784 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2785 "In WIDGET, get the value of PROPERTY.\n\
2786 The value could either be specified when the widget was created, or\n\
2787 later with `widget-put'.")
2789 Lisp_Object widget
, property
;
2797 CHECK_CONS (widget
, 1);
2798 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2804 tmp
= XCAR (widget
);
2807 widget
= Fget (tmp
, Qwidget_type
);
2811 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2812 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2813 ARGS are passed as extra arguments to the function.")
2818 /* This function can GC. */
2819 Lisp_Object newargs
[3];
2820 struct gcpro gcpro1
, gcpro2
;
2823 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2824 newargs
[1] = args
[0];
2825 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2826 GCPRO2 (newargs
[0], newargs
[2]);
2827 result
= Fapply (3, newargs
);
2832 /* base64 encode/decode functions.
2833 Based on code from GNU recode. */
2835 #define MIME_LINE_LENGTH 76
2837 #define IS_ASCII(Character) \
2839 #define IS_BASE64(Character) \
2840 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2841 #define IS_BASE64_IGNORABLE(Character) \
2842 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2843 || (Character) == '\f' || (Character) == '\r')
2845 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2846 character or return retval if there are no characters left to
2848 #define READ_QUADRUPLET_BYTE(retval) \
2855 while (IS_BASE64_IGNORABLE (c))
2857 /* Don't use alloca for regions larger than this, lest we overflow
2859 #define MAX_ALLOCA 16*1024
2861 /* Table of characters coding the 64 values. */
2862 static char base64_value_to_char
[64] =
2864 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2865 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2866 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2867 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2868 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2869 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2870 '8', '9', '+', '/' /* 60-63 */
2873 /* Table of base64 values for first 128 characters. */
2874 static short base64_char_to_value
[128] =
2876 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2877 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2878 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2879 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2880 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2881 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2882 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2883 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2884 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2885 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2886 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2887 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2888 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2891 /* The following diagram shows the logical steps by which three octets
2892 get transformed into four base64 characters.
2894 .--------. .--------. .--------.
2895 |aaaaaabb| |bbbbcccc| |ccdddddd|
2896 `--------' `--------' `--------'
2898 .--------+--------+--------+--------.
2899 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2900 `--------+--------+--------+--------'
2902 .--------+--------+--------+--------.
2903 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2904 `--------+--------+--------+--------'
2906 The octets are divided into 6 bit chunks, which are then encoded into
2907 base64 characters. */
2910 static int base64_encode_1
P_ ((const char *, char *, int, int));
2911 static int base64_decode_1
P_ ((const char *, char *, int));
2913 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2915 "Base64-encode the region between BEG and END.\n\
2916 Return the length of the encoded text.\n\
2917 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2918 into shorter lines.")
2919 (beg
, end
, no_line_break
)
2920 Lisp_Object beg
, end
, no_line_break
;
2923 int allength
, length
;
2924 int ibeg
, iend
, encoded_length
;
2927 validate_region (&beg
, &end
);
2929 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2930 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2931 move_gap_both (XFASTINT (beg
), ibeg
);
2933 /* We need to allocate enough room for encoding the text.
2934 We need 33 1/3% more space, plus a newline every 76
2935 characters, and then we round up. */
2936 length
= iend
- ibeg
;
2937 allength
= length
+ length
/3 + 1;
2938 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2940 if (allength
<= MAX_ALLOCA
)
2941 encoded
= (char *) alloca (allength
);
2943 encoded
= (char *) xmalloc (allength
);
2944 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2945 NILP (no_line_break
));
2946 if (encoded_length
> allength
)
2949 /* Now we have encoded the region, so we insert the new contents
2950 and delete the old. (Insert first in order to preserve markers.) */
2951 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2952 insert (encoded
, encoded_length
);
2953 if (allength
> MAX_ALLOCA
)
2955 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2957 /* If point was outside of the region, restore it exactly; else just
2958 move to the beginning of the region. */
2959 if (old_pos
>= XFASTINT (end
))
2960 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2961 else if (old_pos
> XFASTINT (beg
))
2962 old_pos
= XFASTINT (beg
);
2965 /* We return the length of the encoded text. */
2966 return make_number (encoded_length
);
2969 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2971 "Base64-encode STRING and return the result.\n\
2972 Optional second argument NO-LINE-BREAK means do not break long lines\n\
2973 into shorter lines.")
2974 (string
, no_line_break
)
2975 Lisp_Object string
, no_line_break
;
2977 int allength
, length
, encoded_length
;
2979 Lisp_Object encoded_string
;
2981 CHECK_STRING (string
, 1);
2983 /* We need to allocate enough room for encoding the text.
2984 We need 33 1/3% more space, plus a newline every 76
2985 characters, and then we round up. */
2986 length
= STRING_BYTES (XSTRING (string
));
2987 allength
= length
+ length
/3 + 1;
2988 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2990 /* We need to allocate enough room for decoding the text. */
2991 if (allength
<= MAX_ALLOCA
)
2992 encoded
= (char *) alloca (allength
);
2994 encoded
= (char *) xmalloc (allength
);
2996 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2997 encoded
, length
, NILP (no_line_break
));
2998 if (encoded_length
> allength
)
3001 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3002 if (allength
> MAX_ALLOCA
)
3005 return encoded_string
;
3009 base64_encode_1 (from
, to
, length
, line_break
)
3015 int counter
= 0, i
= 0;
3024 /* Wrap line every 76 characters. */
3028 if (counter
< MIME_LINE_LENGTH
/ 4)
3037 /* Process first byte of a triplet. */
3039 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3040 value
= (0x03 & c
) << 4;
3042 /* Process second byte of a triplet. */
3046 *e
++ = base64_value_to_char
[value
];
3054 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3055 value
= (0x0f & c
) << 2;
3057 /* Process third byte of a triplet. */
3061 *e
++ = base64_value_to_char
[value
];
3068 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3069 *e
++ = base64_value_to_char
[0x3f & c
];
3076 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3078 "Base64-decode the region between BEG and END.\n\
3079 Return the length of the decoded text.\n\
3080 If the region can't be decoded, return nil and don't modify the buffer.")
3082 Lisp_Object beg
, end
;
3084 int ibeg
, iend
, length
;
3090 validate_region (&beg
, &end
);
3092 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3093 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3095 length
= iend
- ibeg
;
3096 /* We need to allocate enough room for decoding the text. */
3097 if (length
<= MAX_ALLOCA
)
3098 decoded
= (char *) alloca (length
);
3100 decoded
= (char *) xmalloc (length
);
3102 move_gap_both (XFASTINT (beg
), ibeg
);
3103 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3104 if (decoded_length
> length
)
3107 if (decoded_length
< 0)
3109 /* The decoding wasn't possible. */
3110 if (length
> MAX_ALLOCA
)
3115 /* Now we have decoded the region, so we insert the new contents
3116 and delete the old. (Insert first in order to preserve markers.) */
3117 /* We insert two spaces, then insert the decoded text in between
3118 them, at last, delete those extra two spaces. This is to avoid
3119 byte combining while inserting. */
3120 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3121 insert_1_both (" ", 2, 2, 0, 1, 0);
3122 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3123 insert (decoded
, decoded_length
);
3124 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3125 if (length
> MAX_ALLOCA
)
3127 /* At first delete the original text. This never cause byte
3129 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3130 iend
+ decoded_length
+ 2, 1);
3131 /* Next delete the extra spaces. This will cause byte combining
3133 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3134 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3135 inserted_chars
= PT
- XFASTINT (beg
);
3137 /* If point was outside of the region, restore it exactly; else just
3138 move to the beginning of the region. */
3139 if (old_pos
>= XFASTINT (end
))
3140 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3141 else if (old_pos
> XFASTINT (beg
))
3142 old_pos
= XFASTINT (beg
);
3143 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3145 return make_number (inserted_chars
);
3148 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3150 "Base64-decode STRING and return the result.")
3155 int length
, decoded_length
;
3156 Lisp_Object decoded_string
;
3158 CHECK_STRING (string
, 1);
3160 length
= STRING_BYTES (XSTRING (string
));
3161 /* We need to allocate enough room for decoding the text. */
3162 if (length
<= MAX_ALLOCA
)
3163 decoded
= (char *) alloca (length
);
3165 decoded
= (char *) xmalloc (length
);
3167 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3168 if (decoded_length
> length
)
3171 if (decoded_length
< 0)
3172 /* The decoding wasn't possible. */
3173 decoded_string
= Qnil
;
3175 decoded_string
= make_string (decoded
, decoded_length
);
3177 if (length
> MAX_ALLOCA
)
3180 return decoded_string
;
3184 base64_decode_1 (from
, to
, length
)
3192 unsigned long value
;
3196 /* Process first byte of a quadruplet. */
3198 READ_QUADRUPLET_BYTE (e
-to
);
3202 value
= base64_char_to_value
[c
] << 18;
3204 /* Process second byte of a quadruplet. */
3206 READ_QUADRUPLET_BYTE (-1);
3210 value
|= base64_char_to_value
[c
] << 12;
3212 *e
++ = (unsigned char) (value
>> 16);
3214 /* Process third byte of a quadruplet. */
3216 READ_QUADRUPLET_BYTE (-1);
3220 READ_QUADRUPLET_BYTE (-1);
3229 value
|= base64_char_to_value
[c
] << 6;
3231 *e
++ = (unsigned char) (0xff & value
>> 8);
3233 /* Process fourth byte of a quadruplet. */
3235 READ_QUADRUPLET_BYTE (-1);
3242 value
|= base64_char_to_value
[c
];
3244 *e
++ = (unsigned char) (0xff & value
);
3250 /***********************************************************************
3252 ***** Hash Tables *****
3254 ***********************************************************************/
3256 /* Implemented by gerd@gnu.org. This hash table implementation was
3257 inspired by CMUCL hash tables. */
3261 1. For small tables, association lists are probably faster than
3262 hash tables because they have lower overhead.
3264 For uses of hash tables where the O(1) behavior of table
3265 operations is not a requirement, it might therefore be a good idea
3266 not to hash. Instead, we could just do a linear search in the
3267 key_and_value vector of the hash table. This could be done
3268 if a `:linear-search t' argument is given to make-hash-table. */
3271 /* Return the contents of vector V at index IDX. */
3273 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3275 /* Value is the key part of entry IDX in hash table H. */
3277 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3279 /* Value is the value part of entry IDX in hash table H. */
3281 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3283 /* Value is the index of the next entry following the one at IDX
3286 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3288 /* Value is the hash code computed for entry IDX in hash table H. */
3290 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3292 /* Value is the index of the element in hash table H that is the
3293 start of the collision list at index IDX in the index vector of H. */
3295 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3297 /* Value is the size of hash table H. */
3299 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3301 /* The list of all weak hash tables. Don't staticpro this one. */
3303 Lisp_Object Vweak_hash_tables
;
3305 /* Various symbols. */
3307 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3308 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3309 Lisp_Object Qhash_table_test
;
3311 /* Function prototypes. */
3313 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3314 static int next_almost_prime
P_ ((int));
3315 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3316 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3317 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3318 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3319 Lisp_Object
, unsigned));
3320 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3321 Lisp_Object
, unsigned));
3322 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3323 unsigned, Lisp_Object
, unsigned));
3324 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3325 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3326 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3327 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3329 static unsigned sxhash_string
P_ ((unsigned char *, int));
3330 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3331 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3332 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3336 /***********************************************************************
3338 ***********************************************************************/
3340 /* If OBJ is a Lisp hash table, return a pointer to its struct
3341 Lisp_Hash_Table. Otherwise, signal an error. */
3343 static struct Lisp_Hash_Table
*
3344 check_hash_table (obj
)
3347 CHECK_HASH_TABLE (obj
, 0);
3348 return XHASH_TABLE (obj
);
3352 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3356 next_almost_prime (n
)
3369 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3370 which USED[I] is non-zero. If found at index I in ARGS, set
3371 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3372 -1. This function is used to extract a keyword/argument pair from
3373 a DEFUN parameter list. */
3376 get_key_arg (key
, nargs
, args
, used
)
3384 for (i
= 0; i
< nargs
- 1; ++i
)
3385 if (!used
[i
] && EQ (args
[i
], key
))
3400 /* Return a Lisp vector which has the same contents as VEC but has
3401 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3402 vector that are not copied from VEC are set to INIT. */
3405 larger_vector (vec
, new_size
, init
)
3410 struct Lisp_Vector
*v
;
3413 xassert (VECTORP (vec
));
3414 old_size
= XVECTOR (vec
)->size
;
3415 xassert (new_size
>= old_size
);
3417 v
= allocate_vectorlike (new_size
);
3419 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3420 old_size
* sizeof *v
->contents
);
3421 for (i
= old_size
; i
< new_size
; ++i
)
3422 v
->contents
[i
] = init
;
3423 XSETVECTOR (vec
, v
);
3428 /***********************************************************************
3430 ***********************************************************************/
3432 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3433 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3434 KEY2 are the same. */
3437 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3438 struct Lisp_Hash_Table
*h
;
3439 Lisp_Object key1
, key2
;
3440 unsigned hash1
, hash2
;
3442 return (FLOATP (key1
)
3444 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3448 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3449 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3450 KEY2 are the same. */
3453 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3454 struct Lisp_Hash_Table
*h
;
3455 Lisp_Object key1
, key2
;
3456 unsigned hash1
, hash2
;
3458 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3462 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3463 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3464 if KEY1 and KEY2 are the same. */
3467 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3468 struct Lisp_Hash_Table
*h
;
3469 Lisp_Object key1
, key2
;
3470 unsigned hash1
, hash2
;
3474 Lisp_Object args
[3];
3476 args
[0] = h
->user_cmp_function
;
3479 return !NILP (Ffuncall (3, args
));
3486 /* Value is a hash code for KEY for use in hash table H which uses
3487 `eq' to compare keys. The hash code returned is guaranteed to fit
3488 in a Lisp integer. */
3492 struct Lisp_Hash_Table
*h
;
3495 /* Lisp strings can change their address. Don't try to compute a
3496 hash code for a string from its address. */
3498 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3500 return XUINT (key
) ^ XGCTYPE (key
);
3504 /* Value is a hash code for KEY for use in hash table H which uses
3505 `eql' to compare keys. The hash code returned is guaranteed to fit
3506 in a Lisp integer. */
3510 struct Lisp_Hash_Table
*h
;
3513 /* Lisp strings can change their address. Don't try to compute a
3514 hash code for a string from its address. */
3516 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3517 else if (FLOATP (key
))
3518 return sxhash (key
, 0);
3520 return XUINT (key
) ^ XGCTYPE (key
);
3524 /* Value is a hash code for KEY for use in hash table H which uses
3525 `equal' to compare keys. The hash code returned is guaranteed to fit
3526 in a Lisp integer. */
3529 hashfn_equal (h
, key
)
3530 struct Lisp_Hash_Table
*h
;
3533 return sxhash (key
, 0);
3537 /* Value is a hash code for KEY for use in hash table H which uses as
3538 user-defined function to compare keys. The hash code returned is
3539 guaranteed to fit in a Lisp integer. */
3542 hashfn_user_defined (h
, key
)
3543 struct Lisp_Hash_Table
*h
;
3546 Lisp_Object args
[2], hash
;
3548 args
[0] = h
->user_hash_function
;
3550 hash
= Ffuncall (2, args
);
3551 if (!INTEGERP (hash
))
3553 list2 (build_string ("Illegal hash code returned from \
3554 user-supplied hash function"),
3556 return XUINT (hash
);
3560 /* Create and initialize a new hash table.
3562 TEST specifies the test the hash table will use to compare keys.
3563 It must be either one of the predefined tests `eq', `eql' or
3564 `equal' or a symbol denoting a user-defined test named TEST with
3565 test and hash functions USER_TEST and USER_HASH.
3567 Give the table initial capacity SIZE, SIZE > 0, an integer.
3569 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3570 new size when it becomes full is computed by adding REHASH_SIZE to
3571 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3572 table's new size is computed by multiplying its old size with
3575 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3576 be resized when the ratio of (number of entries in the table) /
3577 (table size) is >= REHASH_THRESHOLD.
3579 WEAK specifies the weakness of the table. If non-nil, it must be
3580 one of the symbols `key', `value' or t. */
3583 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3584 user_test
, user_hash
)
3585 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3586 Lisp_Object user_test
, user_hash
;
3588 struct Lisp_Hash_Table
*h
;
3589 struct Lisp_Vector
*v
;
3591 int index_size
, i
, len
, sz
;
3593 /* Preconditions. */
3594 xassert (SYMBOLP (test
));
3595 xassert (INTEGERP (size
) && XINT (size
) > 0);
3596 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3597 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3598 xassert (FLOATP (rehash_threshold
)
3599 && XFLOATINT (rehash_threshold
) > 0
3600 && XFLOATINT (rehash_threshold
) <= 1.0);
3602 /* Allocate a vector, and initialize it. */
3603 len
= VECSIZE (struct Lisp_Hash_Table
);
3604 v
= allocate_vectorlike (len
);
3606 for (i
= 0; i
< len
; ++i
)
3607 v
->contents
[i
] = Qnil
;
3609 /* Initialize hash table slots. */
3610 sz
= XFASTINT (size
);
3611 h
= (struct Lisp_Hash_Table
*) v
;
3614 if (EQ (test
, Qeql
))
3616 h
->cmpfn
= cmpfn_eql
;
3617 h
->hashfn
= hashfn_eql
;
3619 else if (EQ (test
, Qeq
))
3622 h
->hashfn
= hashfn_eq
;
3624 else if (EQ (test
, Qequal
))
3626 h
->cmpfn
= cmpfn_equal
;
3627 h
->hashfn
= hashfn_equal
;
3631 h
->user_cmp_function
= user_test
;
3632 h
->user_hash_function
= user_hash
;
3633 h
->cmpfn
= cmpfn_user_defined
;
3634 h
->hashfn
= hashfn_user_defined
;
3638 h
->rehash_threshold
= rehash_threshold
;
3639 h
->rehash_size
= rehash_size
;
3640 h
->count
= make_number (0);
3641 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3642 h
->hash
= Fmake_vector (size
, Qnil
);
3643 h
->next
= Fmake_vector (size
, Qnil
);
3644 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3645 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3647 /* Set up the free list. */
3648 for (i
= 0; i
< sz
- 1; ++i
)
3649 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3650 h
->next_free
= make_number (0);
3652 XSET_HASH_TABLE (table
, h
);
3653 xassert (HASH_TABLE_P (table
));
3654 xassert (XHASH_TABLE (table
) == h
);
3656 /* Maybe add this hash table to the list of all weak hash tables. */
3658 h
->next_weak
= Qnil
;
3661 h
->next_weak
= Vweak_hash_tables
;
3662 Vweak_hash_tables
= table
;
3669 /* Return a copy of hash table H1. Keys and values are not copied,
3670 only the table itself is. */
3673 copy_hash_table (h1
)
3674 struct Lisp_Hash_Table
*h1
;
3677 struct Lisp_Hash_Table
*h2
;
3678 struct Lisp_Vector
*v
, *next
;
3681 len
= VECSIZE (struct Lisp_Hash_Table
);
3682 v
= allocate_vectorlike (len
);
3683 h2
= (struct Lisp_Hash_Table
*) v
;
3684 next
= h2
->vec_next
;
3685 bcopy (h1
, h2
, sizeof *h2
);
3686 h2
->vec_next
= next
;
3687 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3688 h2
->hash
= Fcopy_sequence (h1
->hash
);
3689 h2
->next
= Fcopy_sequence (h1
->next
);
3690 h2
->index
= Fcopy_sequence (h1
->index
);
3691 XSET_HASH_TABLE (table
, h2
);
3693 /* Maybe add this hash table to the list of all weak hash tables. */
3694 if (!NILP (h2
->weak
))
3696 h2
->next_weak
= Vweak_hash_tables
;
3697 Vweak_hash_tables
= table
;
3704 /* Resize hash table H if it's too full. If H cannot be resized
3705 because it's already too large, throw an error. */
3708 maybe_resize_hash_table (h
)
3709 struct Lisp_Hash_Table
*h
;
3711 if (NILP (h
->next_free
))
3713 int old_size
= HASH_TABLE_SIZE (h
);
3714 int i
, new_size
, index_size
;
3716 if (INTEGERP (h
->rehash_size
))
3717 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3719 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3720 index_size
= next_almost_prime (new_size
3721 / XFLOATINT (h
->rehash_threshold
));
3722 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3723 error ("Hash table too large to resize");
3725 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3726 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3727 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3728 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3730 /* Update the free list. Do it so that new entries are added at
3731 the end of the free list. This makes some operations like
3733 for (i
= old_size
; i
< new_size
- 1; ++i
)
3734 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3736 if (!NILP (h
->next_free
))
3738 Lisp_Object last
, next
;
3740 last
= h
->next_free
;
3741 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3745 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3748 XSETFASTINT (h
->next_free
, old_size
);
3751 for (i
= 0; i
< old_size
; ++i
)
3752 if (!NILP (HASH_HASH (h
, i
)))
3754 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3755 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3756 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3757 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3763 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3764 the hash code of KEY. Value is the index of the entry in H
3765 matching KEY, or -1 if not found. */
3768 hash_lookup (h
, key
, hash
)
3769 struct Lisp_Hash_Table
*h
;
3774 int start_of_bucket
;
3777 hash_code
= h
->hashfn (h
, key
);
3781 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3782 idx
= HASH_INDEX (h
, start_of_bucket
);
3786 int i
= XFASTINT (idx
);
3787 if (EQ (key
, HASH_KEY (h
, i
))
3789 && h
->cmpfn (h
, key
, hash_code
,
3790 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3792 idx
= HASH_NEXT (h
, i
);
3795 return NILP (idx
) ? -1 : XFASTINT (idx
);
3799 /* Put an entry into hash table H that associates KEY with VALUE.
3800 HASH is a previously computed hash code of KEY. */
3803 hash_put (h
, key
, value
, hash
)
3804 struct Lisp_Hash_Table
*h
;
3805 Lisp_Object key
, value
;
3808 int start_of_bucket
, i
;
3810 xassert ((hash
& ~VALMASK
) == 0);
3812 /* Increment count after resizing because resizing may fail. */
3813 maybe_resize_hash_table (h
);
3814 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3816 /* Store key/value in the key_and_value vector. */
3817 i
= XFASTINT (h
->next_free
);
3818 h
->next_free
= HASH_NEXT (h
, i
);
3819 HASH_KEY (h
, i
) = key
;
3820 HASH_VALUE (h
, i
) = value
;
3822 /* Remember its hash code. */
3823 HASH_HASH (h
, i
) = make_number (hash
);
3825 /* Add new entry to its collision chain. */
3826 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3827 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3828 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3832 /* Remove the entry matching KEY from hash table H, if there is one. */
3835 hash_remove (h
, key
)
3836 struct Lisp_Hash_Table
*h
;
3840 int start_of_bucket
;
3841 Lisp_Object idx
, prev
;
3843 hash_code
= h
->hashfn (h
, key
);
3844 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3845 idx
= HASH_INDEX (h
, start_of_bucket
);
3850 int i
= XFASTINT (idx
);
3852 if (EQ (key
, HASH_KEY (h
, i
))
3854 && h
->cmpfn (h
, key
, hash_code
,
3855 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3857 /* Take entry out of collision chain. */
3859 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3861 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3863 /* Clear slots in key_and_value and add the slots to
3865 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3866 HASH_NEXT (h
, i
) = h
->next_free
;
3867 h
->next_free
= make_number (i
);
3868 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3869 xassert (XINT (h
->count
) >= 0);
3875 idx
= HASH_NEXT (h
, i
);
3881 /* Clear hash table H. */
3885 struct Lisp_Hash_Table
*h
;
3887 if (XFASTINT (h
->count
) > 0)
3889 int i
, size
= HASH_TABLE_SIZE (h
);
3891 for (i
= 0; i
< size
; ++i
)
3893 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3894 HASH_KEY (h
, i
) = Qnil
;
3895 HASH_VALUE (h
, i
) = Qnil
;
3896 HASH_HASH (h
, i
) = Qnil
;
3899 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3900 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3902 h
->next_free
= make_number (0);
3903 h
->count
= make_number (0);
3909 /************************************************************************
3911 ************************************************************************/
3913 /* Remove elements from weak hash tables that don't survive the
3914 current garbage collection. Remove weak tables that don't survive
3915 from Vweak_hash_tables. Called from gc_sweep. */
3918 sweep_weak_hash_tables ()
3921 struct Lisp_Hash_Table
*h
= 0, *prev
;
3923 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
3926 h
= XHASH_TABLE (table
);
3928 if (h
->size
& ARRAY_MARK_FLAG
)
3930 if (XFASTINT (h
->count
) > 0)
3934 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3935 for (bucket
= 0; bucket
< n
; ++bucket
)
3937 Lisp_Object idx
, key
, value
, prev
, next
;
3939 /* Follow collision chain, removing entries that
3940 don't survive this garbage collection. */
3941 idx
= HASH_INDEX (h
, bucket
);
3943 while (!GC_NILP (idx
))
3946 int i
= XFASTINT (idx
);
3949 if (EQ (h
->weak
, Qkey
))
3950 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
3951 else if (EQ (h
->weak
, Qvalue
))
3952 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
3953 else if (EQ (h
->weak
, Qt
))
3954 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
3955 || !survives_gc_p (HASH_VALUE (h
, i
)));
3959 next
= HASH_NEXT (h
, i
);
3962 /* Take out of collision chain. */
3964 HASH_INDEX (h
, i
) = next
;
3966 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3968 /* Add to free list. */
3969 HASH_NEXT (h
, i
) = h
->next_free
;
3972 /* Clear key, value, and hash. */
3973 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3974 HASH_HASH (h
, i
) = Qnil
;
3976 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3980 /* Make sure key and value survive. */
3981 mark_object (&HASH_KEY (h
, i
));
3982 mark_object (&HASH_VALUE (h
, i
));
3992 /* Table is not marked, and will thus be freed.
3993 Take it out of the list of weak hash tables. */
3995 prev
->next_weak
= h
->next_weak
;
3997 Vweak_hash_tables
= h
->next_weak
;
4004 /***********************************************************************
4005 Hash Code Computation
4006 ***********************************************************************/
4008 /* Maximum depth up to which to dive into Lisp structures. */
4010 #define SXHASH_MAX_DEPTH 3
4012 /* Maximum length up to which to take list and vector elements into
4015 #define SXHASH_MAX_LEN 7
4017 /* Combine two integers X and Y for hashing. */
4019 #define SXHASH_COMBINE(X, Y) \
4020 ((((unsigned)(X) << 4) + ((unsigned)(X) >> 24) & 0x0fffffff) \
4024 /* Return a hash for string PTR which has length LEN. */
4027 sxhash_string (ptr
, len
)
4031 unsigned char *p
= ptr
;
4032 unsigned char *end
= p
+ len
;
4041 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4044 return hash
& 07777777777;
4048 /* Return a hash for list LIST. DEPTH is the current depth in the
4049 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4052 sxhash_list (list
, depth
)
4059 if (depth
< SXHASH_MAX_DEPTH
)
4061 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4062 list
= XCDR (list
), ++i
)
4064 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4065 hash
= SXHASH_COMBINE (hash
, hash2
);
4072 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4073 the Lisp structure. */
4076 sxhash_vector (vec
, depth
)
4080 unsigned hash
= XVECTOR (vec
)->size
;
4083 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4084 for (i
= 0; i
< n
; ++i
)
4086 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4087 hash
= SXHASH_COMBINE (hash
, hash2
);
4094 /* Return a hash for bool-vector VECTOR. */
4097 sxhash_bool_vector (vec
)
4100 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4103 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4104 for (i
= 0; i
< n
; ++i
)
4105 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4111 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4112 structure. Value is an unsigned integer clipped to VALMASK. */
4121 if (depth
> SXHASH_MAX_DEPTH
)
4124 switch (XTYPE (obj
))
4131 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4132 XSYMBOL (obj
)->name
->size
);
4140 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4143 /* This can be everything from a vector to an overlay. */
4144 case Lisp_Vectorlike
:
4146 /* According to the CL HyperSpec, two arrays are equal only if
4147 they are `eq', except for strings and bit-vectors. In
4148 Emacs, this works differently. We have to compare element
4150 hash
= sxhash_vector (obj
, depth
);
4151 else if (BOOL_VECTOR_P (obj
))
4152 hash
= sxhash_bool_vector (obj
);
4154 /* Others are `equal' if they are `eq', so let's take their
4160 hash
= sxhash_list (obj
, depth
);
4165 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4166 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4167 for (hash
= 0; p
< e
; ++p
)
4168 hash
= SXHASH_COMBINE (hash
, *p
);
4176 return hash
& VALMASK
;
4181 /***********************************************************************
4183 ***********************************************************************/
4186 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4187 "Compute a hash code for OBJ and return it as integer.")
4191 unsigned hash
= sxhash (obj
, 0);;
4192 return make_number (hash
);
4196 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4197 "Create and return a new hash table.\n\
4198 Arguments are specified as keyword/argument pairs. The following\n\
4199 arguments are defined:\n\
4201 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.
4202 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4203 User-supplied test and hash functions can be specified via\n\
4204 `define-hash-table-test'.\n\
4206 :SIZE SIZE -- A hint as to how many elements will be put in the table.
4209 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4210 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4211 If it is a float, it must be > 1.0, and the new size is computed by\n\
4212 multiplying the old size with that factor. Default is 1.5.\n\
4214 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4215 Resize the hash table when ratio of the number of entries in the table.\n\
4218 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4219 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4220 pairs are removed from a weak hash table when their key, value or both\n\
4221 (WEAK t) are otherwise unreferenced. Default is nil.")
4226 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4227 Lisp_Object user_test
, user_hash
;
4231 /* The vector `used' is used to keep track of arguments that
4232 have been consumed. */
4233 used
= (char *) alloca (nargs
* sizeof *used
);
4234 bzero (used
, nargs
* sizeof *used
);
4236 /* See if there's a `:test TEST' among the arguments. */
4237 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4238 test
= i
< 0 ? Qeql
: args
[i
];
4239 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4241 /* See if it is a user-defined test. */
4244 prop
= Fget (test
, Qhash_table_test
);
4245 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4246 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4248 user_test
= Fnth (make_number (0), prop
);
4249 user_hash
= Fnth (make_number (1), prop
);
4252 user_test
= user_hash
= Qnil
;
4254 /* See if there's a `:size SIZE' argument. */
4255 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4256 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4257 if (!INTEGERP (size
) || XINT (size
) <= 0)
4259 list2 (build_string ("Illegal hash table size"),
4262 /* Look for `:rehash-size SIZE'. */
4263 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4264 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4265 if (!NUMBERP (rehash_size
)
4266 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4267 || XFLOATINT (rehash_size
) <= 1.0)
4269 list2 (build_string ("Illegal hash table rehash size"),
4272 /* Look for `:rehash-threshold THRESHOLD'. */
4273 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4274 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4275 if (!FLOATP (rehash_threshold
)
4276 || XFLOATINT (rehash_threshold
) <= 0.0
4277 || XFLOATINT (rehash_threshold
) > 1.0)
4279 list2 (build_string ("Illegal hash table rehash threshold"),
4282 /* Look for `:weakness WEAK'. */
4283 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4284 weak
= i
< 0 ? Qnil
: args
[i
];
4288 && !EQ (weak
, Qvalue
))
4289 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4292 /* Now, all args should have been used up, or there's a problem. */
4293 for (i
= 0; i
< nargs
; ++i
)
4296 list2 (build_string ("Invalid argument list"), args
[i
]));
4298 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4299 user_test
, user_hash
);
4303 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4304 "Return a copy of hash table TABLE.")
4308 return copy_hash_table (check_hash_table (table
));
4312 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4313 "Create a new hash table.\n\
4314 Optional first argument TEST specifies how to compare keys in\n\
4315 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4316 is `eql'. New tests can be defined with `define-hash-table-test'.")
4320 Lisp_Object args
[2];
4323 return Fmake_hash_table (2, args
);
4327 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4328 "Return the number of elements in TABLE.")
4332 return check_hash_table (table
)->count
;
4336 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4337 Shash_table_rehash_size
, 1, 1, 0,
4338 "Return the current rehash size of TABLE.")
4342 return check_hash_table (table
)->rehash_size
;
4346 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4347 Shash_table_rehash_threshold
, 1, 1, 0,
4348 "Return the current rehash threshold of TABLE.")
4352 return check_hash_table (table
)->rehash_threshold
;
4356 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4357 "Return the size of TABLE.\n\
4358 The size can be used as an argument to `make-hash-table' to create\n\
4359 a hash table than can hold as many elements of TABLE holds\n\
4360 without need for resizing.")
4364 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4365 return make_number (HASH_TABLE_SIZE (h
));
4369 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4370 "Return the test TABLE uses.")
4374 return check_hash_table (table
)->test
;
4378 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4380 "Return the weakness of TABLE.")
4384 return check_hash_table (table
)->weak
;
4388 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4389 "Return t if OBJ is a Lisp hash table object.")
4393 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4397 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4398 "Clear hash table TABLE.")
4402 hash_clear (check_hash_table (table
));
4407 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4408 "Look up KEY in TABLE and return its associated value.\n\
4409 If KEY is not found, return DFLT which defaults to nil.")
4411 Lisp_Object key
, table
;
4413 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4414 int i
= hash_lookup (h
, key
, NULL
);
4415 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4419 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4420 "Associate KEY with VALUE is hash table TABLE.\n\
4421 If KEY is already present in table, replace its current value with\n\
4424 Lisp_Object key
, value
, table
;
4426 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4430 i
= hash_lookup (h
, key
, &hash
);
4432 HASH_VALUE (h
, i
) = value
;
4434 hash_put (h
, key
, value
, hash
);
4440 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4441 "Remove KEY from TABLE.")
4443 Lisp_Object key
, table
;
4445 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4446 hash_remove (h
, key
);
4451 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4452 "Call FUNCTION for all entries in hash table TABLE.\n\
4453 FUNCTION is called with 2 arguments KEY and VALUE.")
4455 Lisp_Object function
, table
;
4457 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4458 Lisp_Object args
[3];
4461 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4462 if (!NILP (HASH_HASH (h
, i
)))
4465 args
[1] = HASH_KEY (h
, i
);
4466 args
[2] = HASH_VALUE (h
, i
);
4474 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4475 Sdefine_hash_table_test
, 3, 3, 0,
4476 "Define a new hash table test with name NAME, a symbol.\n\
4477 In hash tables create with NAME specified as test, use TEST to compare\n\
4478 keys, and HASH for computing hash codes of keys.\n\
4480 TEST must be a function taking two arguments and returning non-nil\n\
4481 if both arguments are the same. HASH must be a function taking\n\
4482 one argument and return an integer that is the hash code of the\n\
4483 argument. Hash code computation should use the whole value range of\n\
4484 integers, including negative integers.")
4486 Lisp_Object name
, test
, hash
;
4488 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4497 /* Hash table stuff. */
4498 Qhash_table_p
= intern ("hash-table-p");
4499 staticpro (&Qhash_table_p
);
4500 Qeq
= intern ("eq");
4502 Qeql
= intern ("eql");
4504 Qequal
= intern ("equal");
4505 staticpro (&Qequal
);
4506 QCtest
= intern (":test");
4507 staticpro (&QCtest
);
4508 QCsize
= intern (":size");
4509 staticpro (&QCsize
);
4510 QCrehash_size
= intern (":rehash-size");
4511 staticpro (&QCrehash_size
);
4512 QCrehash_threshold
= intern (":rehash-threshold");
4513 staticpro (&QCrehash_threshold
);
4514 QCweakness
= intern (":weakness");
4515 staticpro (&QCweakness
);
4516 Qkey
= intern ("key");
4518 Qvalue
= intern ("value");
4519 staticpro (&Qvalue
);
4520 Qhash_table_test
= intern ("hash-table-test");
4521 staticpro (&Qhash_table_test
);
4524 defsubr (&Smake_hash_table
);
4525 defsubr (&Scopy_hash_table
);
4526 defsubr (&Smakehash
);
4527 defsubr (&Shash_table_count
);
4528 defsubr (&Shash_table_rehash_size
);
4529 defsubr (&Shash_table_rehash_threshold
);
4530 defsubr (&Shash_table_size
);
4531 defsubr (&Shash_table_test
);
4532 defsubr (&Shash_table_weakness
);
4533 defsubr (&Shash_table_p
);
4534 defsubr (&Sclrhash
);
4535 defsubr (&Sgethash
);
4536 defsubr (&Sputhash
);
4537 defsubr (&Sremhash
);
4538 defsubr (&Smaphash
);
4539 defsubr (&Sdefine_hash_table_test
);
4541 Qstring_lessp
= intern ("string-lessp");
4542 staticpro (&Qstring_lessp
);
4543 Qprovide
= intern ("provide");
4544 staticpro (&Qprovide
);
4545 Qrequire
= intern ("require");
4546 staticpro (&Qrequire
);
4547 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4548 staticpro (&Qyes_or_no_p_history
);
4549 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4550 staticpro (&Qcursor_in_echo_area
);
4551 Qwidget_type
= intern ("widget-type");
4552 staticpro (&Qwidget_type
);
4554 staticpro (&string_char_byte_cache_string
);
4555 string_char_byte_cache_string
= Qnil
;
4557 Fset (Qyes_or_no_p_history
, Qnil
);
4559 DEFVAR_LISP ("features", &Vfeatures
,
4560 "A list of symbols which are the features of the executing emacs.\n\
4561 Used by `featurep' and `require', and altered by `provide'.");
4564 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4565 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4566 This applies to y-or-n and yes-or-no questions asked by commands\n\
4567 invoked by mouse clicks and mouse menu items.");
4570 defsubr (&Sidentity
);
4573 defsubr (&Ssafe_length
);
4574 defsubr (&Sstring_bytes
);
4575 defsubr (&Sstring_equal
);
4576 defsubr (&Scompare_strings
);
4577 defsubr (&Sstring_lessp
);
4580 defsubr (&Svconcat
);
4581 defsubr (&Scopy_sequence
);
4582 defsubr (&Sstring_make_multibyte
);
4583 defsubr (&Sstring_make_unibyte
);
4584 defsubr (&Sstring_as_multibyte
);
4585 defsubr (&Sstring_as_unibyte
);
4586 defsubr (&Scopy_alist
);
4587 defsubr (&Ssubstring
);
4599 defsubr (&Snreverse
);
4600 defsubr (&Sreverse
);
4602 defsubr (&Splist_get
);
4604 defsubr (&Splist_put
);
4607 defsubr (&Sfillarray
);
4608 defsubr (&Schar_table_subtype
);
4609 defsubr (&Schar_table_parent
);
4610 defsubr (&Sset_char_table_parent
);
4611 defsubr (&Schar_table_extra_slot
);
4612 defsubr (&Sset_char_table_extra_slot
);
4613 defsubr (&Schar_table_range
);
4614 defsubr (&Sset_char_table_range
);
4615 defsubr (&Sset_char_table_default
);
4616 defsubr (&Smap_char_table
);
4619 defsubr (&Smapconcat
);
4620 defsubr (&Sy_or_n_p
);
4621 defsubr (&Syes_or_no_p
);
4622 defsubr (&Sload_average
);
4623 defsubr (&Sfeaturep
);
4624 defsubr (&Srequire
);
4625 defsubr (&Sprovide
);
4626 defsubr (&Swidget_plist_member
);
4627 defsubr (&Swidget_put
);
4628 defsubr (&Swidget_get
);
4629 defsubr (&Swidget_apply
);
4630 defsubr (&Sbase64_encode_region
);
4631 defsubr (&Sbase64_decode_region
);
4632 defsubr (&Sbase64_encode_string
);
4633 defsubr (&Sbase64_decode_string
);
4640 Vweak_hash_tables
= Qnil
;