1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 1999 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
52 #define min(a, b) ((a) < (b) ? (a) : (b))
53 #define max(a, b) ((a) > (b) ? (a) : (b))
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 extern int minibuffer_auto_raise
;
61 extern Lisp_Object minibuf_window
;
63 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
64 Lisp_Object Qyes_or_no_p_history
;
65 Lisp_Object Qcursor_in_echo_area
;
66 Lisp_Object Qwidget_type
;
68 extern Lisp_Object Qinput_method_function
;
70 static int internal_equal ();
72 extern long get_random ();
73 extern void seed_random ();
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 "Return the argument unchanged.")
87 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
88 "Return a pseudo-random number.\n\
89 All integers representable in Lisp are equally likely.\n\
90 On most systems, this is 28 bits' worth.\n\
91 With positive integer argument N, return random number in interval [0,N).\n\
92 With argument t, set the random number seed from the current time and pid.")
97 Lisp_Object lispy_val
;
98 unsigned long denominator
;
101 seed_random (getpid () + time (NULL
));
102 if (NATNUMP (n
) && XFASTINT (n
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. We do this by using the
107 quotient rather than the remainder. At the high end of the RNG
108 it's possible to get a quotient larger than n; discarding
109 these values eliminates the bias that would otherwise appear
110 when using a large n. */
111 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
113 val
= get_random () / denominator
;
114 while (val
>= XFASTINT (n
));
118 XSETINT (lispy_val
, val
);
122 /* Random data-structure functions */
124 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
125 "Return the length of vector, list or string SEQUENCE.\n\
126 A byte-code function object is also allowed.\n\
127 If the string contains multibyte characters, this is not the necessarily\n\
128 the number of bytes in the string; it is the number of characters.\n\
129 To get the number of bytes, use `string-bytes'")
131 register Lisp_Object sequence
;
133 register Lisp_Object tail
, val
;
137 if (STRINGP (sequence
))
138 XSETFASTINT (val
, XSTRING (sequence
)->size
);
139 else if (VECTORP (sequence
))
140 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
141 else if (CHAR_TABLE_P (sequence
))
142 XSETFASTINT (val
, (MIN_CHAR_COMPOSITION
143 + (CHAR_FIELD2_MASK
| CHAR_FIELD3_MASK
)
145 else if (BOOL_VECTOR_P (sequence
))
146 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
147 else if (COMPILEDP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
149 else if (CONSP (sequence
))
151 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
157 XSETFASTINT (val
, i
);
159 else if (NILP (sequence
))
160 XSETFASTINT (val
, 0);
163 sequence
= wrong_type_argument (Qsequencep
, sequence
);
169 /* This does not check for quits. That is safe
170 since it must terminate. */
172 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
173 "Return the length of a list, but avoid error or infinite loop.\n\
174 This function never gets an error. If LIST is not really a list,\n\
175 it returns 0. If LIST is circular, it returns a finite value\n\
176 which is at least the number of distinct elements.")
180 Lisp_Object tail
, halftail
, length
;
183 /* halftail is used to detect circular lists. */
185 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
187 if (EQ (tail
, halftail
) && len
!= 0)
191 halftail
= XCONS (halftail
)->cdr
;
194 XSETINT (length
, len
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 "Return the number of bytes in STRING.\n\
200 If STRING is a multibyte string, this is greater than the length of STRING.")
204 CHECK_STRING (string
, 1);
205 return make_number (STRING_BYTES (XSTRING (string
)));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 "Return t if two strings have identical contents.\n\
210 Case is significant, but text properties are ignored.\n\
211 Symbols are also allowed; their print names are used instead.")
213 register Lisp_Object s1
, s2
;
216 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
218 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
219 CHECK_STRING (s1
, 0);
220 CHECK_STRING (s2
, 1);
222 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
223 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
224 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
229 DEFUN ("compare-strings", Fcompare_strings
,
230 Scompare_strings
, 6, 7, 0,
231 "Compare the contents of two strings, converting to multibyte if needed.\n\
232 In string STR1, skip the first START1 characters and stop at END1.\n\
233 In string STR2, skip the first START2 characters and stop at END2.\n\
234 END1 and END2 default to the full lengths of the respective strings.\n\
236 Case is significant in this comparison if IGNORE-CASE is nil.\n\
237 Unibyte strings are converted to multibyte for comparison.\n\
239 The value is t if the strings (or specified portions) match.\n\
240 If string STR1 is less, the value is a negative number N;\n\
241 - 1 - N is the number of characters that match at the beginning.\n\
242 If string STR1 is greater, the value is a positive number N;\n\
243 N - 1 is the number of characters that match at the beginning.")
244 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
245 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
247 register int end1_char
, end2_char
;
248 register int i1
, i1_byte
, i2
, i2_byte
;
250 CHECK_STRING (str1
, 0);
251 CHECK_STRING (str2
, 1);
253 start1
= make_number (0);
255 start2
= make_number (0);
256 CHECK_NATNUM (start1
, 2);
257 CHECK_NATNUM (start2
, 3);
259 CHECK_NATNUM (end1
, 4);
261 CHECK_NATNUM (end2
, 4);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 end1_char
= XSTRING (str1
)->size
;
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
273 end2_char
= XSTRING (str2
)->size
;
274 if (! NILP (end2
) && end2_char
> XINT (end2
))
275 end2_char
= XINT (end2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
287 c1
= XSTRING (str1
)->data
[i1
++];
288 c1
= unibyte_char_to_multibyte (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
295 c2
= XSTRING (str2
)->data
[i2
++];
296 c2
= unibyte_char_to_multibyte (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
);
321 return make_number (i1
);
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 "Return t if first arg string is less than second in lexicographic order.\n\
334 Case is significant.\n\
335 Symbols are also allowed; their print names are used instead.")
337 register Lisp_Object s1
, s2
;
340 register int i1
, i1_byte
, i2
, i2_byte
;
343 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
345 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
346 CHECK_STRING (s1
, 0);
347 CHECK_STRING (s2
, 1);
349 i1
= i1_byte
= i2
= i2_byte
= 0;
351 end
= XSTRING (s1
)->size
;
352 if (end
> XSTRING (s2
)->size
)
353 end
= XSTRING (s2
)->size
;
357 /* When we find a mismatch, we must compare the
358 characters, not just the bytes. */
361 if (STRING_MULTIBYTE (s1
))
362 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
364 c1
= XSTRING (s1
)->data
[i1
++];
366 if (STRING_MULTIBYTE (s2
))
367 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
369 c2
= XSTRING (s2
)->data
[i2
++];
372 return c1
< c2
? Qt
: Qnil
;
374 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
377 static Lisp_Object
concat ();
388 return concat (2, args
, Lisp_String
, 0);
390 return concat (2, &s1
, Lisp_String
, 0);
391 #endif /* NO_ARG_ARRAY */
397 Lisp_Object s1
, s2
, s3
;
404 return concat (3, args
, Lisp_String
, 0);
406 return concat (3, &s1
, Lisp_String
, 0);
407 #endif /* NO_ARG_ARRAY */
410 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
411 "Concatenate all the arguments and make the result a list.\n\
412 The result is a list whose elements are the elements of all the arguments.\n\
413 Each argument may be a list, vector or string.\n\
414 The last argument is not copied, just used as the tail of the new list.")
419 return concat (nargs
, args
, Lisp_Cons
, 1);
422 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
423 "Concatenate all the arguments and make the result a string.\n\
424 The result is a string whose elements are the elements of all the arguments.\n\
425 Each argument may be a string or a list or vector of characters (integers).\n\
427 Do not use individual integers as arguments!\n\
428 The behavior of `concat' in that case will be changed later!\n\
429 If your program passes an integer as an argument to `concat',\n\
430 you should change it right away not to do so.")
435 return concat (nargs
, args
, Lisp_String
, 0);
438 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
439 "Concatenate all the arguments and make the result a vector.\n\
440 The result is a vector whose elements are the elements of all the arguments.\n\
441 Each argument may be a list, vector or string.")
446 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
449 /* Retrun a copy of a sub char table ARG. The elements except for a
450 nested sub char table are not copied. */
452 copy_sub_char_table (arg
)
455 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
458 /* Copy all the contents. */
459 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
460 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
461 /* Recursively copy any sub char-tables in the ordinary slots. */
462 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
463 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
464 XCHAR_TABLE (copy
)->contents
[i
]
465 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
471 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
472 "Return a copy of a list, vector or string.\n\
473 The elements of a list or vector are not copied; they are shared\n\
478 if (NILP (arg
)) return arg
;
480 if (CHAR_TABLE_P (arg
))
485 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
486 /* Copy all the slots, including the extra ones. */
487 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
488 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
489 * sizeof (Lisp_Object
)));
491 /* Recursively copy any sub char tables in the ordinary slots
492 for multibyte characters. */
493 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
494 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
495 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
496 XCHAR_TABLE (copy
)->contents
[i
]
497 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
502 if (BOOL_VECTOR_P (arg
))
506 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
508 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
509 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
514 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
515 arg
= wrong_type_argument (Qsequencep
, arg
);
516 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
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
)
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
]))
537 while (j
< len
&& ! CHAR_HEAD_P (str
[j
])) j
++;
541 /* This structure holds information of an argument of `concat' that is
542 a string and has text properties to be copied. */
545 int argnum
; /* refer to ARGS (arguments of `concat') */
546 int from
; /* refer to ARGS[argnum] (argument string) */
547 int to
; /* refer to VAL (the target string) */
551 concat (nargs
, args
, target_type
, last_special
)
554 enum Lisp_Type target_type
;
558 register Lisp_Object tail
;
559 register Lisp_Object
this;
562 register int result_len
;
563 register int result_len_byte
;
565 Lisp_Object last_tail
;
568 /* When we make a multibyte string, we can't copy text properties
569 while concatinating each string because the length of resulting
570 string can't be decided until we finish the whole concatination.
571 So, we record strings that have text properties to be copied
572 here, and copy the text properties after the concatination. */
573 struct textprop_rec
*textprops
;
574 /* Number of elments in textprops. */
575 int num_textprops
= 0;
577 /* In append, the last arg isn't treated like the others */
578 if (last_special
&& nargs
> 0)
581 last_tail
= args
[nargs
];
586 /* Canonicalize each argument. */
587 for (argnum
= 0; argnum
< nargs
; argnum
++)
590 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
591 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
594 args
[argnum
] = Fnumber_to_string (this);
596 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
600 /* Compute total length in chars of arguments in RESULT_LEN.
601 If desired output is a string, also compute length in bytes
602 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
603 whether the result should be a multibyte string. */
607 for (argnum
= 0; argnum
< nargs
; argnum
++)
611 len
= XFASTINT (Flength (this));
612 if (target_type
== Lisp_String
)
614 /* We must count the number of bytes needed in the string
615 as well as the number of characters. */
621 for (i
= 0; i
< len
; i
++)
623 ch
= XVECTOR (this)->contents
[i
];
625 wrong_type_argument (Qintegerp
, ch
);
626 this_len_byte
= CHAR_BYTES (XINT (ch
));
627 result_len_byte
+= this_len_byte
;
628 if (this_len_byte
> 1)
631 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
632 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
633 else if (CONSP (this))
634 for (; CONSP (this); this = XCONS (this)->cdr
)
636 ch
= XCONS (this)->car
;
638 wrong_type_argument (Qintegerp
, ch
);
639 this_len_byte
= CHAR_BYTES (XINT (ch
));
640 result_len_byte
+= this_len_byte
;
641 if (this_len_byte
> 1)
644 else if (STRINGP (this))
646 if (STRING_MULTIBYTE (this))
649 result_len_byte
+= STRING_BYTES (XSTRING (this));
652 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
653 XSTRING (this)->size
);
660 if (! some_multibyte
)
661 result_len_byte
= result_len
;
663 /* Create the output object. */
664 if (target_type
== Lisp_Cons
)
665 val
= Fmake_list (make_number (result_len
), Qnil
);
666 else if (target_type
== Lisp_Vectorlike
)
667 val
= Fmake_vector (make_number (result_len
), Qnil
);
668 else if (some_multibyte
)
669 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
671 val
= make_uninit_string (result_len
);
673 /* In `append', if all but last arg are nil, return last arg. */
674 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
677 /* Copy the contents of the args into the result. */
679 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
681 toindex
= 0, toindex_byte
= 0;
686 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
688 for (argnum
= 0; argnum
< nargs
; argnum
++)
692 register unsigned int thisindex
= 0;
693 register unsigned int thisindex_byte
= 0;
697 thislen
= Flength (this), thisleni
= XINT (thislen
);
699 /* Between strings of the same kind, copy fast. */
700 if (STRINGP (this) && STRINGP (val
)
701 && STRING_MULTIBYTE (this) == some_multibyte
)
703 int thislen_byte
= STRING_BYTES (XSTRING (this));
706 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
707 STRING_BYTES (XSTRING (this)));
708 combined
= (some_multibyte
&& toindex_byte
> 0
709 ? count_combining (XSTRING (val
)->data
,
710 toindex_byte
+ thislen_byte
,
713 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
715 textprops
[num_textprops
].argnum
= argnum
;
716 /* We ignore text properties on characters being combined. */
717 textprops
[num_textprops
].from
= combined
;
718 textprops
[num_textprops
++].to
= toindex
;
720 toindex_byte
+= thislen_byte
;
721 toindex
+= thisleni
- combined
;
722 XSTRING (val
)->size
-= combined
;
724 /* Copy a single-byte string to a multibyte string. */
725 else if (STRINGP (this) && STRINGP (val
))
727 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
729 textprops
[num_textprops
].argnum
= argnum
;
730 textprops
[num_textprops
].from
= 0;
731 textprops
[num_textprops
++].to
= toindex
;
733 toindex_byte
+= copy_text (XSTRING (this)->data
,
734 XSTRING (val
)->data
+ toindex_byte
,
735 XSTRING (this)->size
, 0, 1);
739 /* Copy element by element. */
742 register Lisp_Object elt
;
744 /* Fetch next element of `this' arg into `elt', or break if
745 `this' is exhausted. */
746 if (NILP (this)) break;
748 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
749 else if (thisindex
>= thisleni
)
751 else if (STRINGP (this))
754 if (STRING_MULTIBYTE (this))
756 FETCH_STRING_CHAR_ADVANCE (c
, this,
759 XSETFASTINT (elt
, c
);
763 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
765 && (XINT (elt
) >= 0240
766 || (XINT (elt
) >= 0200
767 && ! NILP (Vnonascii_translation_table
)))
768 && XINT (elt
) < 0400)
770 c
= unibyte_char_to_multibyte (XINT (elt
));
775 else if (BOOL_VECTOR_P (this))
778 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
779 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
786 elt
= XVECTOR (this)->contents
[thisindex
++];
788 /* Store this element into the result. */
791 XCONS (tail
)->car
= elt
;
793 tail
= XCONS (tail
)->cdr
;
795 else if (VECTORP (val
))
796 XVECTOR (val
)->contents
[toindex
++] = elt
;
799 CHECK_NUMBER (elt
, 0);
800 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
802 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
805 && count_combining (XSTRING (val
)->data
,
806 toindex_byte
, toindex_byte
- 1))
807 XSTRING (val
)->size
--;
812 /* If we have any multibyte characters,
813 we already decided to make a multibyte string. */
816 unsigned char work
[4], *str
;
817 int i
= CHAR_STRING (c
, work
, str
);
819 /* P exists as a variable
820 to avoid a bug on the Masscomp C compiler. */
821 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
830 XCONS (prev
)->cdr
= last_tail
;
832 if (num_textprops
> 0)
834 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
836 this = args
[textprops
[argnum
].argnum
];
837 copy_text_properties (make_number (textprops
[argnum
].from
),
838 XSTRING (this)->size
, this,
839 make_number (textprops
[argnum
].to
), val
, Qnil
);
845 static Lisp_Object string_char_byte_cache_string
;
846 static int string_char_byte_cache_charpos
;
847 static int string_char_byte_cache_bytepos
;
850 clear_string_char_byte_cache ()
852 string_char_byte_cache_string
= Qnil
;
855 /* Return the character index corresponding to CHAR_INDEX in STRING. */
858 string_char_to_byte (string
, char_index
)
863 int best_below
, best_below_byte
;
864 int best_above
, best_above_byte
;
866 if (! STRING_MULTIBYTE (string
))
869 best_below
= best_below_byte
= 0;
870 best_above
= XSTRING (string
)->size
;
871 best_above_byte
= STRING_BYTES (XSTRING (string
));
873 if (EQ (string
, string_char_byte_cache_string
))
875 if (string_char_byte_cache_charpos
< char_index
)
877 best_below
= string_char_byte_cache_charpos
;
878 best_below_byte
= string_char_byte_cache_bytepos
;
882 best_above
= string_char_byte_cache_charpos
;
883 best_above_byte
= string_char_byte_cache_bytepos
;
887 if (char_index
- best_below
< best_above
- char_index
)
889 while (best_below
< char_index
)
892 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
895 i_byte
= best_below_byte
;
899 while (best_above
> char_index
)
901 int best_above_byte_saved
= --best_above_byte
;
903 while (best_above_byte
> 0
904 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
906 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
907 best_above_byte
= best_above_byte_saved
;
911 i_byte
= best_above_byte
;
914 string_char_byte_cache_bytepos
= i_byte
;
915 string_char_byte_cache_charpos
= i
;
916 string_char_byte_cache_string
= string
;
921 /* Return the character index corresponding to BYTE_INDEX in STRING. */
924 string_byte_to_char (string
, byte_index
)
929 int best_below
, best_below_byte
;
930 int best_above
, best_above_byte
;
932 if (! STRING_MULTIBYTE (string
))
935 best_below
= best_below_byte
= 0;
936 best_above
= XSTRING (string
)->size
;
937 best_above_byte
= STRING_BYTES (XSTRING (string
));
939 if (EQ (string
, string_char_byte_cache_string
))
941 if (string_char_byte_cache_bytepos
< byte_index
)
943 best_below
= string_char_byte_cache_charpos
;
944 best_below_byte
= string_char_byte_cache_bytepos
;
948 best_above
= string_char_byte_cache_charpos
;
949 best_above_byte
= string_char_byte_cache_bytepos
;
953 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
955 while (best_below_byte
< byte_index
)
958 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
961 i_byte
= best_below_byte
;
965 while (best_above_byte
> byte_index
)
967 int best_above_byte_saved
= --best_above_byte
;
969 while (best_above_byte
> 0
970 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
972 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
973 best_above_byte
= best_above_byte_saved
;
977 i_byte
= best_above_byte
;
980 string_char_byte_cache_bytepos
= i_byte
;
981 string_char_byte_cache_charpos
= i
;
982 string_char_byte_cache_string
= string
;
987 /* Convert STRING to a multibyte string.
988 Single-byte characters 0240 through 0377 are converted
989 by adding nonascii_insert_offset to each. */
992 string_make_multibyte (string
)
998 if (STRING_MULTIBYTE (string
))
1001 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1002 XSTRING (string
)->size
);
1003 /* If all the chars are ASCII, they won't need any more bytes
1004 once converted. In that case, we can return STRING itself. */
1005 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1008 buf
= (unsigned char *) alloca (nbytes
);
1009 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1012 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1015 /* Convert STRING to a single-byte string. */
1018 string_make_unibyte (string
)
1023 if (! STRING_MULTIBYTE (string
))
1026 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1028 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1031 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1034 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1036 "Return the multibyte equivalent of STRING.\n\
1037 The function `unibyte-char-to-multibyte' is used to convert\n\
1038 each unibyte character to a multibyte character.")
1042 CHECK_STRING (string
, 0);
1044 return string_make_multibyte (string
);
1047 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1049 "Return the unibyte equivalent of STRING.\n\
1050 Multibyte character codes are converted to unibyte\n\
1051 by using just the low 8 bits.")
1055 CHECK_STRING (string
, 0);
1057 return string_make_unibyte (string
);
1060 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1062 "Return a unibyte string with the same individual bytes as STRING.\n\
1063 If STRING is unibyte, the result is STRING itself.\n\
1064 Otherwise it is a newly created string, with no text properties.")
1068 CHECK_STRING (string
, 0);
1070 if (STRING_MULTIBYTE (string
))
1072 string
= Fcopy_sequence (string
);
1073 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1074 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1075 SET_STRING_BYTES (XSTRING (string
), -1);
1080 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1082 "Return a multibyte string with the same individual bytes as STRING.\n\
1083 If STRING is multibyte, the result is STRING itself.\n\
1084 Otherwise it is a newly created string, with no text properties.")
1088 CHECK_STRING (string
, 0);
1090 if (! STRING_MULTIBYTE (string
))
1092 int nbytes
= STRING_BYTES (XSTRING (string
));
1093 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1095 string
= Fcopy_sequence (string
);
1096 XSTRING (string
)->size
= newlen
;
1097 XSTRING (string
)->size_byte
= nbytes
;
1098 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1103 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1104 "Return a copy of ALIST.\n\
1105 This is an alist which represents the same mapping from objects to objects,\n\
1106 but does not share the alist structure with ALIST.\n\
1107 The objects mapped (cars and cdrs of elements of the alist)\n\
1108 are shared, however.\n\
1109 Elements of ALIST that are not conses are also shared.")
1113 register Lisp_Object tem
;
1115 CHECK_LIST (alist
, 0);
1118 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1119 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1121 register Lisp_Object car
;
1122 car
= XCONS (tem
)->car
;
1125 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1130 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1131 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1132 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1133 If FROM or TO is negative, it counts from the end.\n\
1135 This function allows vectors as well as strings.")
1138 register Lisp_Object from
, to
;
1143 int from_char
, to_char
;
1144 int from_byte
, to_byte
;
1146 if (! (STRINGP (string
) || VECTORP (string
)))
1147 wrong_type_argument (Qarrayp
, string
);
1149 CHECK_NUMBER (from
, 1);
1151 if (STRINGP (string
))
1153 size
= XSTRING (string
)->size
;
1154 size_byte
= STRING_BYTES (XSTRING (string
));
1157 size
= XVECTOR (string
)->size
;
1162 to_byte
= size_byte
;
1166 CHECK_NUMBER (to
, 2);
1168 to_char
= XINT (to
);
1172 if (STRINGP (string
))
1173 to_byte
= string_char_to_byte (string
, to_char
);
1176 from_char
= XINT (from
);
1179 if (STRINGP (string
))
1180 from_byte
= string_char_to_byte (string
, from_char
);
1182 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1183 args_out_of_range_3 (string
, make_number (from_char
),
1184 make_number (to_char
));
1186 if (STRINGP (string
))
1188 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1189 to_char
- from_char
, to_byte
- from_byte
,
1190 STRING_MULTIBYTE (string
));
1191 copy_text_properties (make_number (from_char
), make_number (to_char
),
1192 string
, make_number (0), res
, Qnil
);
1195 res
= Fvector (to_char
- from_char
,
1196 XVECTOR (string
)->contents
+ from_char
);
1201 /* Extract a substring of STRING, giving start and end positions
1202 both in characters and in bytes. */
1205 substring_both (string
, from
, from_byte
, to
, to_byte
)
1207 int from
, from_byte
, to
, to_byte
;
1213 if (! (STRINGP (string
) || VECTORP (string
)))
1214 wrong_type_argument (Qarrayp
, string
);
1216 if (STRINGP (string
))
1218 size
= XSTRING (string
)->size
;
1219 size_byte
= STRING_BYTES (XSTRING (string
));
1222 size
= XVECTOR (string
)->size
;
1224 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1225 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1227 if (STRINGP (string
))
1229 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1230 to
- from
, to_byte
- from_byte
,
1231 STRING_MULTIBYTE (string
));
1232 copy_text_properties (make_number (from
), make_number (to
),
1233 string
, make_number (0), res
, Qnil
);
1236 res
= Fvector (to
- from
,
1237 XVECTOR (string
)->contents
+ from
);
1242 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1243 "Take cdr N times on LIST, returns the result.")
1246 register Lisp_Object list
;
1248 register int i
, num
;
1249 CHECK_NUMBER (n
, 0);
1251 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1259 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1260 "Return the Nth element of LIST.\n\
1261 N counts from zero. If LIST is not that long, nil is returned.")
1263 Lisp_Object n
, list
;
1265 return Fcar (Fnthcdr (n
, list
));
1268 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1269 "Return element of SEQUENCE at index N.")
1271 register Lisp_Object sequence
, n
;
1273 CHECK_NUMBER (n
, 0);
1276 if (CONSP (sequence
) || NILP (sequence
))
1277 return Fcar (Fnthcdr (n
, sequence
));
1278 else if (STRINGP (sequence
) || VECTORP (sequence
)
1279 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1280 return Faref (sequence
, n
);
1282 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1286 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1287 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1288 The value is actually the tail of LIST whose car is ELT.")
1290 register Lisp_Object elt
;
1293 register Lisp_Object tail
;
1294 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1296 register Lisp_Object tem
;
1298 if (! NILP (Fequal (elt
, tem
)))
1305 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1306 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1307 The value is actually the tail of LIST whose car is ELT.")
1309 register Lisp_Object elt
;
1312 register Lisp_Object tail
;
1313 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1315 register Lisp_Object tem
;
1317 if (EQ (elt
, tem
)) return tail
;
1323 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1324 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1325 The value is actually the element of LIST whose car is KEY.\n\
1326 Elements of LIST that are not conses are ignored.")
1328 register Lisp_Object key
;
1331 register Lisp_Object tail
;
1332 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1334 register Lisp_Object elt
, tem
;
1336 if (!CONSP (elt
)) continue;
1337 tem
= XCONS (elt
)->car
;
1338 if (EQ (key
, tem
)) return elt
;
1344 /* Like Fassq but never report an error and do not allow quits.
1345 Use only on lists known never to be circular. */
1348 assq_no_quit (key
, list
)
1349 register Lisp_Object key
;
1352 register Lisp_Object tail
;
1353 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1355 register Lisp_Object elt
, tem
;
1357 if (!CONSP (elt
)) continue;
1358 tem
= XCONS (elt
)->car
;
1359 if (EQ (key
, tem
)) return elt
;
1364 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1365 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1366 The value is actually the element of LIST whose car equals KEY.")
1368 register Lisp_Object key
;
1371 register Lisp_Object tail
;
1372 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1374 register Lisp_Object elt
, tem
;
1376 if (!CONSP (elt
)) continue;
1377 tem
= Fequal (XCONS (elt
)->car
, key
);
1378 if (!NILP (tem
)) return elt
;
1384 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1385 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1386 The value is actually the element of LIST whose cdr is ELT.")
1388 register Lisp_Object key
;
1391 register Lisp_Object tail
;
1392 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1394 register Lisp_Object elt
, tem
;
1396 if (!CONSP (elt
)) continue;
1397 tem
= XCONS (elt
)->cdr
;
1398 if (EQ (key
, tem
)) return elt
;
1404 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1405 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1406 The value is actually the element of LIST whose cdr equals KEY.")
1408 register Lisp_Object key
;
1411 register Lisp_Object tail
;
1412 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1414 register Lisp_Object elt
, tem
;
1416 if (!CONSP (elt
)) continue;
1417 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1418 if (!NILP (tem
)) return elt
;
1424 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1425 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1426 The modified LIST is returned. Comparison is done with `eq'.\n\
1427 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1428 therefore, write `(setq foo (delq element foo))'\n\
1429 to be sure of changing the value of `foo'.")
1431 register Lisp_Object elt
;
1434 register Lisp_Object tail
, prev
;
1435 register Lisp_Object tem
;
1439 while (!NILP (tail
))
1445 list
= XCONS (tail
)->cdr
;
1447 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1451 tail
= XCONS (tail
)->cdr
;
1457 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1458 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1459 The modified LIST is returned. Comparison is done with `equal'.\n\
1460 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1461 it is simply using a different list.\n\
1462 Therefore, write `(setq foo (delete element foo))'\n\
1463 to be sure of changing the value of `foo'.")
1465 register Lisp_Object elt
;
1468 register Lisp_Object tail
, prev
;
1469 register Lisp_Object tem
;
1473 while (!NILP (tail
))
1476 if (! NILP (Fequal (elt
, tem
)))
1479 list
= XCONS (tail
)->cdr
;
1481 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1485 tail
= XCONS (tail
)->cdr
;
1491 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1492 "Reverse LIST by modifying cdr pointers.\n\
1493 Returns the beginning of the reversed list.")
1497 register Lisp_Object prev
, tail
, next
;
1499 if (NILP (list
)) return list
;
1502 while (!NILP (tail
))
1506 Fsetcdr (tail
, prev
);
1513 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1514 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1515 See also the function `nreverse', which is used more often.")
1521 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1522 new = Fcons (XCONS (list
)->car
, new);
1524 wrong_type_argument (Qconsp
, list
);
1528 Lisp_Object
merge ();
1530 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1531 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1532 Returns the sorted list. LIST is modified by side effects.\n\
1533 PREDICATE is called with two elements of LIST, and should return T\n\
1534 if the first element is \"less\" than the second.")
1536 Lisp_Object list
, predicate
;
1538 Lisp_Object front
, back
;
1539 register Lisp_Object len
, tem
;
1540 struct gcpro gcpro1
, gcpro2
;
1541 register int length
;
1544 len
= Flength (list
);
1545 length
= XINT (len
);
1549 XSETINT (len
, (length
/ 2) - 1);
1550 tem
= Fnthcdr (len
, list
);
1552 Fsetcdr (tem
, Qnil
);
1554 GCPRO2 (front
, back
);
1555 front
= Fsort (front
, predicate
);
1556 back
= Fsort (back
, predicate
);
1558 return merge (front
, back
, predicate
);
1562 merge (org_l1
, org_l2
, pred
)
1563 Lisp_Object org_l1
, org_l2
;
1567 register Lisp_Object tail
;
1569 register Lisp_Object l1
, l2
;
1570 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1577 /* It is sufficient to protect org_l1 and org_l2.
1578 When l1 and l2 are updated, we copy the new values
1579 back into the org_ vars. */
1580 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1600 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1616 Fsetcdr (tail
, tem
);
1622 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1623 "Extract a value from a property list.\n\
1624 PLIST is a property list, which is a list of the form\n\
1625 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1626 corresponding to the given PROP, or nil if PROP is not\n\
1627 one of the properties on the list.")
1630 register Lisp_Object prop
;
1632 register Lisp_Object tail
;
1633 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1635 register Lisp_Object tem
;
1638 return Fcar (XCONS (tail
)->cdr
);
1643 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1644 "Return the value of SYMBOL's PROPNAME property.\n\
1645 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1647 Lisp_Object symbol
, propname
;
1649 CHECK_SYMBOL (symbol
, 0);
1650 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1653 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1654 "Change value in PLIST of PROP to VAL.\n\
1655 PLIST is a property list, which is a list of the form\n\
1656 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1657 If PROP is already a property on the list, its value is set to VAL,\n\
1658 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1659 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1660 The PLIST is modified by side effects.")
1663 register Lisp_Object prop
;
1666 register Lisp_Object tail
, prev
;
1667 Lisp_Object newcell
;
1669 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1670 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1672 if (EQ (prop
, XCONS (tail
)->car
))
1674 Fsetcar (XCONS (tail
)->cdr
, val
);
1679 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1683 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1687 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1688 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1689 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1690 (symbol
, propname
, value
)
1691 Lisp_Object symbol
, propname
, value
;
1693 CHECK_SYMBOL (symbol
, 0);
1694 XSYMBOL (symbol
)->plist
1695 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1699 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1700 "Return t if two Lisp objects have similar structure and contents.\n\
1701 They must have the same data type.\n\
1702 Conses are compared by comparing the cars and the cdrs.\n\
1703 Vectors and strings are compared element by element.\n\
1704 Numbers are compared by value, but integers cannot equal floats.\n\
1705 (Use `=' if you want integers and floats to be able to be equal.)\n\
1706 Symbols must match exactly.")
1708 register Lisp_Object o1
, o2
;
1710 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1714 internal_equal (o1
, o2
, depth
)
1715 register Lisp_Object o1
, o2
;
1719 error ("Stack overflow in equal");
1725 if (XTYPE (o1
) != XTYPE (o2
))
1730 #ifdef LISP_FLOAT_TYPE
1732 return (extract_float (o1
) == extract_float (o2
));
1736 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1738 o1
= XCONS (o1
)->cdr
;
1739 o2
= XCONS (o2
)->cdr
;
1743 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1747 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1749 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1752 o1
= XOVERLAY (o1
)->plist
;
1753 o2
= XOVERLAY (o2
)->plist
;
1758 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1759 && (XMARKER (o1
)->buffer
== 0
1760 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1764 case Lisp_Vectorlike
:
1766 register int i
, size
;
1767 size
= XVECTOR (o1
)->size
;
1768 /* Pseudovectors have the type encoded in the size field, so this test
1769 actually checks that the objects have the same type as well as the
1771 if (XVECTOR (o2
)->size
!= size
)
1773 /* Boolvectors are compared much like strings. */
1774 if (BOOL_VECTOR_P (o1
))
1777 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1779 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1781 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1786 if (WINDOW_CONFIGURATIONP (o1
))
1787 return compare_window_configurations (o1
, o2
, 0);
1789 /* Aside from them, only true vectors, char-tables, and compiled
1790 functions are sensible to compare, so eliminate the others now. */
1791 if (size
& PSEUDOVECTOR_FLAG
)
1793 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1795 size
&= PSEUDOVECTOR_SIZE_MASK
;
1797 for (i
= 0; i
< size
; i
++)
1800 v1
= XVECTOR (o1
)->contents
[i
];
1801 v2
= XVECTOR (o2
)->contents
[i
];
1802 if (!internal_equal (v1
, v2
, depth
+ 1))
1810 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1812 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1814 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1815 STRING_BYTES (XSTRING (o1
))))
1822 extern Lisp_Object
Fmake_char_internal ();
1824 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1825 "Store each element of ARRAY with ITEM.\n\
1826 ARRAY is a vector, string, char-table, or bool-vector.")
1828 Lisp_Object array
, item
;
1830 register int size
, index
, charval
;
1832 if (VECTORP (array
))
1834 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1835 size
= XVECTOR (array
)->size
;
1836 for (index
= 0; index
< size
; index
++)
1839 else if (CHAR_TABLE_P (array
))
1841 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1842 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1843 for (index
= 0; index
< size
; index
++)
1845 XCHAR_TABLE (array
)->defalt
= Qnil
;
1847 else if (STRINGP (array
))
1849 register unsigned char *p
= XSTRING (array
)->data
;
1850 CHECK_NUMBER (item
, 1);
1851 charval
= XINT (item
);
1852 size
= XSTRING (array
)->size
;
1853 if (STRING_MULTIBYTE (array
))
1855 unsigned char workbuf
[4], *str
;
1856 int len
= CHAR_STRING (charval
, workbuf
, str
);
1857 int size_byte
= STRING_BYTES (XSTRING (array
));
1858 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1861 if (size
!= size_byte
)
1864 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1865 if (len
!= this_len
)
1866 error ("Attempt to change byte length of a string");
1869 for (i
= 0; i
< size_byte
; i
++)
1870 *p
++ = str
[i
% len
];
1873 for (index
= 0; index
< size
; index
++)
1876 else if (BOOL_VECTOR_P (array
))
1878 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1880 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1882 charval
= (! NILP (item
) ? -1 : 0);
1883 for (index
= 0; index
< size_in_chars
; index
++)
1888 array
= wrong_type_argument (Qarrayp
, array
);
1894 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1896 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1898 Lisp_Object char_table
;
1900 CHECK_CHAR_TABLE (char_table
, 0);
1902 return XCHAR_TABLE (char_table
)->purpose
;
1905 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1907 "Return the parent char-table of CHAR-TABLE.\n\
1908 The value is either nil or another char-table.\n\
1909 If CHAR-TABLE holds nil for a given character,\n\
1910 then the actual applicable value is inherited from the parent char-table\n\
1911 \(or from its parents, if necessary).")
1913 Lisp_Object char_table
;
1915 CHECK_CHAR_TABLE (char_table
, 0);
1917 return XCHAR_TABLE (char_table
)->parent
;
1920 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1922 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1923 PARENT must be either nil or another char-table.")
1924 (char_table
, parent
)
1925 Lisp_Object char_table
, parent
;
1929 CHECK_CHAR_TABLE (char_table
, 0);
1933 CHECK_CHAR_TABLE (parent
, 0);
1935 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1936 if (EQ (temp
, char_table
))
1937 error ("Attempt to make a chartable be its own parent");
1940 XCHAR_TABLE (char_table
)->parent
= parent
;
1945 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1947 "Return the value of CHAR-TABLE's extra-slot number N.")
1949 Lisp_Object char_table
, n
;
1951 CHECK_CHAR_TABLE (char_table
, 1);
1952 CHECK_NUMBER (n
, 2);
1954 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1955 args_out_of_range (char_table
, n
);
1957 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1960 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1961 Sset_char_table_extra_slot
,
1963 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1964 (char_table
, n
, value
)
1965 Lisp_Object char_table
, n
, value
;
1967 CHECK_CHAR_TABLE (char_table
, 1);
1968 CHECK_NUMBER (n
, 2);
1970 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1971 args_out_of_range (char_table
, n
);
1973 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1976 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1978 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1979 RANGE should be nil (for the default value)\n\
1980 a vector which identifies a character set or a row of a character set,\n\
1981 a character set name, or a character code.")
1983 Lisp_Object char_table
, range
;
1987 CHECK_CHAR_TABLE (char_table
, 0);
1989 if (EQ (range
, Qnil
))
1990 return XCHAR_TABLE (char_table
)->defalt
;
1991 else if (INTEGERP (range
))
1992 return Faref (char_table
, range
);
1993 else if (SYMBOLP (range
))
1995 Lisp_Object charset_info
;
1997 charset_info
= Fget (range
, Qcharset
);
1998 CHECK_VECTOR (charset_info
, 0);
2000 return Faref (char_table
,
2001 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2004 else if (VECTORP (range
))
2006 if (XVECTOR (range
)->size
== 1)
2007 return Faref (char_table
,
2008 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2011 int size
= XVECTOR (range
)->size
;
2012 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2013 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2014 size
<= 1 ? Qnil
: val
[1],
2015 size
<= 2 ? Qnil
: val
[2]);
2016 return Faref (char_table
, ch
);
2020 error ("Invalid RANGE argument to `char-table-range'");
2023 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2025 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2026 RANGE should be t (for all characters), nil (for the default value)\n\
2027 a vector which identifies a character set or a row of a character set,\n\
2028 a coding system, or a character code.")
2029 (char_table
, range
, value
)
2030 Lisp_Object char_table
, range
, value
;
2034 CHECK_CHAR_TABLE (char_table
, 0);
2037 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2038 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2039 else if (EQ (range
, Qnil
))
2040 XCHAR_TABLE (char_table
)->defalt
= value
;
2041 else if (SYMBOLP (range
))
2043 Lisp_Object charset_info
;
2045 charset_info
= Fget (range
, Qcharset
);
2046 CHECK_VECTOR (charset_info
, 0);
2048 return Faset (char_table
,
2049 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2053 else if (INTEGERP (range
))
2054 Faset (char_table
, range
, value
);
2055 else if (VECTORP (range
))
2057 if (XVECTOR (range
)->size
== 1)
2058 return Faset (char_table
,
2059 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2063 int size
= XVECTOR (range
)->size
;
2064 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2065 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2066 size
<= 1 ? Qnil
: val
[1],
2067 size
<= 2 ? Qnil
: val
[2]);
2068 return Faset (char_table
, ch
, value
);
2072 error ("Invalid RANGE argument to `set-char-table-range'");
2077 DEFUN ("set-char-table-default", Fset_char_table_default
,
2078 Sset_char_table_default
, 3, 3, 0,
2079 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2080 The generic character specifies the group of characters.\n\
2081 See also the documentation of make-char.")
2082 (char_table
, ch
, value
)
2083 Lisp_Object char_table
, ch
, value
;
2085 int c
, i
, charset
, code1
, code2
;
2088 CHECK_CHAR_TABLE (char_table
, 0);
2089 CHECK_NUMBER (ch
, 1);
2092 SPLIT_CHAR (c
, charset
, code1
, code2
);
2094 /* Since we may want to set the default value for a character set
2095 not yet defined, we check only if the character set is in the
2096 valid range or not, instead of it is already defined or not. */
2097 if (! CHARSET_VALID_P (charset
))
2098 invalid_character (c
);
2100 if (charset
== CHARSET_ASCII
)
2101 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2103 /* Even if C is not a generic char, we had better behave as if a
2104 generic char is specified. */
2105 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2107 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2110 if (SUB_CHAR_TABLE_P (temp
))
2111 XCHAR_TABLE (temp
)->defalt
= value
;
2113 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2117 if (! SUB_CHAR_TABLE_P (char_table
))
2118 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2119 = make_sub_char_table (temp
));
2120 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2121 if (SUB_CHAR_TABLE_P (temp
))
2122 XCHAR_TABLE (temp
)->defalt
= value
;
2124 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2128 /* Look up the element in TABLE at index CH,
2129 and return it as an integer.
2130 If the element is nil, return CH itself.
2131 (Actually we do that for any non-integer.) */
2134 char_table_translate (table
, ch
)
2139 value
= Faref (table
, make_number (ch
));
2140 if (! INTEGERP (value
))
2142 return XINT (value
);
2145 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2146 character or group of characters that share a value.
2147 DEPTH is the current depth in the originally specified
2148 chartable, and INDICES contains the vector indices
2149 for the levels our callers have descended.
2151 ARG is passed to C_FUNCTION when that is called. */
2154 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2155 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2156 Lisp_Object function
, subtable
, arg
, *indices
;
2163 /* At first, handle ASCII and 8-bit European characters. */
2164 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2166 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2168 (*c_function
) (arg
, make_number (i
), elt
);
2170 call2 (function
, make_number (i
), elt
);
2172 #if 0 /* If the char table has entries for higher characters,
2173 we should report them. */
2174 if (NILP (current_buffer
->enable_multibyte_characters
))
2177 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2182 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2187 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2189 XSETFASTINT (indices
[depth
], i
);
2191 if (SUB_CHAR_TABLE_P (elt
))
2194 error ("Too deep char table");
2195 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2199 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2201 if (CHARSET_DEFINED_P (charset
))
2203 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2204 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2205 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2207 (*c_function
) (arg
, make_number (c
), elt
);
2209 call2 (function
, make_number (c
), elt
);
2215 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2217 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2218 FUNCTION is called with two arguments--a key and a value.\n\
2219 The key is always a possible IDX argument to `aref'.")
2220 (function
, char_table
)
2221 Lisp_Object function
, char_table
;
2223 /* The depth of char table is at most 3. */
2224 Lisp_Object indices
[3];
2226 CHECK_CHAR_TABLE (char_table
, 1);
2228 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2238 Lisp_Object args
[2];
2241 return Fnconc (2, args
);
2243 return Fnconc (2, &s1
);
2244 #endif /* NO_ARG_ARRAY */
2247 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2248 "Concatenate any number of lists by altering them.\n\
2249 Only the last argument is not altered, and need not be a list.")
2254 register int argnum
;
2255 register Lisp_Object tail
, tem
, val
;
2259 for (argnum
= 0; argnum
< nargs
; argnum
++)
2262 if (NILP (tem
)) continue;
2267 if (argnum
+ 1 == nargs
) break;
2270 tem
= wrong_type_argument (Qlistp
, tem
);
2279 tem
= args
[argnum
+ 1];
2280 Fsetcdr (tail
, tem
);
2282 args
[argnum
+ 1] = tail
;
2288 /* This is the guts of all mapping functions.
2289 Apply FN to each element of SEQ, one by one,
2290 storing the results into elements of VALS, a C vector of Lisp_Objects.
2291 LENI is the length of VALS, which should also be the length of SEQ. */
2294 mapcar1 (leni
, vals
, fn
, seq
)
2297 Lisp_Object fn
, seq
;
2299 register Lisp_Object tail
;
2302 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2304 /* Don't let vals contain any garbage when GC happens. */
2305 for (i
= 0; i
< leni
; i
++)
2308 GCPRO3 (dummy
, fn
, seq
);
2310 gcpro1
.nvars
= leni
;
2311 /* We need not explicitly protect `tail' because it is used only on lists, and
2312 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2316 for (i
= 0; i
< leni
; i
++)
2318 dummy
= XVECTOR (seq
)->contents
[i
];
2319 vals
[i
] = call1 (fn
, dummy
);
2322 else if (BOOL_VECTOR_P (seq
))
2324 for (i
= 0; i
< leni
; i
++)
2327 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2328 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2333 vals
[i
] = call1 (fn
, dummy
);
2336 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2338 /* Single-byte string. */
2339 for (i
= 0; i
< leni
; i
++)
2341 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2342 vals
[i
] = call1 (fn
, dummy
);
2345 else if (STRINGP (seq
))
2347 /* Multi-byte string. */
2348 int len_byte
= STRING_BYTES (XSTRING (seq
));
2351 for (i
= 0, i_byte
= 0; i
< leni
;)
2356 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2357 XSETFASTINT (dummy
, c
);
2358 vals
[i_before
] = call1 (fn
, dummy
);
2361 else /* Must be a list, since Flength did not get an error */
2364 for (i
= 0; i
< leni
; i
++)
2366 vals
[i
] = call1 (fn
, Fcar (tail
));
2367 tail
= XCONS (tail
)->cdr
;
2374 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2375 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2376 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2377 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2378 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2379 (function
, sequence
, separator
)
2380 Lisp_Object function
, sequence
, separator
;
2385 register Lisp_Object
*args
;
2387 struct gcpro gcpro1
;
2389 len
= Flength (sequence
);
2391 nargs
= leni
+ leni
- 1;
2392 if (nargs
< 0) return build_string ("");
2394 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2397 mapcar1 (leni
, args
, function
, sequence
);
2400 for (i
= leni
- 1; i
>= 0; i
--)
2401 args
[i
+ i
] = args
[i
];
2403 for (i
= 1; i
< nargs
; i
+= 2)
2404 args
[i
] = separator
;
2406 return Fconcat (nargs
, args
);
2409 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2410 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2411 The result is a list just as long as SEQUENCE.\n\
2412 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2413 (function
, sequence
)
2414 Lisp_Object function
, sequence
;
2416 register Lisp_Object len
;
2418 register Lisp_Object
*args
;
2420 len
= Flength (sequence
);
2421 leni
= XFASTINT (len
);
2422 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2424 mapcar1 (leni
, args
, function
, sequence
);
2426 return Flist (leni
, args
);
2429 /* Anything that calls this function must protect from GC! */
2431 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2432 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2433 Takes one argument, which is the string to display to ask the question.\n\
2434 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2435 No confirmation of the answer is requested; a single character is enough.\n\
2436 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2437 the bindings in query-replace-map; see the documentation of that variable\n\
2438 for more information. In this case, the useful bindings are `act', `skip',\n\
2439 `recenter', and `quit'.\)\n\
2441 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2446 register Lisp_Object obj
, key
, def
, map
;
2447 register int answer
;
2448 Lisp_Object xprompt
;
2449 Lisp_Object args
[2];
2450 struct gcpro gcpro1
, gcpro2
;
2451 int count
= specpdl_ptr
- specpdl
;
2453 specbind (Qcursor_in_echo_area
, Qt
);
2455 map
= Fsymbol_value (intern ("query-replace-map"));
2457 CHECK_STRING (prompt
, 0);
2459 GCPRO2 (prompt
, xprompt
);
2465 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2469 Lisp_Object pane
, menu
;
2470 redisplay_preserve_echo_area ();
2471 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2472 Fcons (Fcons (build_string ("No"), Qnil
),
2474 menu
= Fcons (prompt
, pane
);
2475 obj
= Fx_popup_dialog (Qt
, menu
);
2476 answer
= !NILP (obj
);
2479 #endif /* HAVE_MENUS */
2480 cursor_in_echo_area
= 1;
2481 choose_minibuf_frame ();
2482 message_with_string ("%s(y or n) ", xprompt
, 0);
2484 if (minibuffer_auto_raise
)
2486 Lisp_Object mini_frame
;
2488 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2490 Fraise_frame (mini_frame
);
2493 obj
= read_filtered_event (1, 0, 0, 0);
2494 cursor_in_echo_area
= 0;
2495 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2498 key
= Fmake_vector (make_number (1), obj
);
2499 def
= Flookup_key (map
, key
, Qt
);
2501 if (EQ (def
, intern ("skip")))
2506 else if (EQ (def
, intern ("act")))
2511 else if (EQ (def
, intern ("recenter")))
2517 else if (EQ (def
, intern ("quit")))
2519 /* We want to exit this command for exit-prefix,
2520 and this is the only way to do it. */
2521 else if (EQ (def
, intern ("exit-prefix")))
2526 /* If we don't clear this, then the next call to read_char will
2527 return quit_char again, and we'll enter an infinite loop. */
2532 if (EQ (xprompt
, prompt
))
2534 args
[0] = build_string ("Please answer y or n. ");
2536 xprompt
= Fconcat (2, args
);
2541 if (! noninteractive
)
2543 cursor_in_echo_area
= -1;
2544 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2548 unbind_to (count
, Qnil
);
2549 return answer
? Qt
: Qnil
;
2552 /* This is how C code calls `yes-or-no-p' and allows the user
2555 Anything that calls this function must protect from GC! */
2558 do_yes_or_no_p (prompt
)
2561 return call1 (intern ("yes-or-no-p"), prompt
);
2564 /* Anything that calls this function must protect from GC! */
2566 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2567 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2568 Takes one argument, which is the string to display to ask the question.\n\
2569 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2570 The user must confirm the answer with RET,\n\
2571 and can edit it until it has been confirmed.\n\
2573 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2578 register Lisp_Object ans
;
2579 Lisp_Object args
[2];
2580 struct gcpro gcpro1
;
2583 CHECK_STRING (prompt
, 0);
2586 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2590 Lisp_Object pane
, menu
, obj
;
2591 redisplay_preserve_echo_area ();
2592 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2593 Fcons (Fcons (build_string ("No"), Qnil
),
2596 menu
= Fcons (prompt
, pane
);
2597 obj
= Fx_popup_dialog (Qt
, menu
);
2601 #endif /* HAVE_MENUS */
2604 args
[1] = build_string ("(yes or no) ");
2605 prompt
= Fconcat (2, args
);
2611 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2612 Qyes_or_no_p_history
, Qnil
,
2614 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2619 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2627 message ("Please answer yes or no.");
2628 Fsleep_for (make_number (2), Qnil
);
2632 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2633 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2634 Each of the three load averages is multiplied by 100,\n\
2635 then converted to integer.\n\
2636 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2637 These floats are not multiplied by 100.\n\n\
2638 If the 5-minute or 15-minute load averages are not available, return a\n\
2639 shortened list, containing only those averages which are available.")
2641 Lisp_Object use_floats
;
2644 int loads
= getloadavg (load_ave
, 3);
2645 Lisp_Object ret
= Qnil
;
2648 error ("load-average not implemented for this operating system");
2652 Lisp_Object load
= (NILP (use_floats
) ?
2653 make_number ((int) (100.0 * load_ave
[loads
]))
2654 : make_float (load_ave
[loads
]));
2655 ret
= Fcons (load
, ret
);
2661 Lisp_Object Vfeatures
;
2663 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2664 "Returns t if FEATURE is present in this Emacs.\n\
2665 Use this to conditionalize execution of lisp code based on the presence or\n\
2666 absence of emacs or environment extensions.\n\
2667 Use `provide' to declare that a feature is available.\n\
2668 This function looks at the value of the variable `features'.")
2670 Lisp_Object feature
;
2672 register Lisp_Object tem
;
2673 CHECK_SYMBOL (feature
, 0);
2674 tem
= Fmemq (feature
, Vfeatures
);
2675 return (NILP (tem
)) ? Qnil
: Qt
;
2678 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2679 "Announce that FEATURE is a feature of the current Emacs.")
2681 Lisp_Object feature
;
2683 register Lisp_Object tem
;
2684 CHECK_SYMBOL (feature
, 0);
2685 if (!NILP (Vautoload_queue
))
2686 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2687 tem
= Fmemq (feature
, Vfeatures
);
2689 Vfeatures
= Fcons (feature
, Vfeatures
);
2690 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2694 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2695 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2696 If FEATURE is not a member of the list `features', then the feature\n\
2697 is not loaded; so load the file FILENAME.\n\
2698 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2699 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2700 If the optional third argument NOERROR is non-nil,\n\
2701 then return nil if the file is not found.\n\
2702 Normally the return value is FEATURE.")
2703 (feature
, file_name
, noerror
)
2704 Lisp_Object feature
, file_name
, noerror
;
2706 register Lisp_Object tem
;
2707 CHECK_SYMBOL (feature
, 0);
2708 tem
= Fmemq (feature
, Vfeatures
);
2709 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2712 int count
= specpdl_ptr
- specpdl
;
2714 /* Value saved here is to be restored into Vautoload_queue */
2715 record_unwind_protect (un_autoload
, Vautoload_queue
);
2716 Vautoload_queue
= Qt
;
2718 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2719 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2720 /* If load failed entirely, return nil. */
2722 return unbind_to (count
, Qnil
);
2724 tem
= Fmemq (feature
, Vfeatures
);
2726 error ("Required feature %s was not provided",
2727 XSYMBOL (feature
)->name
->data
);
2729 /* Once loading finishes, don't undo it. */
2730 Vautoload_queue
= Qt
;
2731 feature
= unbind_to (count
, feature
);
2736 /* Primitives for work of the "widget" library.
2737 In an ideal world, this section would not have been necessary.
2738 However, lisp function calls being as slow as they are, it turns
2739 out that some functions in the widget library (wid-edit.el) are the
2740 bottleneck of Widget operation. Here is their translation to C,
2741 for the sole reason of efficiency. */
2743 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2744 "Return non-nil if PLIST has the property PROP.\n\
2745 PLIST is a property list, which is a list of the form\n\
2746 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2747 Unlike `plist-get', this allows you to distinguish between a missing\n\
2748 property and a property with the value nil.\n\
2749 The value is actually the tail of PLIST whose car is PROP.")
2751 Lisp_Object plist
, prop
;
2753 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2756 plist
= XCDR (plist
);
2757 plist
= CDR (plist
);
2762 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2763 "In WIDGET, set PROPERTY to VALUE.\n\
2764 The value can later be retrieved with `widget-get'.")
2765 (widget
, property
, value
)
2766 Lisp_Object widget
, property
, value
;
2768 CHECK_CONS (widget
, 1);
2769 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2773 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2774 "In WIDGET, get the value of PROPERTY.\n\
2775 The value could either be specified when the widget was created, or\n\
2776 later with `widget-put'.")
2778 Lisp_Object widget
, property
;
2786 CHECK_CONS (widget
, 1);
2787 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2793 tmp
= XCAR (widget
);
2796 widget
= Fget (tmp
, Qwidget_type
);
2800 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2801 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2802 ARGS are passed as extra arguments to the function.")
2807 /* This function can GC. */
2808 Lisp_Object newargs
[3];
2809 struct gcpro gcpro1
, gcpro2
;
2812 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2813 newargs
[1] = args
[0];
2814 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2815 GCPRO2 (newargs
[0], newargs
[2]);
2816 result
= Fapply (3, newargs
);
2821 /* base64 encode/decode functions.
2822 Based on code from GNU recode. */
2824 #define MIME_LINE_LENGTH 76
2826 #define IS_ASCII(Character) \
2828 #define IS_BASE64(Character) \
2829 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2830 #define IS_BASE64_IGNORABLE(Character) \
2831 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2832 || (Character) == '\f' || (Character) == '\r')
2834 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2835 character or return retval if there are no characters left to
2837 #define READ_QUADRUPLET_BYTE(retval) \
2844 while (IS_BASE64_IGNORABLE (c))
2846 /* Don't use alloca for regions larger than this, lest we overflow
2848 #define MAX_ALLOCA 16*1024
2850 /* Table of characters coding the 64 values. */
2851 static char base64_value_to_char
[64] =
2853 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2854 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2855 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2856 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2857 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2858 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2859 '8', '9', '+', '/' /* 60-63 */
2862 /* Table of base64 values for first 128 characters. */
2863 static short base64_char_to_value
[128] =
2865 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2866 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2867 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2868 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2869 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2870 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2871 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2872 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2873 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2874 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2875 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2876 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2877 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2880 /* The following diagram shows the logical steps by which three octets
2881 get transformed into four base64 characters.
2883 .--------. .--------. .--------.
2884 |aaaaaabb| |bbbbcccc| |ccdddddd|
2885 `--------' `--------' `--------'
2887 .--------+--------+--------+--------.
2888 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2889 `--------+--------+--------+--------'
2891 .--------+--------+--------+--------.
2892 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2893 `--------+--------+--------+--------'
2895 The octets are divided into 6 bit chunks, which are then encoded into
2896 base64 characters. */
2899 static int base64_encode_1
P_ ((const char *, char *, int, int));
2900 static int base64_decode_1
P_ ((const char *, char *, int));
2902 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2904 "Base64-encode the region between BEG and END.\n\
2905 Return the length of the encoded text.\n\
2906 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2907 into shorter lines.")
2908 (beg
, end
, no_line_break
)
2909 Lisp_Object beg
, end
, no_line_break
;
2912 int allength
, length
;
2913 int ibeg
, iend
, encoded_length
;
2916 validate_region (&beg
, &end
);
2918 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2919 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2920 move_gap_both (XFASTINT (beg
), ibeg
);
2922 /* We need to allocate enough room for encoding the text.
2923 We need 33 1/3% more space, plus a newline every 76
2924 characters, and then we round up. */
2925 length
= iend
- ibeg
;
2926 allength
= length
+ length
/3 + 1;
2927 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2929 if (allength
<= MAX_ALLOCA
)
2930 encoded
= (char *) alloca (allength
);
2932 encoded
= (char *) xmalloc (allength
);
2933 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2934 NILP (no_line_break
));
2935 if (encoded_length
> allength
)
2938 /* Now we have encoded the region, so we insert the new contents
2939 and delete the old. (Insert first in order to preserve markers.) */
2940 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2941 insert (encoded
, encoded_length
);
2942 if (allength
> MAX_ALLOCA
)
2944 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2946 /* If point was outside of the region, restore it exactly; else just
2947 move to the beginning of the region. */
2948 if (old_pos
>= XFASTINT (end
))
2949 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2950 else if (old_pos
> XFASTINT (beg
))
2951 old_pos
= XFASTINT (beg
);
2954 /* We return the length of the encoded text. */
2955 return make_number (encoded_length
);
2958 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2960 "Base64-encode STRING and return the result.\n\
2961 Optional second argument NO-LINE-BREAK means do not break long lines\n\
2962 into shorter lines.")
2963 (string
, no_line_break
)
2964 Lisp_Object string
, no_line_break
;
2966 int allength
, length
, encoded_length
;
2968 Lisp_Object encoded_string
;
2970 CHECK_STRING (string
, 1);
2972 /* We need to allocate enough room for encoding the text.
2973 We need 33 1/3% more space, plus a newline every 76
2974 characters, and then we round up. */
2975 length
= STRING_BYTES (XSTRING (string
));
2976 allength
= length
+ length
/3 + 1;
2977 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2979 /* We need to allocate enough room for decoding the text. */
2980 if (allength
<= MAX_ALLOCA
)
2981 encoded
= (char *) alloca (allength
);
2983 encoded
= (char *) xmalloc (allength
);
2985 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2986 encoded
, length
, NILP (no_line_break
));
2987 if (encoded_length
> allength
)
2990 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
2991 if (allength
> MAX_ALLOCA
)
2994 return encoded_string
;
2998 base64_encode_1 (from
, to
, length
, line_break
)
3004 int counter
= 0, i
= 0;
3013 /* Wrap line every 76 characters. */
3017 if (counter
< MIME_LINE_LENGTH
/ 4)
3026 /* Process first byte of a triplet. */
3028 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3029 value
= (0x03 & c
) << 4;
3031 /* Process second byte of a triplet. */
3035 *e
++ = base64_value_to_char
[value
];
3043 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3044 value
= (0x0f & c
) << 2;
3046 /* Process third byte of a triplet. */
3050 *e
++ = base64_value_to_char
[value
];
3057 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3058 *e
++ = base64_value_to_char
[0x3f & c
];
3065 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3067 "Base64-decode the region between BEG and END.\n\
3068 Return the length of the decoded text.\n\
3069 If the region can't be decoded, return nil and don't modify the buffer.")
3071 Lisp_Object beg
, end
;
3073 int ibeg
, iend
, length
;
3079 validate_region (&beg
, &end
);
3081 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3082 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3084 length
= iend
- ibeg
;
3085 /* We need to allocate enough room for decoding the text. */
3086 if (length
<= MAX_ALLOCA
)
3087 decoded
= (char *) alloca (length
);
3089 decoded
= (char *) xmalloc (length
);
3091 move_gap_both (XFASTINT (beg
), ibeg
);
3092 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3093 if (decoded_length
> length
)
3096 if (decoded_length
< 0)
3098 /* The decoding wasn't possible. */
3099 if (length
> MAX_ALLOCA
)
3104 /* Now we have decoded the region, so we insert the new contents
3105 and delete the old. (Insert first in order to preserve markers.) */
3106 /* We insert two spaces, then insert the decoded text in between
3107 them, at last, delete those extra two spaces. This is to avoid
3108 byte combining while inserting. */
3109 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3110 insert_1_both (" ", 2, 2, 0, 1, 0);
3111 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3112 insert (decoded
, decoded_length
);
3113 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3114 if (length
> MAX_ALLOCA
)
3116 /* At first delete the original text. This never cause byte
3118 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3119 iend
+ decoded_length
+ 2, 1);
3120 /* Next delete the extra spaces. This will cause byte combining
3122 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3123 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3124 inserted_chars
= PT
- XFASTINT (beg
);
3126 /* If point was outside of the region, restore it exactly; else just
3127 move to the beginning of the region. */
3128 if (old_pos
>= XFASTINT (end
))
3129 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3130 else if (old_pos
> XFASTINT (beg
))
3131 old_pos
= XFASTINT (beg
);
3134 return make_number (inserted_chars
);
3137 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3139 "Base64-decode STRING and return the result.")
3144 int length
, decoded_length
;
3145 Lisp_Object decoded_string
;
3147 CHECK_STRING (string
, 1);
3149 length
= STRING_BYTES (XSTRING (string
));
3150 /* We need to allocate enough room for decoding the text. */
3151 if (length
<= MAX_ALLOCA
)
3152 decoded
= (char *) alloca (length
);
3154 decoded
= (char *) xmalloc (length
);
3156 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3157 if (decoded_length
> length
)
3160 if (decoded_length
< 0)
3161 /* The decoding wasn't possible. */
3162 decoded_string
= Qnil
;
3164 decoded_string
= make_string (decoded
, decoded_length
);
3166 if (length
> MAX_ALLOCA
)
3169 return decoded_string
;
3173 base64_decode_1 (from
, to
, length
)
3181 unsigned long value
;
3185 /* Process first byte of a quadruplet. */
3187 READ_QUADRUPLET_BYTE (e
-to
);
3191 value
= base64_char_to_value
[c
] << 18;
3193 /* Process second byte of a quadruplet. */
3195 READ_QUADRUPLET_BYTE (-1);
3199 value
|= base64_char_to_value
[c
] << 12;
3201 *e
++ = (unsigned char) (value
>> 16);
3203 /* Process third byte of a quadruplet. */
3205 READ_QUADRUPLET_BYTE (-1);
3209 READ_QUADRUPLET_BYTE (-1);
3218 value
|= base64_char_to_value
[c
] << 6;
3220 *e
++ = (unsigned char) (0xff & value
>> 8);
3222 /* Process fourth byte of a quadruplet. */
3224 READ_QUADRUPLET_BYTE (-1);
3231 value
|= base64_char_to_value
[c
];
3233 *e
++ = (unsigned char) (0xff & value
);
3239 /***********************************************************************
3241 ***** Hash Tables *****
3243 ***********************************************************************/
3245 /* Implemented by gerd@gnu.org. This hash table implementation was
3246 inspired by CMUCL hash tables. */
3250 1. For small tables, association lists are probably faster than
3251 hash tables because they have lower overhead.
3253 For uses of hash tables where the O(1) behavior of table
3254 operations is not a requirement, it might therefore be a good idea
3255 not to hash. Instead, we could just do a linear search in the
3256 key_and_value vector of the hash table. This could be done
3257 if a `:linear-search t' argument is given to make-hash-table. */
3260 /* Return the contents of vector V at index IDX. */
3262 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3264 /* Value is the key part of entry IDX in hash table H. */
3266 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3268 /* Value is the value part of entry IDX in hash table H. */
3270 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3272 /* Value is the index of the next entry following the one at IDX
3275 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3277 /* Value is the hash code computed for entry IDX in hash table H. */
3279 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3281 /* Value is the index of the element in hash table H that is the
3282 start of the collision list at index IDX in the index vector of H. */
3284 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3286 /* Value is the size of hash table H. */
3288 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3290 /* The list of all weak hash tables. Don't staticpro this one. */
3292 Lisp_Object Vweak_hash_tables
;
3294 /* Various symbols. */
3296 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3297 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweak
;
3298 Lisp_Object Qhash_table_test
;
3300 /* Function prototypes. */
3302 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3303 static int next_almost_prime
P_ ((int));
3304 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3305 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3306 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3307 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3308 Lisp_Object
, unsigned));
3309 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3310 Lisp_Object
, unsigned));
3311 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3312 unsigned, Lisp_Object
, unsigned));
3313 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3314 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3315 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3316 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3318 static unsigned sxhash_string
P_ ((unsigned char *, int));
3319 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3320 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3321 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3325 /***********************************************************************
3327 ***********************************************************************/
3329 /* If OBJ is a Lisp hash table, return a pointer to its struct
3330 Lisp_Hash_Table. Otherwise, signal an error. */
3332 static struct Lisp_Hash_Table
*
3333 check_hash_table (obj
)
3336 CHECK_HASH_TABLE (obj
, 0);
3337 return XHASH_TABLE (obj
);
3341 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3345 next_almost_prime (n
)
3358 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3359 which USED[I] is non-zero. If found at index I in ARGS, set
3360 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3361 -1. This function is used to extract a keyword/argument pair from
3362 a DEFUN parameter list. */
3365 get_key_arg (key
, nargs
, args
, used
)
3373 for (i
= 0; i
< nargs
- 1; ++i
)
3374 if (!used
[i
] && EQ (args
[i
], key
))
3389 /* Return a Lisp vector which has the same contents as VEC but has
3390 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3391 vector that are not copied from VEC are set to INIT. */
3394 larger_vector (vec
, new_size
, init
)
3399 struct Lisp_Vector
*v
;
3402 xassert (VECTORP (vec
));
3403 old_size
= XVECTOR (vec
)->size
;
3404 xassert (new_size
>= old_size
);
3406 v
= allocate_vectorlike (new_size
);
3408 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3409 old_size
* sizeof *v
->contents
);
3410 for (i
= old_size
; i
< new_size
; ++i
)
3411 v
->contents
[i
] = init
;
3412 XSETVECTOR (vec
, v
);
3417 /***********************************************************************
3419 ***********************************************************************/
3421 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3422 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3423 KEY2 are the same. */
3426 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3427 struct Lisp_Hash_Table
*h
;
3428 Lisp_Object key1
, key2
;
3429 unsigned hash1
, hash2
;
3431 return (FLOATP (key1
)
3433 && XFLOAT (key1
)->data
== XFLOAT (key2
)->data
);
3437 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3438 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3439 KEY2 are the same. */
3442 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3443 struct Lisp_Hash_Table
*h
;
3444 Lisp_Object key1
, key2
;
3445 unsigned hash1
, hash2
;
3447 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3451 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3452 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3453 if KEY1 and KEY2 are the same. */
3456 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3457 struct Lisp_Hash_Table
*h
;
3458 Lisp_Object key1
, key2
;
3459 unsigned hash1
, hash2
;
3463 Lisp_Object args
[3];
3465 args
[0] = h
->user_cmp_function
;
3468 return !NILP (Ffuncall (3, args
));
3475 /* Value is a hash code for KEY for use in hash table H which uses
3476 `eq' to compare keys. The hash code returned is guaranteed to fit
3477 in a Lisp integer. */
3481 struct Lisp_Hash_Table
*h
;
3484 /* Lisp strings can change their address. Don't try to compute a
3485 hash code for a string from its address. */
3487 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3489 return XUINT (key
) ^ XGCTYPE (key
);
3493 /* Value is a hash code for KEY for use in hash table H which uses
3494 `eql' to compare keys. The hash code returned is guaranteed to fit
3495 in a Lisp integer. */
3499 struct Lisp_Hash_Table
*h
;
3502 /* Lisp strings can change their address. Don't try to compute a
3503 hash code for a string from its address. */
3505 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3506 else if (FLOATP (key
))
3507 return sxhash (key
, 0);
3509 return XUINT (key
) ^ XGCTYPE (key
);
3513 /* Value is a hash code for KEY for use in hash table H which uses
3514 `equal' to compare keys. The hash code returned is guaranteed to fit
3515 in a Lisp integer. */
3518 hashfn_equal (h
, key
)
3519 struct Lisp_Hash_Table
*h
;
3522 return sxhash (key
, 0);
3526 /* Value is a hash code for KEY for use in hash table H which uses as
3527 user-defined function to compare keys. The hash code returned is
3528 guaranteed to fit in a Lisp integer. */
3531 hashfn_user_defined (h
, key
)
3532 struct Lisp_Hash_Table
*h
;
3535 Lisp_Object args
[2], hash
;
3537 args
[0] = h
->user_hash_function
;
3539 hash
= Ffuncall (2, args
);
3540 if (!INTEGERP (hash
))
3542 list2 (build_string ("Illegal hash code returned from \
3543 user-supplied hash function"),
3545 return XUINT (hash
);
3549 /* Create and initialize a new hash table.
3551 TEST specifies the test the hash table will use to compare keys.
3552 It must be either one of the predefined tests `eq', `eql' or
3553 `equal' or a symbol denoting a user-defined test named TEST with
3554 test and hash functions USER_TEST and USER_HASH.
3556 Give the table initial capacity SIZE, SIZE > 0, an integer.
3558 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3559 new size when it becomes full is computed by adding REHASH_SIZE to
3560 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3561 table's new size is computed by multiplying its old size with
3564 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3565 be resized when the ratio of (number of entries in the table) /
3566 (table size) is >= REHASH_THRESHOLD.
3568 WEAK specifies the weakness of the table. If non-nil, it must be
3569 one of the symbols `key', `value' or t. */
3572 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3573 user_test
, user_hash
)
3574 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3575 Lisp_Object user_test
, user_hash
;
3577 struct Lisp_Hash_Table
*h
;
3578 struct Lisp_Vector
*v
;
3580 int index_size
, i
, len
, sz
;
3582 /* Preconditions. */
3583 xassert (SYMBOLP (test
));
3584 xassert (INTEGERP (size
) && XINT (size
) > 0);
3585 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3586 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3587 xassert (FLOATP (rehash_threshold
)
3588 && XFLOATINT (rehash_threshold
) > 0
3589 && XFLOATINT (rehash_threshold
) <= 1.0);
3591 /* Allocate a vector, and initialize it. */
3592 len
= VECSIZE (struct Lisp_Hash_Table
);
3593 v
= allocate_vectorlike (len
);
3595 for (i
= 0; i
< len
; ++i
)
3596 v
->contents
[i
] = Qnil
;
3598 /* Initialize hash table slots. */
3599 sz
= XFASTINT (size
);
3600 h
= (struct Lisp_Hash_Table
*) v
;
3603 if (EQ (test
, Qeql
))
3605 h
->cmpfn
= cmpfn_eql
;
3606 h
->hashfn
= hashfn_eql
;
3608 else if (EQ (test
, Qeq
))
3611 h
->hashfn
= hashfn_eq
;
3613 else if (EQ (test
, Qequal
))
3615 h
->cmpfn
= cmpfn_equal
;
3616 h
->hashfn
= hashfn_equal
;
3620 h
->user_cmp_function
= user_test
;
3621 h
->user_hash_function
= user_hash
;
3622 h
->cmpfn
= cmpfn_user_defined
;
3623 h
->hashfn
= hashfn_user_defined
;
3627 h
->rehash_threshold
= rehash_threshold
;
3628 h
->rehash_size
= rehash_size
;
3629 h
->count
= make_number (0);
3630 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3631 h
->hash
= Fmake_vector (size
, Qnil
);
3632 h
->next
= Fmake_vector (size
, Qnil
);
3633 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3634 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3636 /* Set up the free list. */
3637 for (i
= 0; i
< sz
- 1; ++i
)
3638 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3639 h
->next_free
= make_number (0);
3641 XSET_HASH_TABLE (table
, h
);
3642 xassert (HASH_TABLE_P (table
));
3643 xassert (XHASH_TABLE (table
) == h
);
3645 /* Maybe add this hash table to the list of all weak hash tables. */
3647 h
->next_weak
= Qnil
;
3650 h
->next_weak
= Vweak_hash_tables
;
3651 Vweak_hash_tables
= table
;
3658 /* Return a copy of hash table H1. Keys and values are not copied,
3659 only the table itself is. */
3662 copy_hash_table (h1
)
3663 struct Lisp_Hash_Table
*h1
;
3666 struct Lisp_Hash_Table
*h2
;
3667 struct Lisp_Vector
*v
, *next
;
3670 len
= VECSIZE (struct Lisp_Hash_Table
);
3671 v
= allocate_vectorlike (len
);
3672 h2
= (struct Lisp_Hash_Table
*) v
;
3673 next
= h2
->vec_next
;
3674 bcopy (h1
, h2
, sizeof *h2
);
3675 h2
->vec_next
= next
;
3676 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3677 h2
->hash
= Fcopy_sequence (h1
->hash
);
3678 h2
->next
= Fcopy_sequence (h1
->next
);
3679 h2
->index
= Fcopy_sequence (h1
->index
);
3680 XSET_HASH_TABLE (table
, h2
);
3682 /* Maybe add this hash table to the list of all weak hash tables. */
3683 if (!NILP (h2
->weak
))
3685 h2
->next_weak
= Vweak_hash_tables
;
3686 Vweak_hash_tables
= table
;
3693 /* Resize hash table H if it's too full. If H cannot be resized
3694 because it's already too large, throw an error. */
3697 maybe_resize_hash_table (h
)
3698 struct Lisp_Hash_Table
*h
;
3700 if (NILP (h
->next_free
))
3702 int old_size
= HASH_TABLE_SIZE (h
);
3703 int i
, new_size
, index_size
;
3705 if (INTEGERP (h
->rehash_size
))
3706 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3708 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3709 index_size
= next_almost_prime (new_size
3710 / XFLOATINT (h
->rehash_threshold
));
3711 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3712 error ("Hash table too large to resize");
3714 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3715 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3716 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3717 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3719 /* Update the free list. Do it so that new entries are added at
3720 the end of the free list. This makes some operations like
3722 for (i
= old_size
; i
< new_size
- 1; ++i
)
3723 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3725 if (!NILP (h
->next_free
))
3727 Lisp_Object last
, next
;
3729 last
= h
->next_free
;
3730 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3734 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3737 XSETFASTINT (h
->next_free
, old_size
);
3740 for (i
= 0; i
< old_size
; ++i
)
3741 if (!NILP (HASH_HASH (h
, i
)))
3743 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3744 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3745 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3746 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3752 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3753 the hash code of KEY. Value is the index of the entry in H
3754 matching KEY, or -1 if not found. */
3757 hash_lookup (h
, key
, hash
)
3758 struct Lisp_Hash_Table
*h
;
3763 int start_of_bucket
;
3766 hash_code
= h
->hashfn (h
, key
);
3770 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3771 idx
= HASH_INDEX (h
, start_of_bucket
);
3775 int i
= XFASTINT (idx
);
3776 if (EQ (key
, HASH_KEY (h
, i
))
3778 && h
->cmpfn (h
, key
, hash_code
,
3779 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3781 idx
= HASH_NEXT (h
, i
);
3784 return NILP (idx
) ? -1 : XFASTINT (idx
);
3788 /* Put an entry into hash table H that associates KEY with VALUE.
3789 HASH is a previously computed hash code of KEY. */
3792 hash_put (h
, key
, value
, hash
)
3793 struct Lisp_Hash_Table
*h
;
3794 Lisp_Object key
, value
;
3797 int start_of_bucket
, i
;
3799 xassert ((hash
& ~VALMASK
) == 0);
3801 /* Increment count after resizing because resizing may fail. */
3802 maybe_resize_hash_table (h
);
3803 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3805 /* Store key/value in the key_and_value vector. */
3806 i
= XFASTINT (h
->next_free
);
3807 h
->next_free
= HASH_NEXT (h
, i
);
3808 HASH_KEY (h
, i
) = key
;
3809 HASH_VALUE (h
, i
) = value
;
3811 /* Remember its hash code. */
3812 HASH_HASH (h
, i
) = make_number (hash
);
3814 /* Add new entry to its collision chain. */
3815 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3816 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3817 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3821 /* Remove the entry matching KEY from hash table H, if there is one. */
3824 hash_remove (h
, key
)
3825 struct Lisp_Hash_Table
*h
;
3829 int start_of_bucket
;
3830 Lisp_Object idx
, prev
;
3832 hash_code
= h
->hashfn (h
, key
);
3833 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3834 idx
= HASH_INDEX (h
, start_of_bucket
);
3839 int i
= XFASTINT (idx
);
3841 if (EQ (key
, HASH_KEY (h
, i
))
3843 && h
->cmpfn (h
, key
, hash_code
,
3844 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3846 /* Take entry out of collision chain. */
3848 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3850 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3852 /* Clear slots in key_and_value and add the slots to
3854 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3855 HASH_NEXT (h
, i
) = h
->next_free
;
3856 h
->next_free
= make_number (i
);
3857 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3858 xassert (XINT (h
->count
) >= 0);
3864 idx
= HASH_NEXT (h
, i
);
3870 /* Clear hash table H. */
3874 struct Lisp_Hash_Table
*h
;
3876 if (XFASTINT (h
->count
) > 0)
3878 int i
, size
= HASH_TABLE_SIZE (h
);
3880 for (i
= 0; i
< size
; ++i
)
3882 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3883 HASH_KEY (h
, i
) = Qnil
;
3884 HASH_VALUE (h
, i
) = Qnil
;
3885 HASH_HASH (h
, i
) = Qnil
;
3888 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3889 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3891 h
->next_free
= make_number (0);
3892 h
->count
= make_number (0);
3898 /************************************************************************
3900 ************************************************************************/
3902 /* Remove elements from weak hash tables that don't survive the
3903 current garbage collection. Remove weak tables that don't survive
3904 from Vweak_hash_tables. Called from gc_sweep. */
3907 sweep_weak_hash_tables ()
3910 struct Lisp_Hash_Table
*h
= 0, *prev
;
3912 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
3915 h
= XHASH_TABLE (table
);
3917 if (h
->size
& ARRAY_MARK_FLAG
)
3919 if (XFASTINT (h
->count
) > 0)
3923 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3924 for (bucket
= 0; bucket
< n
; ++bucket
)
3926 Lisp_Object idx
, key
, value
, prev
, next
;
3928 /* Follow collision chain, removing entries that
3929 don't survive this garbage collection. */
3930 idx
= HASH_INDEX (h
, bucket
);
3932 while (!GC_NILP (idx
))
3935 int i
= XFASTINT (idx
);
3938 if (EQ (h
->weak
, Qkey
))
3939 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
3940 else if (EQ (h
->weak
, Qvalue
))
3941 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
3942 else if (EQ (h
->weak
, Qt
))
3943 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
3944 || !survives_gc_p (HASH_VALUE (h
, i
)));
3948 next
= HASH_NEXT (h
, i
);
3951 /* Take out of collision chain. */
3953 HASH_INDEX (h
, i
) = next
;
3955 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3957 /* Add to free list. */
3958 HASH_NEXT (h
, i
) = h
->next_free
;
3961 /* Clear key, value, and hash. */
3962 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3963 HASH_HASH (h
, i
) = Qnil
;
3965 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3969 /* Make sure key and value survive. */
3970 mark_object (&HASH_KEY (h
, i
));
3971 mark_object (&HASH_VALUE (h
, i
));
3981 /* Table is not marked, and will thus be freed.
3982 Take it out of the list of weak hash tables. */
3984 prev
->next_weak
= h
->next_weak
;
3986 Vweak_hash_tables
= h
->next_weak
;
3993 /***********************************************************************
3994 Hash Code Computation
3995 ***********************************************************************/
3997 /* Maximum depth up to which to dive into Lisp structures. */
3999 #define SXHASH_MAX_DEPTH 3
4001 /* Maximum length up to which to take list and vector elements into
4004 #define SXHASH_MAX_LEN 7
4006 /* Combine two integers X and Y for hashing. */
4008 #define SXHASH_COMBINE(X, Y) \
4009 ((((unsigned)(X) << 4) + ((unsigned)(X) >> 24) & 0x0fffffff) \
4013 /* Return a hash for string PTR which has length LEN. */
4016 sxhash_string (ptr
, len
)
4020 unsigned char *p
= ptr
;
4021 unsigned char *end
= p
+ len
;
4030 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4033 return hash
& 07777777777;
4037 /* Return a hash for list LIST. DEPTH is the current depth in the
4038 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4041 sxhash_list (list
, depth
)
4048 if (depth
< SXHASH_MAX_DEPTH
)
4050 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4051 list
= XCDR (list
), ++i
)
4053 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4054 hash
= SXHASH_COMBINE (hash
, hash2
);
4061 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4062 the Lisp structure. */
4065 sxhash_vector (vec
, depth
)
4069 unsigned hash
= XVECTOR (vec
)->size
;
4072 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4073 for (i
= 0; i
< n
; ++i
)
4075 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4076 hash
= SXHASH_COMBINE (hash
, hash2
);
4083 /* Return a hash for bool-vector VECTOR. */
4086 sxhash_bool_vector (vec
)
4089 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4092 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4093 for (i
= 0; i
< n
; ++i
)
4094 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4100 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4101 structure. Value is an unsigned integer clipped to VALMASK. */
4110 if (depth
> SXHASH_MAX_DEPTH
)
4113 switch (XTYPE (obj
))
4120 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4121 XSYMBOL (obj
)->name
->size
);
4129 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4132 /* This can be everything from a vector to an overlay. */
4133 case Lisp_Vectorlike
:
4135 /* According to the CL HyperSpec, two arrays are equal only if
4136 they are `eq', except for strings and bit-vectors. In
4137 Emacs, this works differently. We have to compare element
4139 hash
= sxhash_vector (obj
, depth
);
4140 else if (BOOL_VECTOR_P (obj
))
4141 hash
= sxhash_bool_vector (obj
);
4143 /* Others are `equal' if they are `eq', so let's take their
4149 hash
= sxhash_list (obj
, depth
);
4154 unsigned char *p
= (unsigned char *) &XFLOAT (obj
)->data
;
4155 unsigned char *e
= p
+ sizeof XFLOAT (obj
)->data
;
4156 for (hash
= 0; p
< e
; ++p
)
4157 hash
= SXHASH_COMBINE (hash
, *p
);
4165 return hash
& VALMASK
;
4170 /***********************************************************************
4172 ***********************************************************************/
4175 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4176 "Compute a hash code for OBJ and return it as integer.")
4180 unsigned hash
= sxhash (obj
, 0);;
4181 return make_number (hash
);
4185 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4186 "Create and return a new hash table.\n\
4187 Arguments are specified as keyword/argument pairs. The following\n\
4188 arguments are defined:\n\
4190 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.
4191 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4192 User-supplied test and hash functions can be specified via\n\
4193 `define-hash-table-test'.\n\
4195 :SIZE SIZE -- A hint as to how many elements will be put in the table.
4198 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4199 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4200 If it is a float, it must be > 1.0, and the new size is computed by\n\
4201 multiplying the old size with that factor. Default is 1.5.\n\
4203 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4204 Resize the hash table when ratio of the number of entries in the table.\n\
4207 :WEAK WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4208 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4209 pairs are removed from a weak hash table when their key, value or both\n\
4210 (WEAK t) are otherwise unreferenced. Default is nil.")
4215 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4216 Lisp_Object user_test
, user_hash
;
4220 /* The vector `used' is used to keep track of arguments that
4221 have been consumed. */
4222 used
= (char *) alloca (nargs
* sizeof *used
);
4223 bzero (used
, nargs
* sizeof *used
);
4225 /* See if there's a `:test TEST' among the arguments. */
4226 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4227 test
= i
< 0 ? Qeql
: args
[i
];
4228 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4230 /* See if it is a user-defined test. */
4233 prop
= Fget (test
, Qhash_table_test
);
4234 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4235 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4237 user_test
= Fnth (make_number (0), prop
);
4238 user_hash
= Fnth (make_number (1), prop
);
4241 user_test
= user_hash
= Qnil
;
4243 /* See if there's a `:size SIZE' argument. */
4244 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4245 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4246 if (!INTEGERP (size
) || XINT (size
) <= 0)
4248 list2 (build_string ("Illegal hash table size"),
4251 /* Look for `:rehash-size SIZE'. */
4252 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4253 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4254 if (!NUMBERP (rehash_size
)
4255 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4256 || XFLOATINT (rehash_size
) <= 1.0)
4258 list2 (build_string ("Illegal hash table rehash size"),
4261 /* Look for `:rehash-threshold THRESHOLD'. */
4262 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4263 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4264 if (!FLOATP (rehash_threshold
)
4265 || XFLOATINT (rehash_threshold
) <= 0.0
4266 || XFLOATINT (rehash_threshold
) > 1.0)
4268 list2 (build_string ("Illegal hash table rehash threshold"),
4271 /* Look for `:weak WEAK'. */
4272 i
= get_key_arg (QCweak
, nargs
, args
, used
);
4273 weak
= i
< 0 ? Qnil
: args
[i
];
4277 && !EQ (weak
, Qvalue
))
4278 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4281 /* Now, all args should have been used up, or there's a problem. */
4282 for (i
= 0; i
< nargs
; ++i
)
4285 list2 (build_string ("Invalid argument list"), args
[i
]));
4287 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4288 user_test
, user_hash
);
4292 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4293 "Return a copy of hash table TABLE.")
4297 return copy_hash_table (check_hash_table (table
));
4301 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, MANY
, 0,
4302 "Create a new hash table.\n\
4303 Optional first argument SIZE is a hint to the implementation as\n\
4304 to how many elements will be put in the table. Default is 65.\n\
4306 Optional second argument TEST specifies how to compare keys in\n\
4307 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4308 is `eql'. New tests can be defined with `define-hash-table-test'.\n\
4310 Optional third argument WEAK must be one of nil, t, `key',\n\
4311 or `value'. Default is nil. Elements of weak hash tables\n\
4312 are removed when their key, value or both are otherwise unreferenced.\n\
4314 The rest of the optional arguments are keyword/value pairs. The\n\
4315 following are recognized:\n\
4317 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4318 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4319 If it is a float, it must be > 1.0, and the new size is computed by\n\
4320 multiplying the old size with that factor. Default is 1.5.\n\
4322 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4323 Resize the hash table when ratio of the number of entries in the table.\n\
4329 Lisp_Object args2
[nargs
+ 6];
4332 /* Recognize size argument. */
4334 if (INTEGERP (args
[i
]))
4336 args2
[j
++] = QCsize
;
4337 args2
[j
++] = args
[i
++];
4340 /* Recognize test argument. */
4341 if (SYMBOLP (args
[i
])
4342 && !EQ (args
[i
], QCrehash_size
)
4343 && !EQ (args
[i
], QCrehash_threshold
)
4344 && !EQ (args
[i
], QCweak
))
4346 args2
[j
++] = QCtest
;
4347 args2
[j
++] = args
[i
++];
4350 /* Recognize weakness argument. */
4351 if (EQ (args
[i
], Qt
)
4353 || EQ (args
[i
], Qkey
)
4354 || EQ (args
[i
], Qvalue
))
4356 args2
[j
++] = QCweak
;
4357 args2
[j
++] = args
[i
++];
4360 /* Copy remaining arguments. */
4362 args2
[j
++] = args
[i
++];
4364 return Fmake_hash_table (j
, args2
);
4368 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4369 "Return the number of elements in TABLE.")
4373 return check_hash_table (table
)->count
;
4377 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4378 Shash_table_rehash_size
, 1, 1, 0,
4379 "Return the current rehash size of TABLE.")
4383 return check_hash_table (table
)->rehash_size
;
4387 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4388 Shash_table_rehash_threshold
, 1, 1, 0,
4389 "Return the current rehash threshold of TABLE.")
4393 return check_hash_table (table
)->rehash_threshold
;
4397 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4398 "Return the size of TABLE.\n\
4399 The size can be used as an argument to `make-hash-table' to create\n\
4400 a hash table than can hold as many elements of TABLE holds\n\
4401 without need for resizing.")
4405 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4406 return make_number (HASH_TABLE_SIZE (h
));
4410 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4411 "Return the test TABLE uses.")
4415 return check_hash_table (table
)->test
;
4419 DEFUN ("hash-table-weak", Fhash_table_weak
, Shash_table_weak
, 1, 1, 0,
4420 "Return the weakness of TABLE.")
4424 return check_hash_table (table
)->weak
;
4428 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4429 "Return t if OBJ is a Lisp hash table object.")
4433 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4437 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4438 "Clear hash table TABLE.")
4442 hash_clear (check_hash_table (table
));
4447 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4448 "Look up KEY in TABLE and return its associated value.\n\
4449 If KEY is not found, return DFLT which defaults to nil.")
4451 Lisp_Object key
, table
;
4453 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4454 int i
= hash_lookup (h
, key
, NULL
);
4455 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4459 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4460 "Associate KEY with VALUE is hash table TABLE.\n\
4461 If KEY is already present in table, replace its current value with\n\
4464 Lisp_Object key
, value
, table
;
4466 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4470 i
= hash_lookup (h
, key
, &hash
);
4472 HASH_VALUE (h
, i
) = value
;
4474 hash_put (h
, key
, value
, hash
);
4480 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4481 "Remove KEY from TABLE.")
4483 Lisp_Object key
, table
;
4485 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4486 hash_remove (h
, key
);
4491 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4492 "Call FUNCTION for all entries in hash table TABLE.\n\
4493 FUNCTION is called with 2 arguments KEY and VALUE.")
4495 Lisp_Object function
, table
;
4497 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4498 Lisp_Object args
[3];
4501 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4502 if (!NILP (HASH_HASH (h
, i
)))
4505 args
[1] = HASH_KEY (h
, i
);
4506 args
[2] = HASH_VALUE (h
, i
);
4514 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4515 Sdefine_hash_table_test
, 3, 3, 0,
4516 "Define a new hash table test with name NAME, a symbol.\n\
4517 In hash tables create with NAME specified as test, use TEST to compare\n\
4518 keys, and HASH for computing hash codes of keys.\n\
4520 TEST must be a function taking two arguments and returning non-nil\n\
4521 if both arguments are the same. HASH must be a function taking\n\
4522 one argument and return an integer that is the hash code of the\n\
4523 argument. Hash code computation should use the whole value range of\n\
4524 integers, including negative integers.")
4526 Lisp_Object name
, test
, hash
;
4528 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4537 /* Hash table stuff. */
4538 Qhash_table_p
= intern ("hash-table-p");
4539 staticpro (&Qhash_table_p
);
4540 Qeq
= intern ("eq");
4542 Qeql
= intern ("eql");
4544 Qequal
= intern ("equal");
4545 staticpro (&Qequal
);
4546 QCtest
= intern (":test");
4547 staticpro (&QCtest
);
4548 QCsize
= intern (":size");
4549 staticpro (&QCsize
);
4550 QCrehash_size
= intern (":rehash-size");
4551 staticpro (&QCrehash_size
);
4552 QCrehash_threshold
= intern (":rehash-threshold");
4553 staticpro (&QCrehash_threshold
);
4554 QCweak
= intern (":weak");
4555 staticpro (&QCweak
);
4556 Qkey
= intern ("key");
4558 Qvalue
= intern ("value");
4559 staticpro (&Qvalue
);
4560 Qhash_table_test
= intern ("hash-table-test");
4561 staticpro (&Qhash_table_test
);
4564 defsubr (&Smake_hash_table
);
4565 defsubr (&Scopy_hash_table
);
4566 defsubr (&Smakehash
);
4567 defsubr (&Shash_table_count
);
4568 defsubr (&Shash_table_rehash_size
);
4569 defsubr (&Shash_table_rehash_threshold
);
4570 defsubr (&Shash_table_size
);
4571 defsubr (&Shash_table_test
);
4572 defsubr (&Shash_table_weak
);
4573 defsubr (&Shash_table_p
);
4574 defsubr (&Sclrhash
);
4575 defsubr (&Sgethash
);
4576 defsubr (&Sputhash
);
4577 defsubr (&Sremhash
);
4578 defsubr (&Smaphash
);
4579 defsubr (&Sdefine_hash_table_test
);
4581 Qstring_lessp
= intern ("string-lessp");
4582 staticpro (&Qstring_lessp
);
4583 Qprovide
= intern ("provide");
4584 staticpro (&Qprovide
);
4585 Qrequire
= intern ("require");
4586 staticpro (&Qrequire
);
4587 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4588 staticpro (&Qyes_or_no_p_history
);
4589 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4590 staticpro (&Qcursor_in_echo_area
);
4591 Qwidget_type
= intern ("widget-type");
4592 staticpro (&Qwidget_type
);
4594 staticpro (&string_char_byte_cache_string
);
4595 string_char_byte_cache_string
= Qnil
;
4597 Fset (Qyes_or_no_p_history
, Qnil
);
4599 DEFVAR_LISP ("features", &Vfeatures
,
4600 "A list of symbols which are the features of the executing emacs.\n\
4601 Used by `featurep' and `require', and altered by `provide'.");
4604 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4605 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4606 This applies to y-or-n and yes-or-no questions asked by commands\n\
4607 invoked by mouse clicks and mouse menu items.");
4610 defsubr (&Sidentity
);
4613 defsubr (&Ssafe_length
);
4614 defsubr (&Sstring_bytes
);
4615 defsubr (&Sstring_equal
);
4616 defsubr (&Scompare_strings
);
4617 defsubr (&Sstring_lessp
);
4620 defsubr (&Svconcat
);
4621 defsubr (&Scopy_sequence
);
4622 defsubr (&Sstring_make_multibyte
);
4623 defsubr (&Sstring_make_unibyte
);
4624 defsubr (&Sstring_as_multibyte
);
4625 defsubr (&Sstring_as_unibyte
);
4626 defsubr (&Scopy_alist
);
4627 defsubr (&Ssubstring
);
4639 defsubr (&Snreverse
);
4640 defsubr (&Sreverse
);
4642 defsubr (&Splist_get
);
4644 defsubr (&Splist_put
);
4647 defsubr (&Sfillarray
);
4648 defsubr (&Schar_table_subtype
);
4649 defsubr (&Schar_table_parent
);
4650 defsubr (&Sset_char_table_parent
);
4651 defsubr (&Schar_table_extra_slot
);
4652 defsubr (&Sset_char_table_extra_slot
);
4653 defsubr (&Schar_table_range
);
4654 defsubr (&Sset_char_table_range
);
4655 defsubr (&Sset_char_table_default
);
4656 defsubr (&Smap_char_table
);
4659 defsubr (&Smapconcat
);
4660 defsubr (&Sy_or_n_p
);
4661 defsubr (&Syes_or_no_p
);
4662 defsubr (&Sload_average
);
4663 defsubr (&Sfeaturep
);
4664 defsubr (&Srequire
);
4665 defsubr (&Sprovide
);
4666 defsubr (&Swidget_plist_member
);
4667 defsubr (&Swidget_put
);
4668 defsubr (&Swidget_get
);
4669 defsubr (&Swidget_apply
);
4670 defsubr (&Sbase64_encode_region
);
4671 defsubr (&Sbase64_decode_region
);
4672 defsubr (&Sbase64_encode_string
);
4673 defsubr (&Sbase64_decode_string
);
4680 Vweak_hash_tables
= Qnil
;