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
))
152 while (CONSP (sequence
))
154 sequence
= XCDR (sequence
);
157 if (!CONSP (sequence
))
160 sequence
= XCDR (sequence
);
165 if (!NILP (sequence
))
166 wrong_type_argument (Qlistp
, sequence
);
168 val
= make_number (i
);
170 else if (NILP (sequence
))
171 XSETFASTINT (val
, 0);
174 sequence
= wrong_type_argument (Qsequencep
, sequence
);
180 /* This does not check for quits. That is safe
181 since it must terminate. */
183 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
184 "Return the length of a list, but avoid error or infinite loop.\n\
185 This function never gets an error. If LIST is not really a list,\n\
186 it returns 0. If LIST is circular, it returns a finite value\n\
187 which is at least the number of distinct elements.")
191 Lisp_Object tail
, halftail
, length
;
194 /* halftail is used to detect circular lists. */
196 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
198 if (EQ (tail
, halftail
) && len
!= 0)
202 halftail
= XCDR (halftail
);
205 XSETINT (length
, len
);
209 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
210 "Return the number of bytes in STRING.\n\
211 If STRING is a multibyte string, this is greater than the length of STRING.")
215 CHECK_STRING (string
, 1);
216 return make_number (STRING_BYTES (XSTRING (string
)));
219 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
220 "Return t if two strings have identical contents.\n\
221 Case is significant, but text properties are ignored.\n\
222 Symbols are also allowed; their print names are used instead.")
224 register Lisp_Object s1
, s2
;
227 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
229 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
230 CHECK_STRING (s1
, 0);
231 CHECK_STRING (s2
, 1);
233 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
234 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
235 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
240 DEFUN ("compare-strings", Fcompare_strings
,
241 Scompare_strings
, 6, 7, 0,
242 "Compare the contents of two strings, converting to multibyte if needed.\n\
243 In string STR1, skip the first START1 characters and stop at END1.\n\
244 In string STR2, skip the first START2 characters and stop at END2.\n\
245 END1 and END2 default to the full lengths of the respective strings.\n\
247 Case is significant in this comparison if IGNORE-CASE is nil.\n\
248 Unibyte strings are converted to multibyte for comparison.\n\
250 The value is t if the strings (or specified portions) match.\n\
251 If string STR1 is less, the value is a negative number N;\n\
252 - 1 - N is the number of characters that match at the beginning.\n\
253 If string STR1 is greater, the value is a positive number N;\n\
254 N - 1 is the number of characters that match at the beginning.")
255 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
256 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
258 register int end1_char
, end2_char
;
259 register int i1
, i1_byte
, i2
, i2_byte
;
261 CHECK_STRING (str1
, 0);
262 CHECK_STRING (str2
, 1);
264 start1
= make_number (0);
266 start2
= make_number (0);
267 CHECK_NATNUM (start1
, 2);
268 CHECK_NATNUM (start2
, 3);
270 CHECK_NATNUM (end1
, 4);
272 CHECK_NATNUM (end2
, 4);
277 i1_byte
= string_char_to_byte (str1
, i1
);
278 i2_byte
= string_char_to_byte (str2
, i2
);
280 end1_char
= XSTRING (str1
)->size
;
281 if (! NILP (end1
) && end1_char
> XINT (end1
))
282 end1_char
= XINT (end1
);
284 end2_char
= XSTRING (str2
)->size
;
285 if (! NILP (end2
) && end2_char
> XINT (end2
))
286 end2_char
= XINT (end2
);
288 while (i1
< end1_char
&& i2
< end2_char
)
290 /* When we find a mismatch, we must compare the
291 characters, not just the bytes. */
294 if (STRING_MULTIBYTE (str1
))
295 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
298 c1
= XSTRING (str1
)->data
[i1
++];
299 c1
= unibyte_char_to_multibyte (c1
);
302 if (STRING_MULTIBYTE (str2
))
303 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
306 c2
= XSTRING (str2
)->data
[i2
++];
307 c2
= unibyte_char_to_multibyte (c2
);
313 if (! NILP (ignore_case
))
317 tem
= Fupcase (make_number (c1
));
319 tem
= Fupcase (make_number (c2
));
326 /* Note that I1 has already been incremented
327 past the character that we are comparing;
328 hence we don't add or subtract 1 here. */
330 return make_number (- i1
);
332 return make_number (i1
);
336 return make_number (i1
- XINT (start1
) + 1);
338 return make_number (- i1
+ XINT (start1
) - 1);
343 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
344 "Return t if first arg string is less than second in lexicographic order.\n\
345 Case is significant.\n\
346 Symbols are also allowed; their print names are used instead.")
348 register Lisp_Object s1
, s2
;
351 register int i1
, i1_byte
, i2
, i2_byte
;
354 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
356 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
357 CHECK_STRING (s1
, 0);
358 CHECK_STRING (s2
, 1);
360 i1
= i1_byte
= i2
= i2_byte
= 0;
362 end
= XSTRING (s1
)->size
;
363 if (end
> XSTRING (s2
)->size
)
364 end
= XSTRING (s2
)->size
;
368 /* When we find a mismatch, we must compare the
369 characters, not just the bytes. */
372 if (STRING_MULTIBYTE (s1
))
373 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
375 c1
= XSTRING (s1
)->data
[i1
++];
377 if (STRING_MULTIBYTE (s2
))
378 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
380 c2
= XSTRING (s2
)->data
[i2
++];
383 return c1
< c2
? Qt
: Qnil
;
385 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
388 static Lisp_Object
concat ();
399 return concat (2, args
, Lisp_String
, 0);
401 return concat (2, &s1
, Lisp_String
, 0);
402 #endif /* NO_ARG_ARRAY */
408 Lisp_Object s1
, s2
, s3
;
415 return concat (3, args
, Lisp_String
, 0);
417 return concat (3, &s1
, Lisp_String
, 0);
418 #endif /* NO_ARG_ARRAY */
421 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
422 "Concatenate all the arguments and make the result a list.\n\
423 The result is a list whose elements are the elements of all the arguments.\n\
424 Each argument may be a list, vector or string.\n\
425 The last argument is not copied, just used as the tail of the new list.")
430 return concat (nargs
, args
, Lisp_Cons
, 1);
433 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
434 "Concatenate all the arguments and make the result a string.\n\
435 The result is a string whose elements are the elements of all the arguments.\n\
436 Each argument may be a string or a list or vector of characters (integers).\n\
438 Do not use individual integers as arguments!\n\
439 The behavior of `concat' in that case will be changed later!\n\
440 If your program passes an integer as an argument to `concat',\n\
441 you should change it right away not to do so.")
446 return concat (nargs
, args
, Lisp_String
, 0);
449 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
450 "Concatenate all the arguments and make the result a vector.\n\
451 The result is a vector whose elements are the elements of all the arguments.\n\
452 Each argument may be a list, vector or string.")
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 /* Retrun a copy of a sub char table ARG. The elements except for a
461 nested sub char table are not copied. */
463 copy_sub_char_table (arg
)
466 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
469 /* Copy all the contents. */
470 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
471 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
472 /* Recursively copy any sub char-tables in the ordinary slots. */
473 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
474 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
475 XCHAR_TABLE (copy
)->contents
[i
]
476 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
482 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
483 "Return a copy of a list, vector or string.\n\
484 The elements of a list or vector are not copied; they are shared\n\
489 if (NILP (arg
)) return arg
;
491 if (CHAR_TABLE_P (arg
))
496 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
497 /* Copy all the slots, including the extra ones. */
498 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
499 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
500 * sizeof (Lisp_Object
)));
502 /* Recursively copy any sub char tables in the ordinary slots
503 for multibyte characters. */
504 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
505 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
506 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
507 XCHAR_TABLE (copy
)->contents
[i
]
508 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
513 if (BOOL_VECTOR_P (arg
))
517 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
519 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
520 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
525 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
526 arg
= wrong_type_argument (Qsequencep
, arg
);
527 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
530 /* In string STR of length LEN, see if bytes before STR[I] combine
531 with bytes after STR[I] to form a single character. If so, return
532 the number of bytes after STR[I] which combine in this way.
533 Otherwize, return 0. */
536 count_combining (str
, len
, i
)
540 int j
= i
- 1, bytes
;
542 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
544 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
545 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
547 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
548 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
551 /* This structure holds information of an argument of `concat' that is
552 a string and has text properties to be copied. */
555 int argnum
; /* refer to ARGS (arguments of `concat') */
556 int from
; /* refer to ARGS[argnum] (argument string) */
557 int to
; /* refer to VAL (the target string) */
561 concat (nargs
, args
, target_type
, last_special
)
564 enum Lisp_Type target_type
;
568 register Lisp_Object tail
;
569 register Lisp_Object
this;
572 register int result_len
;
573 register int result_len_byte
;
575 Lisp_Object last_tail
;
578 /* When we make a multibyte string, we can't copy text properties
579 while concatinating each string because the length of resulting
580 string can't be decided until we finish the whole concatination.
581 So, we record strings that have text properties to be copied
582 here, and copy the text properties after the concatination. */
583 struct textprop_rec
*textprops
;
584 /* Number of elments in textprops. */
585 int num_textprops
= 0;
587 /* In append, the last arg isn't treated like the others */
588 if (last_special
&& nargs
> 0)
591 last_tail
= args
[nargs
];
596 /* Canonicalize each argument. */
597 for (argnum
= 0; argnum
< nargs
; argnum
++)
600 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
601 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
604 args
[argnum
] = Fnumber_to_string (this);
606 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
610 /* Compute total length in chars of arguments in RESULT_LEN.
611 If desired output is a string, also compute length in bytes
612 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
613 whether the result should be a multibyte string. */
617 for (argnum
= 0; argnum
< nargs
; argnum
++)
621 len
= XFASTINT (Flength (this));
622 if (target_type
== Lisp_String
)
624 /* We must count the number of bytes needed in the string
625 as well as the number of characters. */
631 for (i
= 0; i
< len
; i
++)
633 ch
= XVECTOR (this)->contents
[i
];
635 wrong_type_argument (Qintegerp
, ch
);
636 this_len_byte
= CHAR_BYTES (XINT (ch
));
637 result_len_byte
+= this_len_byte
;
638 if (this_len_byte
> 1)
641 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
642 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
643 else if (CONSP (this))
644 for (; CONSP (this); this = XCDR (this))
648 wrong_type_argument (Qintegerp
, ch
);
649 this_len_byte
= CHAR_BYTES (XINT (ch
));
650 result_len_byte
+= this_len_byte
;
651 if (this_len_byte
> 1)
654 else if (STRINGP (this))
656 if (STRING_MULTIBYTE (this))
659 result_len_byte
+= STRING_BYTES (XSTRING (this));
662 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
663 XSTRING (this)->size
);
670 if (! some_multibyte
)
671 result_len_byte
= result_len
;
673 /* Create the output object. */
674 if (target_type
== Lisp_Cons
)
675 val
= Fmake_list (make_number (result_len
), Qnil
);
676 else if (target_type
== Lisp_Vectorlike
)
677 val
= Fmake_vector (make_number (result_len
), Qnil
);
678 else if (some_multibyte
)
679 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
681 val
= make_uninit_string (result_len
);
683 /* In `append', if all but last arg are nil, return last arg. */
684 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
687 /* Copy the contents of the args into the result. */
689 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
691 toindex
= 0, toindex_byte
= 0;
696 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
698 for (argnum
= 0; argnum
< nargs
; argnum
++)
702 register unsigned int thisindex
= 0;
703 register unsigned int thisindex_byte
= 0;
707 thislen
= Flength (this), thisleni
= XINT (thislen
);
709 /* Between strings of the same kind, copy fast. */
710 if (STRINGP (this) && STRINGP (val
)
711 && STRING_MULTIBYTE (this) == some_multibyte
)
713 int thislen_byte
= STRING_BYTES (XSTRING (this));
716 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
717 STRING_BYTES (XSTRING (this)));
718 combined
= (some_multibyte
&& toindex_byte
> 0
719 ? count_combining (XSTRING (val
)->data
,
720 toindex_byte
+ thislen_byte
,
723 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
725 textprops
[num_textprops
].argnum
= argnum
;
726 /* We ignore text properties on characters being combined. */
727 textprops
[num_textprops
].from
= combined
;
728 textprops
[num_textprops
++].to
= toindex
;
730 toindex_byte
+= thislen_byte
;
731 toindex
+= thisleni
- combined
;
732 XSTRING (val
)->size
-= combined
;
734 /* Copy a single-byte string to a multibyte string. */
735 else if (STRINGP (this) && STRINGP (val
))
737 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
739 textprops
[num_textprops
].argnum
= argnum
;
740 textprops
[num_textprops
].from
= 0;
741 textprops
[num_textprops
++].to
= toindex
;
743 toindex_byte
+= copy_text (XSTRING (this)->data
,
744 XSTRING (val
)->data
+ toindex_byte
,
745 XSTRING (this)->size
, 0, 1);
749 /* Copy element by element. */
752 register Lisp_Object elt
;
754 /* Fetch next element of `this' arg into `elt', or break if
755 `this' is exhausted. */
756 if (NILP (this)) break;
758 elt
= XCAR (this), this = XCDR (this);
759 else if (thisindex
>= thisleni
)
761 else if (STRINGP (this))
764 if (STRING_MULTIBYTE (this))
766 FETCH_STRING_CHAR_ADVANCE (c
, this,
769 XSETFASTINT (elt
, c
);
773 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
775 && (XINT (elt
) >= 0240
776 || (XINT (elt
) >= 0200
777 && ! NILP (Vnonascii_translation_table
)))
778 && XINT (elt
) < 0400)
780 c
= unibyte_char_to_multibyte (XINT (elt
));
785 else if (BOOL_VECTOR_P (this))
788 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
789 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
796 elt
= XVECTOR (this)->contents
[thisindex
++];
798 /* Store this element into the result. */
805 else if (VECTORP (val
))
806 XVECTOR (val
)->contents
[toindex
++] = elt
;
809 CHECK_NUMBER (elt
, 0);
810 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
812 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
815 && count_combining (XSTRING (val
)->data
,
816 toindex_byte
, toindex_byte
- 1))
817 XSTRING (val
)->size
--;
822 /* If we have any multibyte characters,
823 we already decided to make a multibyte string. */
826 unsigned char work
[4], *str
;
827 int i
= CHAR_STRING (c
, work
, str
);
829 /* P exists as a variable
830 to avoid a bug on the Masscomp C compiler. */
831 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
840 XCDR (prev
) = last_tail
;
842 if (num_textprops
> 0)
844 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
846 this = args
[textprops
[argnum
].argnum
];
847 copy_text_properties (make_number (textprops
[argnum
].from
),
848 XSTRING (this)->size
, this,
849 make_number (textprops
[argnum
].to
), val
, Qnil
);
855 static Lisp_Object string_char_byte_cache_string
;
856 static int string_char_byte_cache_charpos
;
857 static int string_char_byte_cache_bytepos
;
860 clear_string_char_byte_cache ()
862 string_char_byte_cache_string
= Qnil
;
865 /* Return the character index corresponding to CHAR_INDEX in STRING. */
868 string_char_to_byte (string
, char_index
)
873 int best_below
, best_below_byte
;
874 int best_above
, best_above_byte
;
876 if (! STRING_MULTIBYTE (string
))
879 best_below
= best_below_byte
= 0;
880 best_above
= XSTRING (string
)->size
;
881 best_above_byte
= STRING_BYTES (XSTRING (string
));
883 if (EQ (string
, string_char_byte_cache_string
))
885 if (string_char_byte_cache_charpos
< char_index
)
887 best_below
= string_char_byte_cache_charpos
;
888 best_below_byte
= string_char_byte_cache_bytepos
;
892 best_above
= string_char_byte_cache_charpos
;
893 best_above_byte
= string_char_byte_cache_bytepos
;
897 if (char_index
- best_below
< best_above
- char_index
)
899 while (best_below
< char_index
)
902 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
905 i_byte
= best_below_byte
;
909 while (best_above
> char_index
)
911 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
912 unsigned char *pbeg
= pend
- best_above_byte
;
913 unsigned char *p
= pend
- 1;
916 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
917 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
918 if (bytes
== pend
- p
)
919 best_above_byte
-= bytes
;
920 else if (bytes
> pend
- p
)
921 best_above_byte
-= (pend
- p
);
927 i_byte
= best_above_byte
;
930 string_char_byte_cache_bytepos
= i_byte
;
931 string_char_byte_cache_charpos
= i
;
932 string_char_byte_cache_string
= string
;
937 /* Return the character index corresponding to BYTE_INDEX in STRING. */
940 string_byte_to_char (string
, byte_index
)
945 int best_below
, best_below_byte
;
946 int best_above
, best_above_byte
;
948 if (! STRING_MULTIBYTE (string
))
951 best_below
= best_below_byte
= 0;
952 best_above
= XSTRING (string
)->size
;
953 best_above_byte
= STRING_BYTES (XSTRING (string
));
955 if (EQ (string
, string_char_byte_cache_string
))
957 if (string_char_byte_cache_bytepos
< byte_index
)
959 best_below
= string_char_byte_cache_charpos
;
960 best_below_byte
= string_char_byte_cache_bytepos
;
964 best_above
= string_char_byte_cache_charpos
;
965 best_above_byte
= string_char_byte_cache_bytepos
;
969 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
971 while (best_below_byte
< byte_index
)
974 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
977 i_byte
= best_below_byte
;
981 while (best_above_byte
> byte_index
)
983 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
984 unsigned char *pbeg
= pend
- best_above_byte
;
985 unsigned char *p
= pend
- 1;
988 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
989 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
990 if (bytes
== pend
- p
)
991 best_above_byte
-= bytes
;
992 else if (bytes
> pend
- p
)
993 best_above_byte
-= (pend
- p
);
999 i_byte
= best_above_byte
;
1002 string_char_byte_cache_bytepos
= i_byte
;
1003 string_char_byte_cache_charpos
= i
;
1004 string_char_byte_cache_string
= string
;
1009 /* Convert STRING to a multibyte string.
1010 Single-byte characters 0240 through 0377 are converted
1011 by adding nonascii_insert_offset to each. */
1014 string_make_multibyte (string
)
1020 if (STRING_MULTIBYTE (string
))
1023 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1024 XSTRING (string
)->size
);
1025 /* If all the chars are ASCII, they won't need any more bytes
1026 once converted. In that case, we can return STRING itself. */
1027 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1030 buf
= (unsigned char *) alloca (nbytes
);
1031 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1034 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1037 /* Convert STRING to a single-byte string. */
1040 string_make_unibyte (string
)
1045 if (! STRING_MULTIBYTE (string
))
1048 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1050 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1053 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1056 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1058 "Return the multibyte equivalent of STRING.\n\
1059 The function `unibyte-char-to-multibyte' is used to convert\n\
1060 each unibyte character to a multibyte character.")
1064 CHECK_STRING (string
, 0);
1066 return string_make_multibyte (string
);
1069 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1071 "Return the unibyte equivalent of STRING.\n\
1072 Multibyte character codes are converted to unibyte\n\
1073 by using just the low 8 bits.")
1077 CHECK_STRING (string
, 0);
1079 return string_make_unibyte (string
);
1082 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1084 "Return a unibyte string with the same individual bytes as STRING.\n\
1085 If STRING is unibyte, the result is STRING itself.\n\
1086 Otherwise it is a newly created string, with no text properties.")
1090 CHECK_STRING (string
, 0);
1092 if (STRING_MULTIBYTE (string
))
1094 string
= Fcopy_sequence (string
);
1095 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1096 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1097 SET_STRING_BYTES (XSTRING (string
), -1);
1102 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1104 "Return a multibyte string with the same individual bytes as STRING.\n\
1105 If STRING is multibyte, the result is STRING itself.\n\
1106 Otherwise it is a newly created string, with no text properties.")
1110 CHECK_STRING (string
, 0);
1112 if (! STRING_MULTIBYTE (string
))
1114 int nbytes
= STRING_BYTES (XSTRING (string
));
1115 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1117 string
= Fcopy_sequence (string
);
1118 XSTRING (string
)->size
= newlen
;
1119 XSTRING (string
)->size_byte
= nbytes
;
1120 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1125 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1126 "Return a copy of ALIST.\n\
1127 This is an alist which represents the same mapping from objects to objects,\n\
1128 but does not share the alist structure with ALIST.\n\
1129 The objects mapped (cars and cdrs of elements of the alist)\n\
1130 are shared, however.\n\
1131 Elements of ALIST that are not conses are also shared.")
1135 register Lisp_Object tem
;
1137 CHECK_LIST (alist
, 0);
1140 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1141 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1143 register Lisp_Object car
;
1147 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1152 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1153 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1154 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1155 If FROM or TO is negative, it counts from the end.\n\
1157 This function allows vectors as well as strings.")
1160 register Lisp_Object from
, to
;
1165 int from_char
, to_char
;
1166 int from_byte
, to_byte
;
1168 if (! (STRINGP (string
) || VECTORP (string
)))
1169 wrong_type_argument (Qarrayp
, string
);
1171 CHECK_NUMBER (from
, 1);
1173 if (STRINGP (string
))
1175 size
= XSTRING (string
)->size
;
1176 size_byte
= STRING_BYTES (XSTRING (string
));
1179 size
= XVECTOR (string
)->size
;
1184 to_byte
= size_byte
;
1188 CHECK_NUMBER (to
, 2);
1190 to_char
= XINT (to
);
1194 if (STRINGP (string
))
1195 to_byte
= string_char_to_byte (string
, to_char
);
1198 from_char
= XINT (from
);
1201 if (STRINGP (string
))
1202 from_byte
= string_char_to_byte (string
, from_char
);
1204 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1205 args_out_of_range_3 (string
, make_number (from_char
),
1206 make_number (to_char
));
1208 if (STRINGP (string
))
1210 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1211 to_char
- from_char
, to_byte
- from_byte
,
1212 STRING_MULTIBYTE (string
));
1213 copy_text_properties (make_number (from_char
), make_number (to_char
),
1214 string
, make_number (0), res
, Qnil
);
1217 res
= Fvector (to_char
- from_char
,
1218 XVECTOR (string
)->contents
+ from_char
);
1223 /* Extract a substring of STRING, giving start and end positions
1224 both in characters and in bytes. */
1227 substring_both (string
, from
, from_byte
, to
, to_byte
)
1229 int from
, from_byte
, to
, to_byte
;
1235 if (! (STRINGP (string
) || VECTORP (string
)))
1236 wrong_type_argument (Qarrayp
, string
);
1238 if (STRINGP (string
))
1240 size
= XSTRING (string
)->size
;
1241 size_byte
= STRING_BYTES (XSTRING (string
));
1244 size
= XVECTOR (string
)->size
;
1246 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1247 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1249 if (STRINGP (string
))
1251 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1252 to
- from
, to_byte
- from_byte
,
1253 STRING_MULTIBYTE (string
));
1254 copy_text_properties (make_number (from
), make_number (to
),
1255 string
, make_number (0), res
, Qnil
);
1258 res
= Fvector (to
- from
,
1259 XVECTOR (string
)->contents
+ from
);
1264 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1265 "Take cdr N times on LIST, returns the result.")
1268 register Lisp_Object list
;
1270 register int i
, num
;
1271 CHECK_NUMBER (n
, 0);
1273 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1277 wrong_type_argument (Qlistp
, list
);
1283 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1284 "Return the Nth element of LIST.\n\
1285 N counts from zero. If LIST is not that long, nil is returned.")
1287 Lisp_Object n
, list
;
1289 return Fcar (Fnthcdr (n
, list
));
1292 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1293 "Return element of SEQUENCE at index N.")
1295 register Lisp_Object sequence
, n
;
1297 CHECK_NUMBER (n
, 0);
1300 if (CONSP (sequence
) || NILP (sequence
))
1301 return Fcar (Fnthcdr (n
, sequence
));
1302 else if (STRINGP (sequence
) || VECTORP (sequence
)
1303 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1304 return Faref (sequence
, n
);
1306 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1310 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1311 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1312 The value is actually the tail of LIST whose car is ELT.")
1314 register Lisp_Object elt
;
1317 register Lisp_Object tail
;
1318 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1320 register Lisp_Object tem
;
1322 wrong_type_argument (Qlistp
, list
);
1324 if (! NILP (Fequal (elt
, tem
)))
1331 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1332 "Return non-nil if ELT is an element of LIST.\n\
1333 Comparison done with EQ. The value is actually the tail of LIST\n\
1336 Lisp_Object elt
, list
;
1340 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1344 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1348 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1355 if (!CONSP (list
) && !NILP (list
))
1356 list
= wrong_type_argument (Qlistp
, list
);
1361 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1362 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1363 The value is actually the element of LIST whose car is KEY.\n\
1364 Elements of LIST that are not conses are ignored.")
1366 Lisp_Object key
, list
;
1373 || (CONSP (XCAR (list
))
1374 && EQ (XCAR (XCAR (list
)), key
)))
1379 || (CONSP (XCAR (list
))
1380 && EQ (XCAR (XCAR (list
)), key
)))
1385 || (CONSP (XCAR (list
))
1386 && EQ (XCAR (XCAR (list
)), key
)))
1394 result
= XCAR (list
);
1395 else if (NILP (list
))
1398 result
= wrong_type_argument (Qlistp
, list
);
1403 /* Like Fassq but never report an error and do not allow quits.
1404 Use only on lists known never to be circular. */
1407 assq_no_quit (key
, list
)
1408 Lisp_Object key
, list
;
1411 && (!CONSP (XCAR (list
))
1412 || !EQ (XCAR (XCAR (list
)), key
)))
1415 return CONSP (list
) ? XCAR (list
) : Qnil
;
1418 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1419 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1420 The value is actually the element of LIST whose car equals KEY.")
1422 Lisp_Object key
, list
;
1424 Lisp_Object result
, car
;
1429 || (CONSP (XCAR (list
))
1430 && (car
= XCAR (XCAR (list
)),
1431 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1436 || (CONSP (XCAR (list
))
1437 && (car
= XCAR (XCAR (list
)),
1438 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1443 || (CONSP (XCAR (list
))
1444 && (car
= XCAR (XCAR (list
)),
1445 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1453 result
= XCAR (list
);
1454 else if (NILP (list
))
1457 result
= wrong_type_argument (Qlistp
, list
);
1462 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1463 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1464 The value is actually the element of LIST whose cdr is KEY.")
1466 register Lisp_Object key
;
1474 || (CONSP (XCAR (list
))
1475 && EQ (XCDR (XCAR (list
)), key
)))
1480 || (CONSP (XCAR (list
))
1481 && EQ (XCDR (XCAR (list
)), key
)))
1486 || (CONSP (XCAR (list
))
1487 && EQ (XCDR (XCAR (list
)), key
)))
1496 else if (CONSP (list
))
1497 result
= XCAR (list
);
1499 result
= wrong_type_argument (Qlistp
, list
);
1504 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1505 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1506 The value is actually the element of LIST whose cdr equals KEY.")
1508 Lisp_Object key
, list
;
1510 Lisp_Object result
, cdr
;
1515 || (CONSP (XCAR (list
))
1516 && (cdr
= XCDR (XCAR (list
)),
1517 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1522 || (CONSP (XCAR (list
))
1523 && (cdr
= XCDR (XCAR (list
)),
1524 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1529 || (CONSP (XCAR (list
))
1530 && (cdr
= XCDR (XCAR (list
)),
1531 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1539 result
= XCAR (list
);
1540 else if (NILP (list
))
1543 result
= wrong_type_argument (Qlistp
, list
);
1548 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1549 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1550 The modified LIST is returned. Comparison is done with `eq'.\n\
1551 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1552 therefore, write `(setq foo (delq element foo))'\n\
1553 to be sure of changing the value of `foo'.")
1555 register Lisp_Object elt
;
1558 register Lisp_Object tail
, prev
;
1559 register Lisp_Object tem
;
1563 while (!NILP (tail
))
1566 wrong_type_argument (Qlistp
, list
);
1573 Fsetcdr (prev
, XCDR (tail
));
1583 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1584 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1585 The modified LIST is returned. Comparison is done with `equal'.\n\
1586 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1587 it is simply using a different list.\n\
1588 Therefore, write `(setq foo (delete element foo))'\n\
1589 to be sure of changing the value of `foo'.")
1591 register Lisp_Object elt
;
1594 register Lisp_Object tail
, prev
;
1595 register Lisp_Object tem
;
1599 while (!NILP (tail
))
1602 wrong_type_argument (Qlistp
, list
);
1604 if (! NILP (Fequal (elt
, tem
)))
1609 Fsetcdr (prev
, XCDR (tail
));
1619 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1620 "Reverse LIST by modifying cdr pointers.\n\
1621 Returns the beginning of the reversed list.")
1625 register Lisp_Object prev
, tail
, next
;
1627 if (NILP (list
)) return list
;
1630 while (!NILP (tail
))
1634 wrong_type_argument (Qlistp
, list
);
1636 Fsetcdr (tail
, prev
);
1643 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1644 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1645 See also the function `nreverse', which is used more often.")
1651 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1652 new = Fcons (XCAR (list
), new);
1654 wrong_type_argument (Qconsp
, list
);
1658 Lisp_Object
merge ();
1660 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1661 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1662 Returns the sorted list. LIST is modified by side effects.\n\
1663 PREDICATE is called with two elements of LIST, and should return T\n\
1664 if the first element is \"less\" than the second.")
1666 Lisp_Object list
, predicate
;
1668 Lisp_Object front
, back
;
1669 register Lisp_Object len
, tem
;
1670 struct gcpro gcpro1
, gcpro2
;
1671 register int length
;
1674 len
= Flength (list
);
1675 length
= XINT (len
);
1679 XSETINT (len
, (length
/ 2) - 1);
1680 tem
= Fnthcdr (len
, list
);
1682 Fsetcdr (tem
, Qnil
);
1684 GCPRO2 (front
, back
);
1685 front
= Fsort (front
, predicate
);
1686 back
= Fsort (back
, predicate
);
1688 return merge (front
, back
, predicate
);
1692 merge (org_l1
, org_l2
, pred
)
1693 Lisp_Object org_l1
, org_l2
;
1697 register Lisp_Object tail
;
1699 register Lisp_Object l1
, l2
;
1700 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1707 /* It is sufficient to protect org_l1 and org_l2.
1708 When l1 and l2 are updated, we copy the new values
1709 back into the org_ vars. */
1710 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1730 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1746 Fsetcdr (tail
, tem
);
1752 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1753 "Extract a value from a property list.\n\
1754 PLIST is a property list, which is a list of the form\n\
1755 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1756 corresponding to the given PROP, or nil if PROP is not\n\
1757 one of the properties on the list.")
1760 register Lisp_Object prop
;
1762 register Lisp_Object tail
;
1763 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1765 register Lisp_Object tem
;
1768 return Fcar (XCDR (tail
));
1773 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1774 "Return the value of SYMBOL's PROPNAME property.\n\
1775 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1777 Lisp_Object symbol
, propname
;
1779 CHECK_SYMBOL (symbol
, 0);
1780 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1783 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1784 "Change value in PLIST of PROP to VAL.\n\
1785 PLIST is a property list, which is a list of the form\n\
1786 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1787 If PROP is already a property on the list, its value is set to VAL,\n\
1788 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1789 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1790 The PLIST is modified by side effects.")
1793 register Lisp_Object prop
;
1796 register Lisp_Object tail
, prev
;
1797 Lisp_Object newcell
;
1799 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1800 tail
= XCDR (XCDR (tail
)))
1802 if (EQ (prop
, XCAR (tail
)))
1804 Fsetcar (XCDR (tail
), val
);
1809 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1813 Fsetcdr (XCDR (prev
), newcell
);
1817 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1818 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1819 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1820 (symbol
, propname
, value
)
1821 Lisp_Object symbol
, propname
, value
;
1823 CHECK_SYMBOL (symbol
, 0);
1824 XSYMBOL (symbol
)->plist
1825 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1829 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1830 "Return t if two Lisp objects have similar structure and contents.\n\
1831 They must have the same data type.\n\
1832 Conses are compared by comparing the cars and the cdrs.\n\
1833 Vectors and strings are compared element by element.\n\
1834 Numbers are compared by value, but integers cannot equal floats.\n\
1835 (Use `=' if you want integers and floats to be able to be equal.)\n\
1836 Symbols must match exactly.")
1838 register Lisp_Object o1
, o2
;
1840 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1844 internal_equal (o1
, o2
, depth
)
1845 register Lisp_Object o1
, o2
;
1849 error ("Stack overflow in equal");
1855 if (XTYPE (o1
) != XTYPE (o2
))
1860 #ifdef LISP_FLOAT_TYPE
1862 return (extract_float (o1
) == extract_float (o2
));
1866 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1873 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1877 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1879 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1882 o1
= XOVERLAY (o1
)->plist
;
1883 o2
= XOVERLAY (o2
)->plist
;
1888 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1889 && (XMARKER (o1
)->buffer
== 0
1890 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1894 case Lisp_Vectorlike
:
1896 register int i
, size
;
1897 size
= XVECTOR (o1
)->size
;
1898 /* Pseudovectors have the type encoded in the size field, so this test
1899 actually checks that the objects have the same type as well as the
1901 if (XVECTOR (o2
)->size
!= size
)
1903 /* Boolvectors are compared much like strings. */
1904 if (BOOL_VECTOR_P (o1
))
1907 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1909 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1911 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1916 if (WINDOW_CONFIGURATIONP (o1
))
1917 return compare_window_configurations (o1
, o2
, 0);
1919 /* Aside from them, only true vectors, char-tables, and compiled
1920 functions are sensible to compare, so eliminate the others now. */
1921 if (size
& PSEUDOVECTOR_FLAG
)
1923 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1925 size
&= PSEUDOVECTOR_SIZE_MASK
;
1927 for (i
= 0; i
< size
; i
++)
1930 v1
= XVECTOR (o1
)->contents
[i
];
1931 v2
= XVECTOR (o2
)->contents
[i
];
1932 if (!internal_equal (v1
, v2
, depth
+ 1))
1940 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1942 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1944 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1945 STRING_BYTES (XSTRING (o1
))))
1952 extern Lisp_Object
Fmake_char_internal ();
1954 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1955 "Store each element of ARRAY with ITEM.\n\
1956 ARRAY is a vector, string, char-table, or bool-vector.")
1958 Lisp_Object array
, item
;
1960 register int size
, index
, charval
;
1962 if (VECTORP (array
))
1964 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1965 size
= XVECTOR (array
)->size
;
1966 for (index
= 0; index
< size
; index
++)
1969 else if (CHAR_TABLE_P (array
))
1971 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1972 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1973 for (index
= 0; index
< size
; index
++)
1975 XCHAR_TABLE (array
)->defalt
= Qnil
;
1977 else if (STRINGP (array
))
1979 register unsigned char *p
= XSTRING (array
)->data
;
1980 CHECK_NUMBER (item
, 1);
1981 charval
= XINT (item
);
1982 size
= XSTRING (array
)->size
;
1983 if (STRING_MULTIBYTE (array
))
1985 unsigned char workbuf
[4], *str
;
1986 int len
= CHAR_STRING (charval
, workbuf
, str
);
1987 int size_byte
= STRING_BYTES (XSTRING (array
));
1988 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1991 if (size
!= size_byte
)
1994 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1995 if (len
!= this_len
)
1996 error ("Attempt to change byte length of a string");
1999 for (i
= 0; i
< size_byte
; i
++)
2000 *p
++ = str
[i
% len
];
2003 for (index
= 0; index
< size
; index
++)
2006 else if (BOOL_VECTOR_P (array
))
2008 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2010 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2012 charval
= (! NILP (item
) ? -1 : 0);
2013 for (index
= 0; index
< size_in_chars
; index
++)
2018 array
= wrong_type_argument (Qarrayp
, array
);
2024 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2026 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2028 Lisp_Object char_table
;
2030 CHECK_CHAR_TABLE (char_table
, 0);
2032 return XCHAR_TABLE (char_table
)->purpose
;
2035 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2037 "Return the parent char-table of CHAR-TABLE.\n\
2038 The value is either nil or another char-table.\n\
2039 If CHAR-TABLE holds nil for a given character,\n\
2040 then the actual applicable value is inherited from the parent char-table\n\
2041 \(or from its parents, if necessary).")
2043 Lisp_Object char_table
;
2045 CHECK_CHAR_TABLE (char_table
, 0);
2047 return XCHAR_TABLE (char_table
)->parent
;
2050 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2052 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2053 PARENT must be either nil or another char-table.")
2054 (char_table
, parent
)
2055 Lisp_Object char_table
, parent
;
2059 CHECK_CHAR_TABLE (char_table
, 0);
2063 CHECK_CHAR_TABLE (parent
, 0);
2065 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2066 if (EQ (temp
, char_table
))
2067 error ("Attempt to make a chartable be its own parent");
2070 XCHAR_TABLE (char_table
)->parent
= parent
;
2075 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2077 "Return the value of CHAR-TABLE's extra-slot number N.")
2079 Lisp_Object char_table
, n
;
2081 CHECK_CHAR_TABLE (char_table
, 1);
2082 CHECK_NUMBER (n
, 2);
2084 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2085 args_out_of_range (char_table
, n
);
2087 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2090 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2091 Sset_char_table_extra_slot
,
2093 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2094 (char_table
, n
, value
)
2095 Lisp_Object char_table
, n
, value
;
2097 CHECK_CHAR_TABLE (char_table
, 1);
2098 CHECK_NUMBER (n
, 2);
2100 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2101 args_out_of_range (char_table
, n
);
2103 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2106 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2108 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2109 RANGE should be nil (for the default value)\n\
2110 a vector which identifies a character set or a row of a character set,\n\
2111 a character set name, or a character code.")
2113 Lisp_Object char_table
, range
;
2115 CHECK_CHAR_TABLE (char_table
, 0);
2117 if (EQ (range
, Qnil
))
2118 return XCHAR_TABLE (char_table
)->defalt
;
2119 else if (INTEGERP (range
))
2120 return Faref (char_table
, range
);
2121 else if (SYMBOLP (range
))
2123 Lisp_Object charset_info
;
2125 charset_info
= Fget (range
, Qcharset
);
2126 CHECK_VECTOR (charset_info
, 0);
2128 return Faref (char_table
,
2129 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2132 else if (VECTORP (range
))
2134 if (XVECTOR (range
)->size
== 1)
2135 return Faref (char_table
,
2136 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2139 int size
= XVECTOR (range
)->size
;
2140 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2141 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2142 size
<= 1 ? Qnil
: val
[1],
2143 size
<= 2 ? Qnil
: val
[2]);
2144 return Faref (char_table
, ch
);
2148 error ("Invalid RANGE argument to `char-table-range'");
2151 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2153 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2154 RANGE should be t (for all characters), nil (for the default value)\n\
2155 a vector which identifies a character set or a row of a character set,\n\
2156 a coding system, or a character code.")
2157 (char_table
, range
, value
)
2158 Lisp_Object char_table
, range
, value
;
2162 CHECK_CHAR_TABLE (char_table
, 0);
2165 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2166 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2167 else if (EQ (range
, Qnil
))
2168 XCHAR_TABLE (char_table
)->defalt
= value
;
2169 else if (SYMBOLP (range
))
2171 Lisp_Object charset_info
;
2173 charset_info
= Fget (range
, Qcharset
);
2174 CHECK_VECTOR (charset_info
, 0);
2176 return Faset (char_table
,
2177 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2181 else if (INTEGERP (range
))
2182 Faset (char_table
, range
, value
);
2183 else if (VECTORP (range
))
2185 if (XVECTOR (range
)->size
== 1)
2186 return Faset (char_table
,
2187 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2191 int size
= XVECTOR (range
)->size
;
2192 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2193 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2194 size
<= 1 ? Qnil
: val
[1],
2195 size
<= 2 ? Qnil
: val
[2]);
2196 return Faset (char_table
, ch
, value
);
2200 error ("Invalid RANGE argument to `set-char-table-range'");
2205 DEFUN ("set-char-table-default", Fset_char_table_default
,
2206 Sset_char_table_default
, 3, 3, 0,
2207 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2208 The generic character specifies the group of characters.\n\
2209 See also the documentation of make-char.")
2210 (char_table
, ch
, value
)
2211 Lisp_Object char_table
, ch
, value
;
2213 int c
, charset
, code1
, code2
;
2216 CHECK_CHAR_TABLE (char_table
, 0);
2217 CHECK_NUMBER (ch
, 1);
2220 SPLIT_CHAR (c
, charset
, code1
, code2
);
2222 /* Since we may want to set the default value for a character set
2223 not yet defined, we check only if the character set is in the
2224 valid range or not, instead of it is already defined or not. */
2225 if (! CHARSET_VALID_P (charset
))
2226 invalid_character (c
);
2228 if (charset
== CHARSET_ASCII
)
2229 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2231 /* Even if C is not a generic char, we had better behave as if a
2232 generic char is specified. */
2233 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2235 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2238 if (SUB_CHAR_TABLE_P (temp
))
2239 XCHAR_TABLE (temp
)->defalt
= value
;
2241 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2245 if (! SUB_CHAR_TABLE_P (char_table
))
2246 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2247 = make_sub_char_table (temp
));
2248 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2249 if (SUB_CHAR_TABLE_P (temp
))
2250 XCHAR_TABLE (temp
)->defalt
= value
;
2252 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2256 /* Look up the element in TABLE at index CH,
2257 and return it as an integer.
2258 If the element is nil, return CH itself.
2259 (Actually we do that for any non-integer.) */
2262 char_table_translate (table
, ch
)
2267 value
= Faref (table
, make_number (ch
));
2268 if (! INTEGERP (value
))
2270 return XINT (value
);
2273 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2274 character or group of characters that share a value.
2275 DEPTH is the current depth in the originally specified
2276 chartable, and INDICES contains the vector indices
2277 for the levels our callers have descended.
2279 ARG is passed to C_FUNCTION when that is called. */
2282 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2283 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2284 Lisp_Object function
, subtable
, arg
, *indices
;
2291 /* At first, handle ASCII and 8-bit European characters. */
2292 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2294 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2296 (*c_function
) (arg
, make_number (i
), elt
);
2298 call2 (function
, make_number (i
), elt
);
2300 #if 0 /* If the char table has entries for higher characters,
2301 we should report them. */
2302 if (NILP (current_buffer
->enable_multibyte_characters
))
2305 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2310 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2315 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2317 XSETFASTINT (indices
[depth
], i
);
2319 if (SUB_CHAR_TABLE_P (elt
))
2322 error ("Too deep char table");
2323 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2327 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2329 if (CHARSET_DEFINED_P (charset
))
2331 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2332 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2333 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2335 (*c_function
) (arg
, make_number (c
), elt
);
2337 call2 (function
, make_number (c
), elt
);
2343 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2345 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2346 FUNCTION is called with two arguments--a key and a value.\n\
2347 The key is always a possible IDX argument to `aref'.")
2348 (function
, char_table
)
2349 Lisp_Object function
, char_table
;
2351 /* The depth of char table is at most 3. */
2352 Lisp_Object indices
[3];
2354 CHECK_CHAR_TABLE (char_table
, 1);
2356 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2366 Lisp_Object args
[2];
2369 return Fnconc (2, args
);
2371 return Fnconc (2, &s1
);
2372 #endif /* NO_ARG_ARRAY */
2375 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2376 "Concatenate any number of lists by altering them.\n\
2377 Only the last argument is not altered, and need not be a list.")
2382 register int argnum
;
2383 register Lisp_Object tail
, tem
, val
;
2387 for (argnum
= 0; argnum
< nargs
; argnum
++)
2390 if (NILP (tem
)) continue;
2395 if (argnum
+ 1 == nargs
) break;
2398 tem
= wrong_type_argument (Qlistp
, tem
);
2407 tem
= args
[argnum
+ 1];
2408 Fsetcdr (tail
, tem
);
2410 args
[argnum
+ 1] = tail
;
2416 /* This is the guts of all mapping functions.
2417 Apply FN to each element of SEQ, one by one,
2418 storing the results into elements of VALS, a C vector of Lisp_Objects.
2419 LENI is the length of VALS, which should also be the length of SEQ. */
2422 mapcar1 (leni
, vals
, fn
, seq
)
2425 Lisp_Object fn
, seq
;
2427 register Lisp_Object tail
;
2430 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2432 /* Don't let vals contain any garbage when GC happens. */
2433 for (i
= 0; i
< leni
; i
++)
2436 GCPRO3 (dummy
, fn
, seq
);
2438 gcpro1
.nvars
= leni
;
2439 /* We need not explicitly protect `tail' because it is used only on lists, and
2440 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2444 for (i
= 0; i
< leni
; i
++)
2446 dummy
= XVECTOR (seq
)->contents
[i
];
2447 vals
[i
] = call1 (fn
, dummy
);
2450 else if (BOOL_VECTOR_P (seq
))
2452 for (i
= 0; i
< leni
; i
++)
2455 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2456 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2461 vals
[i
] = call1 (fn
, dummy
);
2464 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2466 /* Single-byte string. */
2467 for (i
= 0; i
< leni
; i
++)
2469 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2470 vals
[i
] = call1 (fn
, dummy
);
2473 else if (STRINGP (seq
))
2475 /* Multi-byte string. */
2478 for (i
= 0, i_byte
= 0; i
< leni
;)
2483 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2484 XSETFASTINT (dummy
, c
);
2485 vals
[i_before
] = call1 (fn
, dummy
);
2488 else /* Must be a list, since Flength did not get an error */
2491 for (i
= 0; i
< leni
; i
++)
2493 vals
[i
] = call1 (fn
, Fcar (tail
));
2501 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2502 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2503 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2504 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2505 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2506 (function
, sequence
, separator
)
2507 Lisp_Object function
, sequence
, separator
;
2512 register Lisp_Object
*args
;
2514 struct gcpro gcpro1
;
2516 len
= Flength (sequence
);
2518 nargs
= leni
+ leni
- 1;
2519 if (nargs
< 0) return build_string ("");
2521 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2524 mapcar1 (leni
, args
, function
, sequence
);
2527 for (i
= leni
- 1; i
>= 0; i
--)
2528 args
[i
+ i
] = args
[i
];
2530 for (i
= 1; i
< nargs
; i
+= 2)
2531 args
[i
] = separator
;
2533 return Fconcat (nargs
, args
);
2536 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2537 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2538 The result is a list just as long as SEQUENCE.\n\
2539 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2540 (function
, sequence
)
2541 Lisp_Object function
, sequence
;
2543 register Lisp_Object len
;
2545 register Lisp_Object
*args
;
2547 len
= Flength (sequence
);
2548 leni
= XFASTINT (len
);
2549 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2551 mapcar1 (leni
, args
, function
, sequence
);
2553 return Flist (leni
, args
);
2556 /* Anything that calls this function must protect from GC! */
2558 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2559 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2560 Takes one argument, which is the string to display to ask the question.\n\
2561 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2562 No confirmation of the answer is requested; a single character is enough.\n\
2563 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2564 the bindings in `query-replace-map'; see the documentation of that variable\n\
2565 for more information. In this case, the useful bindings are `act', `skip',\n\
2566 `recenter', and `quit'.\)\n\
2568 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2573 register Lisp_Object obj
, key
, def
, map
;
2574 register int answer
;
2575 Lisp_Object xprompt
;
2576 Lisp_Object args
[2];
2577 struct gcpro gcpro1
, gcpro2
;
2578 int count
= specpdl_ptr
- specpdl
;
2580 specbind (Qcursor_in_echo_area
, Qt
);
2582 map
= Fsymbol_value (intern ("query-replace-map"));
2584 CHECK_STRING (prompt
, 0);
2586 GCPRO2 (prompt
, xprompt
);
2592 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2596 Lisp_Object pane
, menu
;
2597 redisplay_preserve_echo_area ();
2598 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2599 Fcons (Fcons (build_string ("No"), Qnil
),
2601 menu
= Fcons (prompt
, pane
);
2602 obj
= Fx_popup_dialog (Qt
, menu
);
2603 answer
= !NILP (obj
);
2606 #endif /* HAVE_MENUS */
2607 cursor_in_echo_area
= 1;
2608 choose_minibuf_frame ();
2609 message_with_string ("%s(y or n) ", xprompt
, 0);
2611 if (minibuffer_auto_raise
)
2613 Lisp_Object mini_frame
;
2615 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2617 Fraise_frame (mini_frame
);
2620 obj
= read_filtered_event (1, 0, 0, 0);
2621 cursor_in_echo_area
= 0;
2622 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2625 key
= Fmake_vector (make_number (1), obj
);
2626 def
= Flookup_key (map
, key
, Qt
);
2628 if (EQ (def
, intern ("skip")))
2633 else if (EQ (def
, intern ("act")))
2638 else if (EQ (def
, intern ("recenter")))
2644 else if (EQ (def
, intern ("quit")))
2646 /* We want to exit this command for exit-prefix,
2647 and this is the only way to do it. */
2648 else if (EQ (def
, intern ("exit-prefix")))
2653 /* If we don't clear this, then the next call to read_char will
2654 return quit_char again, and we'll enter an infinite loop. */
2659 if (EQ (xprompt
, prompt
))
2661 args
[0] = build_string ("Please answer y or n. ");
2663 xprompt
= Fconcat (2, args
);
2668 if (! noninteractive
)
2670 cursor_in_echo_area
= -1;
2671 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2675 unbind_to (count
, Qnil
);
2676 return answer
? Qt
: Qnil
;
2679 /* This is how C code calls `yes-or-no-p' and allows the user
2682 Anything that calls this function must protect from GC! */
2685 do_yes_or_no_p (prompt
)
2688 return call1 (intern ("yes-or-no-p"), prompt
);
2691 /* Anything that calls this function must protect from GC! */
2693 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2694 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2695 Takes one argument, which is the string to display to ask the question.\n\
2696 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2697 The user must confirm the answer with RET,\n\
2698 and can edit it until it has been confirmed.\n\
2700 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2705 register Lisp_Object ans
;
2706 Lisp_Object args
[2];
2707 struct gcpro gcpro1
;
2709 CHECK_STRING (prompt
, 0);
2712 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2716 Lisp_Object pane
, menu
, obj
;
2717 redisplay_preserve_echo_area ();
2718 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2719 Fcons (Fcons (build_string ("No"), Qnil
),
2722 menu
= Fcons (prompt
, pane
);
2723 obj
= Fx_popup_dialog (Qt
, menu
);
2727 #endif /* HAVE_MENUS */
2730 args
[1] = build_string ("(yes or no) ");
2731 prompt
= Fconcat (2, args
);
2737 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2738 Qyes_or_no_p_history
, Qnil
,
2740 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2745 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2753 message ("Please answer yes or no.");
2754 Fsleep_for (make_number (2), Qnil
);
2758 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2759 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2760 Each of the three load averages is multiplied by 100,\n\
2761 then converted to integer.\n\
2762 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2763 These floats are not multiplied by 100.\n\n\
2764 If the 5-minute or 15-minute load averages are not available, return a\n\
2765 shortened list, containing only those averages which are available.")
2767 Lisp_Object use_floats
;
2770 int loads
= getloadavg (load_ave
, 3);
2771 Lisp_Object ret
= Qnil
;
2774 error ("load-average not implemented for this operating system");
2778 Lisp_Object load
= (NILP (use_floats
) ?
2779 make_number ((int) (100.0 * load_ave
[loads
]))
2780 : make_float (load_ave
[loads
]));
2781 ret
= Fcons (load
, ret
);
2787 Lisp_Object Vfeatures
;
2789 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2790 "Returns t if FEATURE is present in this Emacs.\n\
2791 Use this to conditionalize execution of lisp code based on the presence or\n\
2792 absence of emacs or environment extensions.\n\
2793 Use `provide' to declare that a feature is available.\n\
2794 This function looks at the value of the variable `features'.")
2796 Lisp_Object feature
;
2798 register Lisp_Object tem
;
2799 CHECK_SYMBOL (feature
, 0);
2800 tem
= Fmemq (feature
, Vfeatures
);
2801 return (NILP (tem
)) ? Qnil
: Qt
;
2804 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2805 "Announce that FEATURE is a feature of the current Emacs.")
2807 Lisp_Object feature
;
2809 register Lisp_Object tem
;
2810 CHECK_SYMBOL (feature
, 0);
2811 if (!NILP (Vautoload_queue
))
2812 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2813 tem
= Fmemq (feature
, Vfeatures
);
2815 Vfeatures
= Fcons (feature
, Vfeatures
);
2816 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2820 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2821 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2822 If FEATURE is not a member of the list `features', then the feature\n\
2823 is not loaded; so load the file FILENAME.\n\
2824 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2825 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2826 If the optional third argument NOERROR is non-nil,\n\
2827 then return nil if the file is not found.\n\
2828 Normally the return value is FEATURE.")
2829 (feature
, file_name
, noerror
)
2830 Lisp_Object feature
, file_name
, noerror
;
2832 register Lisp_Object tem
;
2833 CHECK_SYMBOL (feature
, 0);
2834 tem
= Fmemq (feature
, Vfeatures
);
2835 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2838 int count
= specpdl_ptr
- specpdl
;
2840 /* Value saved here is to be restored into Vautoload_queue */
2841 record_unwind_protect (un_autoload
, Vautoload_queue
);
2842 Vautoload_queue
= Qt
;
2844 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2845 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2846 /* If load failed entirely, return nil. */
2848 return unbind_to (count
, Qnil
);
2850 tem
= Fmemq (feature
, Vfeatures
);
2852 error ("Required feature %s was not provided",
2853 XSYMBOL (feature
)->name
->data
);
2855 /* Once loading finishes, don't undo it. */
2856 Vautoload_queue
= Qt
;
2857 feature
= unbind_to (count
, feature
);
2862 /* Primitives for work of the "widget" library.
2863 In an ideal world, this section would not have been necessary.
2864 However, lisp function calls being as slow as they are, it turns
2865 out that some functions in the widget library (wid-edit.el) are the
2866 bottleneck of Widget operation. Here is their translation to C,
2867 for the sole reason of efficiency. */
2869 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2870 "Return non-nil if PLIST has the property PROP.\n\
2871 PLIST is a property list, which is a list of the form\n\
2872 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2873 Unlike `plist-get', this allows you to distinguish between a missing\n\
2874 property and a property with the value nil.\n\
2875 The value is actually the tail of PLIST whose car is PROP.")
2877 Lisp_Object plist
, prop
;
2879 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2882 plist
= XCDR (plist
);
2883 plist
= CDR (plist
);
2888 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2889 "In WIDGET, set PROPERTY to VALUE.\n\
2890 The value can later be retrieved with `widget-get'.")
2891 (widget
, property
, value
)
2892 Lisp_Object widget
, property
, value
;
2894 CHECK_CONS (widget
, 1);
2895 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2899 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2900 "In WIDGET, get the value of PROPERTY.\n\
2901 The value could either be specified when the widget was created, or\n\
2902 later with `widget-put'.")
2904 Lisp_Object widget
, property
;
2912 CHECK_CONS (widget
, 1);
2913 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2919 tmp
= XCAR (widget
);
2922 widget
= Fget (tmp
, Qwidget_type
);
2926 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2927 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2928 ARGS are passed as extra arguments to the function.")
2933 /* This function can GC. */
2934 Lisp_Object newargs
[3];
2935 struct gcpro gcpro1
, gcpro2
;
2938 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2939 newargs
[1] = args
[0];
2940 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2941 GCPRO2 (newargs
[0], newargs
[2]);
2942 result
= Fapply (3, newargs
);
2947 /* base64 encode/decode functions.
2948 Based on code from GNU recode. */
2950 #define MIME_LINE_LENGTH 76
2952 #define IS_ASCII(Character) \
2954 #define IS_BASE64(Character) \
2955 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2956 #define IS_BASE64_IGNORABLE(Character) \
2957 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2958 || (Character) == '\f' || (Character) == '\r')
2960 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2961 character or return retval if there are no characters left to
2963 #define READ_QUADRUPLET_BYTE(retval) \
2970 while (IS_BASE64_IGNORABLE (c))
2972 /* Don't use alloca for regions larger than this, lest we overflow
2974 #define MAX_ALLOCA 16*1024
2976 /* Table of characters coding the 64 values. */
2977 static char base64_value_to_char
[64] =
2979 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2980 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2981 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2982 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2983 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2984 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2985 '8', '9', '+', '/' /* 60-63 */
2988 /* Table of base64 values for first 128 characters. */
2989 static short base64_char_to_value
[128] =
2991 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2992 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2993 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2994 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2995 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2996 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2997 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2998 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2999 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3000 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3001 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3002 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3003 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3006 /* The following diagram shows the logical steps by which three octets
3007 get transformed into four base64 characters.
3009 .--------. .--------. .--------.
3010 |aaaaaabb| |bbbbcccc| |ccdddddd|
3011 `--------' `--------' `--------'
3013 .--------+--------+--------+--------.
3014 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3015 `--------+--------+--------+--------'
3017 .--------+--------+--------+--------.
3018 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3019 `--------+--------+--------+--------'
3021 The octets are divided into 6 bit chunks, which are then encoded into
3022 base64 characters. */
3025 static int base64_encode_1
P_ ((const char *, char *, int, int));
3026 static int base64_decode_1
P_ ((const char *, char *, int));
3028 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3030 "Base64-encode the region between BEG and END.\n\
3031 Return the length of the encoded text.\n\
3032 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3033 into shorter lines.")
3034 (beg
, end
, no_line_break
)
3035 Lisp_Object beg
, end
, no_line_break
;
3038 int allength
, length
;
3039 int ibeg
, iend
, encoded_length
;
3042 validate_region (&beg
, &end
);
3044 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3045 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3046 move_gap_both (XFASTINT (beg
), ibeg
);
3048 /* We need to allocate enough room for encoding the text.
3049 We need 33 1/3% more space, plus a newline every 76
3050 characters, and then we round up. */
3051 length
= iend
- ibeg
;
3052 allength
= length
+ length
/3 + 1;
3053 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3055 if (allength
<= MAX_ALLOCA
)
3056 encoded
= (char *) alloca (allength
);
3058 encoded
= (char *) xmalloc (allength
);
3059 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3060 NILP (no_line_break
));
3061 if (encoded_length
> allength
)
3064 /* Now we have encoded the region, so we insert the new contents
3065 and delete the old. (Insert first in order to preserve markers.) */
3066 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3067 insert (encoded
, encoded_length
);
3068 if (allength
> MAX_ALLOCA
)
3070 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3072 /* If point was outside of the region, restore it exactly; else just
3073 move to the beginning of the region. */
3074 if (old_pos
>= XFASTINT (end
))
3075 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3076 else if (old_pos
> XFASTINT (beg
))
3077 old_pos
= XFASTINT (beg
);
3080 /* We return the length of the encoded text. */
3081 return make_number (encoded_length
);
3084 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3086 "Base64-encode STRING and return the result.\n\
3087 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3088 into shorter lines.")
3089 (string
, no_line_break
)
3090 Lisp_Object string
, no_line_break
;
3092 int allength
, length
, encoded_length
;
3094 Lisp_Object encoded_string
;
3096 CHECK_STRING (string
, 1);
3098 /* We need to allocate enough room for encoding the text.
3099 We need 33 1/3% more space, plus a newline every 76
3100 characters, and then we round up. */
3101 length
= STRING_BYTES (XSTRING (string
));
3102 allength
= length
+ length
/3 + 1;
3103 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3105 /* We need to allocate enough room for decoding the text. */
3106 if (allength
<= MAX_ALLOCA
)
3107 encoded
= (char *) alloca (allength
);
3109 encoded
= (char *) xmalloc (allength
);
3111 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3112 encoded
, length
, NILP (no_line_break
));
3113 if (encoded_length
> allength
)
3116 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3117 if (allength
> MAX_ALLOCA
)
3120 return encoded_string
;
3124 base64_encode_1 (from
, to
, length
, line_break
)
3130 int counter
= 0, i
= 0;
3139 /* Wrap line every 76 characters. */
3143 if (counter
< MIME_LINE_LENGTH
/ 4)
3152 /* Process first byte of a triplet. */
3154 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3155 value
= (0x03 & c
) << 4;
3157 /* Process second byte of a triplet. */
3161 *e
++ = base64_value_to_char
[value
];
3169 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3170 value
= (0x0f & c
) << 2;
3172 /* Process third byte of a triplet. */
3176 *e
++ = base64_value_to_char
[value
];
3183 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3184 *e
++ = base64_value_to_char
[0x3f & c
];
3191 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3193 "Base64-decode the region between BEG and END.\n\
3194 Return the length of the decoded text.\n\
3195 If the region can't be decoded, return nil and don't modify the buffer.")
3197 Lisp_Object beg
, end
;
3199 int ibeg
, iend
, length
;
3205 validate_region (&beg
, &end
);
3207 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3208 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3210 length
= iend
- ibeg
;
3211 /* We need to allocate enough room for decoding the text. */
3212 if (length
<= MAX_ALLOCA
)
3213 decoded
= (char *) alloca (length
);
3215 decoded
= (char *) xmalloc (length
);
3217 move_gap_both (XFASTINT (beg
), ibeg
);
3218 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3219 if (decoded_length
> length
)
3222 if (decoded_length
< 0)
3224 /* The decoding wasn't possible. */
3225 if (length
> MAX_ALLOCA
)
3230 /* Now we have decoded the region, so we insert the new contents
3231 and delete the old. (Insert first in order to preserve markers.) */
3232 /* We insert two spaces, then insert the decoded text in between
3233 them, at last, delete those extra two spaces. This is to avoid
3234 byte combining while inserting. */
3235 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3236 insert_1_both (" ", 2, 2, 0, 1, 0);
3237 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3238 insert (decoded
, decoded_length
);
3239 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3240 if (length
> MAX_ALLOCA
)
3242 /* At first delete the original text. This never cause byte
3244 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3245 iend
+ decoded_length
+ 2, 1);
3246 /* Next delete the extra spaces. This will cause byte combining
3248 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3249 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3250 inserted_chars
= PT
- XFASTINT (beg
);
3252 /* If point was outside of the region, restore it exactly; else just
3253 move to the beginning of the region. */
3254 if (old_pos
>= XFASTINT (end
))
3255 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3256 else if (old_pos
> XFASTINT (beg
))
3257 old_pos
= XFASTINT (beg
);
3258 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3260 return make_number (inserted_chars
);
3263 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3265 "Base64-decode STRING and return the result.")
3270 int length
, decoded_length
;
3271 Lisp_Object decoded_string
;
3273 CHECK_STRING (string
, 1);
3275 length
= STRING_BYTES (XSTRING (string
));
3276 /* We need to allocate enough room for decoding the text. */
3277 if (length
<= MAX_ALLOCA
)
3278 decoded
= (char *) alloca (length
);
3280 decoded
= (char *) xmalloc (length
);
3282 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3283 if (decoded_length
> length
)
3286 if (decoded_length
< 0)
3287 /* The decoding wasn't possible. */
3288 decoded_string
= Qnil
;
3290 decoded_string
= make_string (decoded
, decoded_length
);
3292 if (length
> MAX_ALLOCA
)
3295 return decoded_string
;
3299 base64_decode_1 (from
, to
, length
)
3307 unsigned long value
;
3311 /* Process first byte of a quadruplet. */
3313 READ_QUADRUPLET_BYTE (e
-to
);
3317 value
= base64_char_to_value
[c
] << 18;
3319 /* Process second byte of a quadruplet. */
3321 READ_QUADRUPLET_BYTE (-1);
3325 value
|= base64_char_to_value
[c
] << 12;
3327 *e
++ = (unsigned char) (value
>> 16);
3329 /* Process third byte of a quadruplet. */
3331 READ_QUADRUPLET_BYTE (-1);
3335 READ_QUADRUPLET_BYTE (-1);
3344 value
|= base64_char_to_value
[c
] << 6;
3346 *e
++ = (unsigned char) (0xff & value
>> 8);
3348 /* Process fourth byte of a quadruplet. */
3350 READ_QUADRUPLET_BYTE (-1);
3357 value
|= base64_char_to_value
[c
];
3359 *e
++ = (unsigned char) (0xff & value
);
3365 /***********************************************************************
3367 ***** Hash Tables *****
3369 ***********************************************************************/
3371 /* Implemented by gerd@gnu.org. This hash table implementation was
3372 inspired by CMUCL hash tables. */
3376 1. For small tables, association lists are probably faster than
3377 hash tables because they have lower overhead.
3379 For uses of hash tables where the O(1) behavior of table
3380 operations is not a requirement, it might therefore be a good idea
3381 not to hash. Instead, we could just do a linear search in the
3382 key_and_value vector of the hash table. This could be done
3383 if a `:linear-search t' argument is given to make-hash-table. */
3386 /* Return the contents of vector V at index IDX. */
3388 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3390 /* Value is the key part of entry IDX in hash table H. */
3392 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3394 /* Value is the value part of entry IDX in hash table H. */
3396 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3398 /* Value is the index of the next entry following the one at IDX
3401 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3403 /* Value is the hash code computed for entry IDX in hash table H. */
3405 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3407 /* Value is the index of the element in hash table H that is the
3408 start of the collision list at index IDX in the index vector of H. */
3410 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3412 /* Value is the size of hash table H. */
3414 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3416 /* The list of all weak hash tables. Don't staticpro this one. */
3418 Lisp_Object Vweak_hash_tables
;
3420 /* Various symbols. */
3422 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3423 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3424 Lisp_Object Qhash_table_test
;
3426 /* Function prototypes. */
3428 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3429 static int next_almost_prime
P_ ((int));
3430 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3431 static Lisp_Object larger_vector
P_ ((Lisp_Object
, int, Lisp_Object
));
3432 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3433 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3434 Lisp_Object
, unsigned));
3435 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3436 Lisp_Object
, unsigned));
3437 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3438 unsigned, Lisp_Object
, unsigned));
3439 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3440 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3441 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3442 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3444 static unsigned sxhash_string
P_ ((unsigned char *, int));
3445 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3446 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3447 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3451 /***********************************************************************
3453 ***********************************************************************/
3455 /* If OBJ is a Lisp hash table, return a pointer to its struct
3456 Lisp_Hash_Table. Otherwise, signal an error. */
3458 static struct Lisp_Hash_Table
*
3459 check_hash_table (obj
)
3462 CHECK_HASH_TABLE (obj
, 0);
3463 return XHASH_TABLE (obj
);
3467 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3471 next_almost_prime (n
)
3484 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3485 which USED[I] is non-zero. If found at index I in ARGS, set
3486 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3487 -1. This function is used to extract a keyword/argument pair from
3488 a DEFUN parameter list. */
3491 get_key_arg (key
, nargs
, args
, used
)
3499 for (i
= 0; i
< nargs
- 1; ++i
)
3500 if (!used
[i
] && EQ (args
[i
], key
))
3515 /* Return a Lisp vector which has the same contents as VEC but has
3516 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3517 vector that are not copied from VEC are set to INIT. */
3520 larger_vector (vec
, new_size
, init
)
3525 struct Lisp_Vector
*v
;
3528 xassert (VECTORP (vec
));
3529 old_size
= XVECTOR (vec
)->size
;
3530 xassert (new_size
>= old_size
);
3532 v
= allocate_vectorlike (new_size
);
3534 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3535 old_size
* sizeof *v
->contents
);
3536 for (i
= old_size
; i
< new_size
; ++i
)
3537 v
->contents
[i
] = init
;
3538 XSETVECTOR (vec
, v
);
3543 /***********************************************************************
3545 ***********************************************************************/
3547 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3548 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3549 KEY2 are the same. */
3552 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3553 struct Lisp_Hash_Table
*h
;
3554 Lisp_Object key1
, key2
;
3555 unsigned hash1
, hash2
;
3557 return (FLOATP (key1
)
3559 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3563 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3564 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3565 KEY2 are the same. */
3568 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3569 struct Lisp_Hash_Table
*h
;
3570 Lisp_Object key1
, key2
;
3571 unsigned hash1
, hash2
;
3573 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3577 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3578 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3579 if KEY1 and KEY2 are the same. */
3582 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3583 struct Lisp_Hash_Table
*h
;
3584 Lisp_Object key1
, key2
;
3585 unsigned hash1
, hash2
;
3589 Lisp_Object args
[3];
3591 args
[0] = h
->user_cmp_function
;
3594 return !NILP (Ffuncall (3, args
));
3601 /* Value is a hash code for KEY for use in hash table H which uses
3602 `eq' to compare keys. The hash code returned is guaranteed to fit
3603 in a Lisp integer. */
3607 struct Lisp_Hash_Table
*h
;
3610 /* Lisp strings can change their address. Don't try to compute a
3611 hash code for a string from its address. */
3613 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3615 return XUINT (key
) ^ XGCTYPE (key
);
3619 /* Value is a hash code for KEY for use in hash table H which uses
3620 `eql' to compare keys. The hash code returned is guaranteed to fit
3621 in a Lisp integer. */
3625 struct Lisp_Hash_Table
*h
;
3628 /* Lisp strings can change their address. Don't try to compute a
3629 hash code for a string from its address. */
3631 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3632 else if (FLOATP (key
))
3633 return sxhash (key
, 0);
3635 return XUINT (key
) ^ XGCTYPE (key
);
3639 /* Value is a hash code for KEY for use in hash table H which uses
3640 `equal' to compare keys. The hash code returned is guaranteed to fit
3641 in a Lisp integer. */
3644 hashfn_equal (h
, key
)
3645 struct Lisp_Hash_Table
*h
;
3648 return sxhash (key
, 0);
3652 /* Value is a hash code for KEY for use in hash table H which uses as
3653 user-defined function to compare keys. The hash code returned is
3654 guaranteed to fit in a Lisp integer. */
3657 hashfn_user_defined (h
, key
)
3658 struct Lisp_Hash_Table
*h
;
3661 Lisp_Object args
[2], hash
;
3663 args
[0] = h
->user_hash_function
;
3665 hash
= Ffuncall (2, args
);
3666 if (!INTEGERP (hash
))
3668 list2 (build_string ("Illegal hash code returned from \
3669 user-supplied hash function"),
3671 return XUINT (hash
);
3675 /* Create and initialize a new hash table.
3677 TEST specifies the test the hash table will use to compare keys.
3678 It must be either one of the predefined tests `eq', `eql' or
3679 `equal' or a symbol denoting a user-defined test named TEST with
3680 test and hash functions USER_TEST and USER_HASH.
3682 Give the table initial capacity SIZE, SIZE > 0, an integer.
3684 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3685 new size when it becomes full is computed by adding REHASH_SIZE to
3686 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3687 table's new size is computed by multiplying its old size with
3690 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3691 be resized when the ratio of (number of entries in the table) /
3692 (table size) is >= REHASH_THRESHOLD.
3694 WEAK specifies the weakness of the table. If non-nil, it must be
3695 one of the symbols `key', `value' or t. */
3698 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3699 user_test
, user_hash
)
3700 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3701 Lisp_Object user_test
, user_hash
;
3703 struct Lisp_Hash_Table
*h
;
3704 struct Lisp_Vector
*v
;
3706 int index_size
, i
, len
, sz
;
3708 /* Preconditions. */
3709 xassert (SYMBOLP (test
));
3710 xassert (INTEGERP (size
) && XINT (size
) > 0);
3711 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3712 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3713 xassert (FLOATP (rehash_threshold
)
3714 && XFLOATINT (rehash_threshold
) > 0
3715 && XFLOATINT (rehash_threshold
) <= 1.0);
3717 /* Allocate a vector, and initialize it. */
3718 len
= VECSIZE (struct Lisp_Hash_Table
);
3719 v
= allocate_vectorlike (len
);
3721 for (i
= 0; i
< len
; ++i
)
3722 v
->contents
[i
] = Qnil
;
3724 /* Initialize hash table slots. */
3725 sz
= XFASTINT (size
);
3726 h
= (struct Lisp_Hash_Table
*) v
;
3729 if (EQ (test
, Qeql
))
3731 h
->cmpfn
= cmpfn_eql
;
3732 h
->hashfn
= hashfn_eql
;
3734 else if (EQ (test
, Qeq
))
3737 h
->hashfn
= hashfn_eq
;
3739 else if (EQ (test
, Qequal
))
3741 h
->cmpfn
= cmpfn_equal
;
3742 h
->hashfn
= hashfn_equal
;
3746 h
->user_cmp_function
= user_test
;
3747 h
->user_hash_function
= user_hash
;
3748 h
->cmpfn
= cmpfn_user_defined
;
3749 h
->hashfn
= hashfn_user_defined
;
3753 h
->rehash_threshold
= rehash_threshold
;
3754 h
->rehash_size
= rehash_size
;
3755 h
->count
= make_number (0);
3756 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3757 h
->hash
= Fmake_vector (size
, Qnil
);
3758 h
->next
= Fmake_vector (size
, Qnil
);
3759 index_size
= next_almost_prime (sz
/ XFLOATINT (rehash_threshold
));
3760 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3762 /* Set up the free list. */
3763 for (i
= 0; i
< sz
- 1; ++i
)
3764 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3765 h
->next_free
= make_number (0);
3767 XSET_HASH_TABLE (table
, h
);
3768 xassert (HASH_TABLE_P (table
));
3769 xassert (XHASH_TABLE (table
) == h
);
3771 /* Maybe add this hash table to the list of all weak hash tables. */
3773 h
->next_weak
= Qnil
;
3776 h
->next_weak
= Vweak_hash_tables
;
3777 Vweak_hash_tables
= table
;
3784 /* Return a copy of hash table H1. Keys and values are not copied,
3785 only the table itself is. */
3788 copy_hash_table (h1
)
3789 struct Lisp_Hash_Table
*h1
;
3792 struct Lisp_Hash_Table
*h2
;
3793 struct Lisp_Vector
*v
, *next
;
3796 len
= VECSIZE (struct Lisp_Hash_Table
);
3797 v
= allocate_vectorlike (len
);
3798 h2
= (struct Lisp_Hash_Table
*) v
;
3799 next
= h2
->vec_next
;
3800 bcopy (h1
, h2
, sizeof *h2
);
3801 h2
->vec_next
= next
;
3802 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3803 h2
->hash
= Fcopy_sequence (h1
->hash
);
3804 h2
->next
= Fcopy_sequence (h1
->next
);
3805 h2
->index
= Fcopy_sequence (h1
->index
);
3806 XSET_HASH_TABLE (table
, h2
);
3808 /* Maybe add this hash table to the list of all weak hash tables. */
3809 if (!NILP (h2
->weak
))
3811 h2
->next_weak
= Vweak_hash_tables
;
3812 Vweak_hash_tables
= table
;
3819 /* Resize hash table H if it's too full. If H cannot be resized
3820 because it's already too large, throw an error. */
3823 maybe_resize_hash_table (h
)
3824 struct Lisp_Hash_Table
*h
;
3826 if (NILP (h
->next_free
))
3828 int old_size
= HASH_TABLE_SIZE (h
);
3829 int i
, new_size
, index_size
;
3831 if (INTEGERP (h
->rehash_size
))
3832 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3834 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3835 index_size
= next_almost_prime (new_size
3836 / XFLOATINT (h
->rehash_threshold
));
3837 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3838 error ("Hash table too large to resize");
3840 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3841 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3842 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3843 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3845 /* Update the free list. Do it so that new entries are added at
3846 the end of the free list. This makes some operations like
3848 for (i
= old_size
; i
< new_size
- 1; ++i
)
3849 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3851 if (!NILP (h
->next_free
))
3853 Lisp_Object last
, next
;
3855 last
= h
->next_free
;
3856 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3860 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3863 XSETFASTINT (h
->next_free
, old_size
);
3866 for (i
= 0; i
< old_size
; ++i
)
3867 if (!NILP (HASH_HASH (h
, i
)))
3869 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3870 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3871 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3872 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3878 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3879 the hash code of KEY. Value is the index of the entry in H
3880 matching KEY, or -1 if not found. */
3883 hash_lookup (h
, key
, hash
)
3884 struct Lisp_Hash_Table
*h
;
3889 int start_of_bucket
;
3892 hash_code
= h
->hashfn (h
, key
);
3896 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3897 idx
= HASH_INDEX (h
, start_of_bucket
);
3901 int i
= XFASTINT (idx
);
3902 if (EQ (key
, HASH_KEY (h
, i
))
3904 && h
->cmpfn (h
, key
, hash_code
,
3905 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3907 idx
= HASH_NEXT (h
, i
);
3910 return NILP (idx
) ? -1 : XFASTINT (idx
);
3914 /* Put an entry into hash table H that associates KEY with VALUE.
3915 HASH is a previously computed hash code of KEY. */
3918 hash_put (h
, key
, value
, hash
)
3919 struct Lisp_Hash_Table
*h
;
3920 Lisp_Object key
, value
;
3923 int start_of_bucket
, i
;
3925 xassert ((hash
& ~VALMASK
) == 0);
3927 /* Increment count after resizing because resizing may fail. */
3928 maybe_resize_hash_table (h
);
3929 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3931 /* Store key/value in the key_and_value vector. */
3932 i
= XFASTINT (h
->next_free
);
3933 h
->next_free
= HASH_NEXT (h
, i
);
3934 HASH_KEY (h
, i
) = key
;
3935 HASH_VALUE (h
, i
) = value
;
3937 /* Remember its hash code. */
3938 HASH_HASH (h
, i
) = make_number (hash
);
3940 /* Add new entry to its collision chain. */
3941 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3942 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3943 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3947 /* Remove the entry matching KEY from hash table H, if there is one. */
3950 hash_remove (h
, key
)
3951 struct Lisp_Hash_Table
*h
;
3955 int start_of_bucket
;
3956 Lisp_Object idx
, prev
;
3958 hash_code
= h
->hashfn (h
, key
);
3959 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3960 idx
= HASH_INDEX (h
, start_of_bucket
);
3965 int i
= XFASTINT (idx
);
3967 if (EQ (key
, HASH_KEY (h
, i
))
3969 && h
->cmpfn (h
, key
, hash_code
,
3970 HASH_KEY (h
, i
), HASH_HASH (h
, i
))))
3972 /* Take entry out of collision chain. */
3974 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3976 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3978 /* Clear slots in key_and_value and add the slots to
3980 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3981 HASH_NEXT (h
, i
) = h
->next_free
;
3982 h
->next_free
= make_number (i
);
3983 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3984 xassert (XINT (h
->count
) >= 0);
3990 idx
= HASH_NEXT (h
, i
);
3996 /* Clear hash table H. */
4000 struct Lisp_Hash_Table
*h
;
4002 if (XFASTINT (h
->count
) > 0)
4004 int i
, size
= HASH_TABLE_SIZE (h
);
4006 for (i
= 0; i
< size
; ++i
)
4008 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4009 HASH_KEY (h
, i
) = Qnil
;
4010 HASH_VALUE (h
, i
) = Qnil
;
4011 HASH_HASH (h
, i
) = Qnil
;
4014 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4015 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4017 h
->next_free
= make_number (0);
4018 h
->count
= make_number (0);
4024 /************************************************************************
4026 ************************************************************************/
4028 /* Remove elements from weak hash tables that don't survive the
4029 current garbage collection. Remove weak tables that don't survive
4030 from Vweak_hash_tables. Called from gc_sweep. */
4033 sweep_weak_hash_tables ()
4036 struct Lisp_Hash_Table
*h
= 0, *prev
;
4038 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4041 h
= XHASH_TABLE (table
);
4043 if (h
->size
& ARRAY_MARK_FLAG
)
4045 if (XFASTINT (h
->count
) > 0)
4049 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4050 for (bucket
= 0; bucket
< n
; ++bucket
)
4052 Lisp_Object idx
, prev
;
4054 /* Follow collision chain, removing entries that
4055 don't survive this garbage collection. */
4056 idx
= HASH_INDEX (h
, bucket
);
4058 while (!GC_NILP (idx
))
4061 int i
= XFASTINT (idx
);
4064 if (EQ (h
->weak
, Qkey
))
4065 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
4066 else if (EQ (h
->weak
, Qvalue
))
4067 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
4068 else if (EQ (h
->weak
, Qt
))
4069 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
4070 || !survives_gc_p (HASH_VALUE (h
, i
)));
4074 next
= HASH_NEXT (h
, i
);
4077 /* Take out of collision chain. */
4079 HASH_INDEX (h
, i
) = next
;
4081 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4083 /* Add to free list. */
4084 HASH_NEXT (h
, i
) = h
->next_free
;
4087 /* Clear key, value, and hash. */
4088 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4089 HASH_HASH (h
, i
) = Qnil
;
4091 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4095 /* Make sure key and value survive. */
4096 mark_object (&HASH_KEY (h
, i
));
4097 mark_object (&HASH_VALUE (h
, i
));
4107 /* Table is not marked, and will thus be freed.
4108 Take it out of the list of weak hash tables. */
4110 prev
->next_weak
= h
->next_weak
;
4112 Vweak_hash_tables
= h
->next_weak
;
4119 /***********************************************************************
4120 Hash Code Computation
4121 ***********************************************************************/
4123 /* Maximum depth up to which to dive into Lisp structures. */
4125 #define SXHASH_MAX_DEPTH 3
4127 /* Maximum length up to which to take list and vector elements into
4130 #define SXHASH_MAX_LEN 7
4132 /* Combine two integers X and Y for hashing. */
4134 #define SXHASH_COMBINE(X, Y) \
4135 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4139 /* Return a hash for string PTR which has length LEN. */
4142 sxhash_string (ptr
, len
)
4146 unsigned char *p
= ptr
;
4147 unsigned char *end
= p
+ len
;
4156 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4159 return hash
& 07777777777;
4163 /* Return a hash for list LIST. DEPTH is the current depth in the
4164 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4167 sxhash_list (list
, depth
)
4174 if (depth
< SXHASH_MAX_DEPTH
)
4176 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4177 list
= XCDR (list
), ++i
)
4179 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4180 hash
= SXHASH_COMBINE (hash
, hash2
);
4187 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4188 the Lisp structure. */
4191 sxhash_vector (vec
, depth
)
4195 unsigned hash
= XVECTOR (vec
)->size
;
4198 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4199 for (i
= 0; i
< n
; ++i
)
4201 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4202 hash
= SXHASH_COMBINE (hash
, hash2
);
4209 /* Return a hash for bool-vector VECTOR. */
4212 sxhash_bool_vector (vec
)
4215 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4218 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4219 for (i
= 0; i
< n
; ++i
)
4220 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4226 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4227 structure. Value is an unsigned integer clipped to VALMASK. */
4236 if (depth
> SXHASH_MAX_DEPTH
)
4239 switch (XTYPE (obj
))
4246 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4247 XSYMBOL (obj
)->name
->size
);
4255 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4258 /* This can be everything from a vector to an overlay. */
4259 case Lisp_Vectorlike
:
4261 /* According to the CL HyperSpec, two arrays are equal only if
4262 they are `eq', except for strings and bit-vectors. In
4263 Emacs, this works differently. We have to compare element
4265 hash
= sxhash_vector (obj
, depth
);
4266 else if (BOOL_VECTOR_P (obj
))
4267 hash
= sxhash_bool_vector (obj
);
4269 /* Others are `equal' if they are `eq', so let's take their
4275 hash
= sxhash_list (obj
, depth
);
4280 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4281 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4282 for (hash
= 0; p
< e
; ++p
)
4283 hash
= SXHASH_COMBINE (hash
, *p
);
4291 return hash
& VALMASK
;
4296 /***********************************************************************
4298 ***********************************************************************/
4301 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4302 "Compute a hash code for OBJ and return it as integer.")
4306 unsigned hash
= sxhash (obj
, 0);;
4307 return make_number (hash
);
4311 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4312 "Create and return a new hash table.\n\
4313 Arguments are specified as keyword/argument pairs. The following\n\
4314 arguments are defined:\n\
4316 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4317 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4318 User-supplied test and hash functions can be specified via\n\
4319 `define-hash-table-test'.\n\
4321 :SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
4324 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4325 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4326 If it is a float, it must be > 1.0, and the new size is computed by\n\
4327 multiplying the old size with that factor. Default is 1.5.\n\
4329 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4330 Resize the hash table when ratio of the number of entries in the table.\n\
4333 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4334 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4335 pairs are removed from a weak hash table when their key, value or both\n\
4336 (WEAK t) are otherwise unreferenced. Default is nil.")
4341 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4342 Lisp_Object user_test
, user_hash
;
4346 /* The vector `used' is used to keep track of arguments that
4347 have been consumed. */
4348 used
= (char *) alloca (nargs
* sizeof *used
);
4349 bzero (used
, nargs
* sizeof *used
);
4351 /* See if there's a `:test TEST' among the arguments. */
4352 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4353 test
= i
< 0 ? Qeql
: args
[i
];
4354 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4356 /* See if it is a user-defined test. */
4359 prop
= Fget (test
, Qhash_table_test
);
4360 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4361 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4363 user_test
= Fnth (make_number (0), prop
);
4364 user_hash
= Fnth (make_number (1), prop
);
4367 user_test
= user_hash
= Qnil
;
4369 /* See if there's a `:size SIZE' argument. */
4370 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4371 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4372 if (!INTEGERP (size
) || XINT (size
) <= 0)
4374 list2 (build_string ("Illegal hash table size"),
4377 /* Look for `:rehash-size SIZE'. */
4378 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4379 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4380 if (!NUMBERP (rehash_size
)
4381 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4382 || XFLOATINT (rehash_size
) <= 1.0)
4384 list2 (build_string ("Illegal hash table rehash size"),
4387 /* Look for `:rehash-threshold THRESHOLD'. */
4388 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4389 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4390 if (!FLOATP (rehash_threshold
)
4391 || XFLOATINT (rehash_threshold
) <= 0.0
4392 || XFLOATINT (rehash_threshold
) > 1.0)
4394 list2 (build_string ("Illegal hash table rehash threshold"),
4397 /* Look for `:weakness WEAK'. */
4398 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4399 weak
= i
< 0 ? Qnil
: args
[i
];
4403 && !EQ (weak
, Qvalue
))
4404 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4407 /* Now, all args should have been used up, or there's a problem. */
4408 for (i
= 0; i
< nargs
; ++i
)
4411 list2 (build_string ("Invalid argument list"), args
[i
]));
4413 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4414 user_test
, user_hash
);
4418 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4419 "Return a copy of hash table TABLE.")
4423 return copy_hash_table (check_hash_table (table
));
4427 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4428 "Create a new hash table.\n\
4429 Optional first argument TEST specifies how to compare keys in\n\
4430 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4431 is `eql'. New tests can be defined with `define-hash-table-test'.")
4435 Lisp_Object args
[2];
4438 return Fmake_hash_table (2, args
);
4442 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4443 "Return the number of elements in TABLE.")
4447 return check_hash_table (table
)->count
;
4451 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4452 Shash_table_rehash_size
, 1, 1, 0,
4453 "Return the current rehash size of TABLE.")
4457 return check_hash_table (table
)->rehash_size
;
4461 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4462 Shash_table_rehash_threshold
, 1, 1, 0,
4463 "Return the current rehash threshold of TABLE.")
4467 return check_hash_table (table
)->rehash_threshold
;
4471 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4472 "Return the size of TABLE.\n\
4473 The size can be used as an argument to `make-hash-table' to create\n\
4474 a hash table than can hold as many elements of TABLE holds\n\
4475 without need for resizing.")
4479 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4480 return make_number (HASH_TABLE_SIZE (h
));
4484 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4485 "Return the test TABLE uses.")
4489 return check_hash_table (table
)->test
;
4493 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4495 "Return the weakness of TABLE.")
4499 return check_hash_table (table
)->weak
;
4503 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4504 "Return t if OBJ is a Lisp hash table object.")
4508 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4512 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4513 "Clear hash table TABLE.")
4517 hash_clear (check_hash_table (table
));
4522 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4523 "Look up KEY in TABLE and return its associated value.\n\
4524 If KEY is not found, return DFLT which defaults to nil.")
4526 Lisp_Object key
, table
, dflt
;
4528 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4529 int i
= hash_lookup (h
, key
, NULL
);
4530 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4534 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4535 "Associate KEY with VALUE is hash table TABLE.\n\
4536 If KEY is already present in table, replace its current value with\n\
4539 Lisp_Object key
, value
, table
;
4541 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4545 i
= hash_lookup (h
, key
, &hash
);
4547 HASH_VALUE (h
, i
) = value
;
4549 hash_put (h
, key
, value
, hash
);
4555 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4556 "Remove KEY from TABLE.")
4558 Lisp_Object key
, table
;
4560 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4561 hash_remove (h
, key
);
4566 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4567 "Call FUNCTION for all entries in hash table TABLE.\n\
4568 FUNCTION is called with 2 arguments KEY and VALUE.")
4570 Lisp_Object function
, table
;
4572 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4573 Lisp_Object args
[3];
4576 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4577 if (!NILP (HASH_HASH (h
, i
)))
4580 args
[1] = HASH_KEY (h
, i
);
4581 args
[2] = HASH_VALUE (h
, i
);
4589 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4590 Sdefine_hash_table_test
, 3, 3, 0,
4591 "Define a new hash table test with name NAME, a symbol.\n\
4592 In hash tables create with NAME specified as test, use TEST to compare\n\
4593 keys, and HASH for computing hash codes of keys.\n\
4595 TEST must be a function taking two arguments and returning non-nil\n\
4596 if both arguments are the same. HASH must be a function taking\n\
4597 one argument and return an integer that is the hash code of the\n\
4598 argument. Hash code computation should use the whole value range of\n\
4599 integers, including negative integers.")
4601 Lisp_Object name
, test
, hash
;
4603 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4612 /* Hash table stuff. */
4613 Qhash_table_p
= intern ("hash-table-p");
4614 staticpro (&Qhash_table_p
);
4615 Qeq
= intern ("eq");
4617 Qeql
= intern ("eql");
4619 Qequal
= intern ("equal");
4620 staticpro (&Qequal
);
4621 QCtest
= intern (":test");
4622 staticpro (&QCtest
);
4623 QCsize
= intern (":size");
4624 staticpro (&QCsize
);
4625 QCrehash_size
= intern (":rehash-size");
4626 staticpro (&QCrehash_size
);
4627 QCrehash_threshold
= intern (":rehash-threshold");
4628 staticpro (&QCrehash_threshold
);
4629 QCweakness
= intern (":weakness");
4630 staticpro (&QCweakness
);
4631 Qkey
= intern ("key");
4633 Qvalue
= intern ("value");
4634 staticpro (&Qvalue
);
4635 Qhash_table_test
= intern ("hash-table-test");
4636 staticpro (&Qhash_table_test
);
4639 defsubr (&Smake_hash_table
);
4640 defsubr (&Scopy_hash_table
);
4641 defsubr (&Smakehash
);
4642 defsubr (&Shash_table_count
);
4643 defsubr (&Shash_table_rehash_size
);
4644 defsubr (&Shash_table_rehash_threshold
);
4645 defsubr (&Shash_table_size
);
4646 defsubr (&Shash_table_test
);
4647 defsubr (&Shash_table_weakness
);
4648 defsubr (&Shash_table_p
);
4649 defsubr (&Sclrhash
);
4650 defsubr (&Sgethash
);
4651 defsubr (&Sputhash
);
4652 defsubr (&Sremhash
);
4653 defsubr (&Smaphash
);
4654 defsubr (&Sdefine_hash_table_test
);
4656 Qstring_lessp
= intern ("string-lessp");
4657 staticpro (&Qstring_lessp
);
4658 Qprovide
= intern ("provide");
4659 staticpro (&Qprovide
);
4660 Qrequire
= intern ("require");
4661 staticpro (&Qrequire
);
4662 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4663 staticpro (&Qyes_or_no_p_history
);
4664 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4665 staticpro (&Qcursor_in_echo_area
);
4666 Qwidget_type
= intern ("widget-type");
4667 staticpro (&Qwidget_type
);
4669 staticpro (&string_char_byte_cache_string
);
4670 string_char_byte_cache_string
= Qnil
;
4672 Fset (Qyes_or_no_p_history
, Qnil
);
4674 DEFVAR_LISP ("features", &Vfeatures
,
4675 "A list of symbols which are the features of the executing emacs.\n\
4676 Used by `featurep' and `require', and altered by `provide'.");
4679 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4680 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4681 This applies to y-or-n and yes-or-no questions asked by commands\n\
4682 invoked by mouse clicks and mouse menu items.");
4685 defsubr (&Sidentity
);
4688 defsubr (&Ssafe_length
);
4689 defsubr (&Sstring_bytes
);
4690 defsubr (&Sstring_equal
);
4691 defsubr (&Scompare_strings
);
4692 defsubr (&Sstring_lessp
);
4695 defsubr (&Svconcat
);
4696 defsubr (&Scopy_sequence
);
4697 defsubr (&Sstring_make_multibyte
);
4698 defsubr (&Sstring_make_unibyte
);
4699 defsubr (&Sstring_as_multibyte
);
4700 defsubr (&Sstring_as_unibyte
);
4701 defsubr (&Scopy_alist
);
4702 defsubr (&Ssubstring
);
4714 defsubr (&Snreverse
);
4715 defsubr (&Sreverse
);
4717 defsubr (&Splist_get
);
4719 defsubr (&Splist_put
);
4722 defsubr (&Sfillarray
);
4723 defsubr (&Schar_table_subtype
);
4724 defsubr (&Schar_table_parent
);
4725 defsubr (&Sset_char_table_parent
);
4726 defsubr (&Schar_table_extra_slot
);
4727 defsubr (&Sset_char_table_extra_slot
);
4728 defsubr (&Schar_table_range
);
4729 defsubr (&Sset_char_table_range
);
4730 defsubr (&Sset_char_table_default
);
4731 defsubr (&Smap_char_table
);
4734 defsubr (&Smapconcat
);
4735 defsubr (&Sy_or_n_p
);
4736 defsubr (&Syes_or_no_p
);
4737 defsubr (&Sload_average
);
4738 defsubr (&Sfeaturep
);
4739 defsubr (&Srequire
);
4740 defsubr (&Sprovide
);
4741 defsubr (&Swidget_plist_member
);
4742 defsubr (&Swidget_put
);
4743 defsubr (&Swidget_get
);
4744 defsubr (&Swidget_apply
);
4745 defsubr (&Sbase64_encode_region
);
4746 defsubr (&Sbase64_decode_region
);
4747 defsubr (&Sbase64_encode_string
);
4748 defsubr (&Sbase64_decode_string
);
4755 Vweak_hash_tables
= Qnil
;