1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
68 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
70 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
72 extern long get_random (void);
73 extern void seed_random (long);
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 doc
: /* Return the argument unchanged. */)
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 doc
: /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 29 bits' worth.
90 With positive integer LIMIT, return random number in interval [0,LIMIT).
91 With argument t, set the random number seed from the current time and pid.
92 Other values of LIMIT are ignored. */)
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (limit
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 doc
: /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */)
129 (register Lisp_Object sequence
)
131 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, SCHARS (sequence
));
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, ASIZE (sequence
));
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 CHECK_LIST_END (sequence
, sequence
);
162 val
= make_number (i
);
164 else if (NILP (sequence
))
165 XSETFASTINT (val
, 0);
167 wrong_type_argument (Qsequencep
, sequence
);
172 /* This does not check for quits. That is safe since it must terminate. */
174 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
175 doc
: /* Return the length of a list, but avoid error or infinite loop.
176 This function never gets an error. If LIST is not really a list,
177 it returns 0. If LIST is circular, it returns a finite value
178 which is at least the number of distinct elements. */)
181 Lisp_Object tail
, halftail
, length
;
184 /* halftail is used to detect circular lists. */
186 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
188 if (EQ (tail
, halftail
) && len
!= 0)
192 halftail
= XCDR (halftail
);
195 XSETINT (length
, len
);
199 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
200 doc
: /* Return the number of bytes in STRING.
201 If STRING is multibyte, this may be greater than the length of STRING. */)
204 CHECK_STRING (string
);
205 return make_number (SBYTES (string
));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 doc
: /* Return t if two strings have identical contents.
210 Case is significant, but text properties are ignored.
211 Symbols are also allowed; their print names are used instead. */)
212 (register Lisp_Object s1
, Lisp_Object s2
)
215 s1
= SYMBOL_NAME (s1
);
217 s2
= SYMBOL_NAME (s2
);
221 if (SCHARS (s1
) != SCHARS (s2
)
222 || SBYTES (s1
) != SBYTES (s2
)
223 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
228 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
229 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
230 In string STR1, skip the first START1 characters and stop at END1.
231 In string STR2, skip the first START2 characters and stop at END2.
232 END1 and END2 default to the full lengths of the respective strings.
234 Case is significant in this comparison if IGNORE-CASE is nil.
235 Unibyte strings are converted to multibyte for comparison.
237 The value is t if the strings (or specified portions) match.
238 If string STR1 is less, the value is a negative number N;
239 - 1 - N is the number of characters that match at the beginning.
240 If string STR1 is greater, the value is a positive number N;
241 N - 1 is the number of characters that match at the beginning. */)
242 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
244 register int end1_char
, end2_char
;
245 register int i1
, i1_byte
, i2
, i2_byte
;
250 start1
= make_number (0);
252 start2
= make_number (0);
253 CHECK_NATNUM (start1
);
254 CHECK_NATNUM (start2
);
263 i1_byte
= string_char_to_byte (str1
, i1
);
264 i2_byte
= string_char_to_byte (str2
, i2
);
266 end1_char
= SCHARS (str1
);
267 if (! NILP (end1
) && end1_char
> XINT (end1
))
268 end1_char
= XINT (end1
);
270 end2_char
= SCHARS (str2
);
271 if (! NILP (end2
) && end2_char
> XINT (end2
))
272 end2_char
= XINT (end2
);
274 while (i1
< end1_char
&& i2
< end2_char
)
276 /* When we find a mismatch, we must compare the
277 characters, not just the bytes. */
280 if (STRING_MULTIBYTE (str1
))
281 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
284 c1
= SREF (str1
, i1
++);
285 MAKE_CHAR_MULTIBYTE (c1
);
288 if (STRING_MULTIBYTE (str2
))
289 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
292 c2
= SREF (str2
, i2
++);
293 MAKE_CHAR_MULTIBYTE (c2
);
299 if (! NILP (ignore_case
))
303 tem
= Fupcase (make_number (c1
));
305 tem
= Fupcase (make_number (c2
));
312 /* Note that I1 has already been incremented
313 past the character that we are comparing;
314 hence we don't add or subtract 1 here. */
316 return make_number (- i1
+ XINT (start1
));
318 return make_number (i1
- XINT (start1
));
322 return make_number (i1
- XINT (start1
) + 1);
324 return make_number (- i1
+ XINT (start1
) - 1);
329 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
330 doc
: /* Return t if first arg string is less than second in lexicographic order.
332 Symbols are also allowed; their print names are used instead. */)
333 (register Lisp_Object s1
, Lisp_Object s2
)
336 register int i1
, i1_byte
, i2
, i2_byte
;
339 s1
= SYMBOL_NAME (s1
);
341 s2
= SYMBOL_NAME (s2
);
345 i1
= i1_byte
= i2
= i2_byte
= 0;
348 if (end
> SCHARS (s2
))
353 /* When we find a mismatch, we must compare the
354 characters, not just the bytes. */
357 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
358 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
361 return c1
< c2
? Qt
: Qnil
;
363 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
366 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
367 enum Lisp_Type target_type
, int last_special
);
371 concat2 (Lisp_Object s1
, Lisp_Object s2
)
376 return concat (2, args
, Lisp_String
, 0);
381 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
387 return concat (3, args
, Lisp_String
, 0);
390 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
391 doc
: /* Concatenate all the arguments and make the result a list.
392 The result is a list whose elements are the elements of all the arguments.
393 Each argument may be a list, vector or string.
394 The last argument is not copied, just used as the tail of the new list.
395 usage: (append &rest SEQUENCES) */)
396 (int nargs
, Lisp_Object
*args
)
398 return concat (nargs
, args
, Lisp_Cons
, 1);
401 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
402 doc
: /* Concatenate all the arguments and make the result a string.
403 The result is a string whose elements are the elements of all the arguments.
404 Each argument may be a string or a list or vector of characters (integers).
405 usage: (concat &rest SEQUENCES) */)
406 (int nargs
, Lisp_Object
*args
)
408 return concat (nargs
, args
, Lisp_String
, 0);
411 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
412 doc
: /* Concatenate all the arguments and make the result a vector.
413 The result is a vector whose elements are the elements of all the arguments.
414 Each argument may be a list, vector or string.
415 usage: (vconcat &rest SEQUENCES) */)
416 (int nargs
, Lisp_Object
*args
)
418 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
422 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
423 doc
: /* Return a copy of a list, vector, string or char-table.
424 The elements of a list or vector are not copied; they are shared
425 with the original. */)
428 if (NILP (arg
)) return arg
;
430 if (CHAR_TABLE_P (arg
))
432 return copy_char_table (arg
);
435 if (BOOL_VECTOR_P (arg
))
439 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
440 / BOOL_VECTOR_BITS_PER_CHAR
);
442 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
443 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
448 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
449 wrong_type_argument (Qsequencep
, arg
);
451 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
454 /* This structure holds information of an argument of `concat' that is
455 a string and has text properties to be copied. */
458 int argnum
; /* refer to ARGS (arguments of `concat') */
459 int from
; /* refer to ARGS[argnum] (argument string) */
460 int to
; /* refer to VAL (the target string) */
464 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
467 register Lisp_Object tail
;
468 register Lisp_Object
this;
470 int toindex_byte
= 0;
471 register int result_len
;
472 register int result_len_byte
;
474 Lisp_Object last_tail
;
477 /* When we make a multibyte string, we can't copy text properties
478 while concatinating each string because the length of resulting
479 string can't be decided until we finish the whole concatination.
480 So, we record strings that have text properties to be copied
481 here, and copy the text properties after the concatination. */
482 struct textprop_rec
*textprops
= NULL
;
483 /* Number of elements in textprops. */
484 int num_textprops
= 0;
489 /* In append, the last arg isn't treated like the others */
490 if (last_special
&& nargs
> 0)
493 last_tail
= args
[nargs
];
498 /* Check each argument. */
499 for (argnum
= 0; argnum
< nargs
; argnum
++)
502 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
503 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
504 wrong_type_argument (Qsequencep
, this);
507 /* Compute total length in chars of arguments in RESULT_LEN.
508 If desired output is a string, also compute length in bytes
509 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
510 whether the result should be a multibyte string. */
514 for (argnum
= 0; argnum
< nargs
; argnum
++)
518 len
= XFASTINT (Flength (this));
519 if (target_type
== Lisp_String
)
521 /* We must count the number of bytes needed in the string
522 as well as the number of characters. */
528 for (i
= 0; i
< len
; i
++)
531 CHECK_CHARACTER (ch
);
532 this_len_byte
= CHAR_BYTES (XINT (ch
));
533 result_len_byte
+= this_len_byte
;
534 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
537 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
538 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
539 else if (CONSP (this))
540 for (; CONSP (this); this = XCDR (this))
543 CHECK_CHARACTER (ch
);
544 this_len_byte
= CHAR_BYTES (XINT (ch
));
545 result_len_byte
+= this_len_byte
;
546 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
549 else if (STRINGP (this))
551 if (STRING_MULTIBYTE (this))
554 result_len_byte
+= SBYTES (this);
557 result_len_byte
+= count_size_as_multibyte (SDATA (this),
564 error ("String overflow");
567 if (! some_multibyte
)
568 result_len_byte
= result_len
;
570 /* Create the output object. */
571 if (target_type
== Lisp_Cons
)
572 val
= Fmake_list (make_number (result_len
), Qnil
);
573 else if (target_type
== Lisp_Vectorlike
)
574 val
= Fmake_vector (make_number (result_len
), Qnil
);
575 else if (some_multibyte
)
576 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
578 val
= make_uninit_string (result_len
);
580 /* In `append', if all but last arg are nil, return last arg. */
581 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
584 /* Copy the contents of the args into the result. */
586 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
588 toindex
= 0, toindex_byte
= 0;
592 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
594 for (argnum
= 0; argnum
< nargs
; argnum
++)
598 register unsigned int thisindex
= 0;
599 register unsigned int thisindex_byte
= 0;
603 thislen
= Flength (this), thisleni
= XINT (thislen
);
605 /* Between strings of the same kind, copy fast. */
606 if (STRINGP (this) && STRINGP (val
)
607 && STRING_MULTIBYTE (this) == some_multibyte
)
609 int thislen_byte
= SBYTES (this);
611 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
612 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
614 textprops
[num_textprops
].argnum
= argnum
;
615 textprops
[num_textprops
].from
= 0;
616 textprops
[num_textprops
++].to
= toindex
;
618 toindex_byte
+= thislen_byte
;
621 /* Copy a single-byte string to a multibyte string. */
622 else if (STRINGP (this) && STRINGP (val
))
624 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
626 textprops
[num_textprops
].argnum
= argnum
;
627 textprops
[num_textprops
].from
= 0;
628 textprops
[num_textprops
++].to
= toindex
;
630 toindex_byte
+= copy_text (SDATA (this),
631 SDATA (val
) + toindex_byte
,
632 SCHARS (this), 0, 1);
636 /* Copy element by element. */
639 register Lisp_Object elt
;
641 /* Fetch next element of `this' arg into `elt', or break if
642 `this' is exhausted. */
643 if (NILP (this)) break;
645 elt
= XCAR (this), this = XCDR (this);
646 else if (thisindex
>= thisleni
)
648 else if (STRINGP (this))
651 if (STRING_MULTIBYTE (this))
653 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
656 XSETFASTINT (elt
, c
);
660 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
662 && !ASCII_CHAR_P (XINT (elt
))
663 && XINT (elt
) < 0400)
665 c
= BYTE8_TO_CHAR (XINT (elt
));
670 else if (BOOL_VECTOR_P (this))
673 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
674 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
682 elt
= AREF (this, thisindex
);
686 /* Store this element into the result. */
693 else if (VECTORP (val
))
695 ASET (val
, toindex
, elt
);
702 toindex_byte
+= CHAR_STRING (XINT (elt
),
703 SDATA (val
) + toindex_byte
);
705 SSET (val
, toindex_byte
++, XINT (elt
));
711 XSETCDR (prev
, last_tail
);
713 if (num_textprops
> 0)
716 int last_to_end
= -1;
718 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
720 this = args
[textprops
[argnum
].argnum
];
721 props
= text_property_list (this,
723 make_number (SCHARS (this)),
725 /* If successive arguments have properites, be sure that the
726 value of `composition' property be the copy. */
727 if (last_to_end
== textprops
[argnum
].to
)
728 make_composition_value_copy (props
);
729 add_text_properties_from_list (val
, props
,
730 make_number (textprops
[argnum
].to
));
731 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
739 static Lisp_Object string_char_byte_cache_string
;
740 static EMACS_INT string_char_byte_cache_charpos
;
741 static EMACS_INT string_char_byte_cache_bytepos
;
744 clear_string_char_byte_cache (void)
746 string_char_byte_cache_string
= Qnil
;
749 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
752 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
755 EMACS_INT best_below
, best_below_byte
;
756 EMACS_INT best_above
, best_above_byte
;
758 best_below
= best_below_byte
= 0;
759 best_above
= SCHARS (string
);
760 best_above_byte
= SBYTES (string
);
761 if (best_above
== best_above_byte
)
764 if (EQ (string
, string_char_byte_cache_string
))
766 if (string_char_byte_cache_charpos
< char_index
)
768 best_below
= string_char_byte_cache_charpos
;
769 best_below_byte
= string_char_byte_cache_bytepos
;
773 best_above
= string_char_byte_cache_charpos
;
774 best_above_byte
= string_char_byte_cache_bytepos
;
778 if (char_index
- best_below
< best_above
- char_index
)
780 unsigned char *p
= SDATA (string
) + best_below_byte
;
782 while (best_below
< char_index
)
784 p
+= BYTES_BY_CHAR_HEAD (*p
);
787 i_byte
= p
- SDATA (string
);
791 unsigned char *p
= SDATA (string
) + best_above_byte
;
793 while (best_above
> char_index
)
796 while (!CHAR_HEAD_P (*p
)) p
--;
799 i_byte
= p
- SDATA (string
);
802 string_char_byte_cache_bytepos
= i_byte
;
803 string_char_byte_cache_charpos
= char_index
;
804 string_char_byte_cache_string
= string
;
809 /* Return the character index corresponding to BYTE_INDEX in STRING. */
812 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
815 EMACS_INT best_below
, best_below_byte
;
816 EMACS_INT best_above
, best_above_byte
;
818 best_below
= best_below_byte
= 0;
819 best_above
= SCHARS (string
);
820 best_above_byte
= SBYTES (string
);
821 if (best_above
== best_above_byte
)
824 if (EQ (string
, string_char_byte_cache_string
))
826 if (string_char_byte_cache_bytepos
< byte_index
)
828 best_below
= string_char_byte_cache_charpos
;
829 best_below_byte
= string_char_byte_cache_bytepos
;
833 best_above
= string_char_byte_cache_charpos
;
834 best_above_byte
= string_char_byte_cache_bytepos
;
838 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
840 unsigned char *p
= SDATA (string
) + best_below_byte
;
841 unsigned char *pend
= SDATA (string
) + byte_index
;
845 p
+= BYTES_BY_CHAR_HEAD (*p
);
849 i_byte
= p
- SDATA (string
);
853 unsigned char *p
= SDATA (string
) + best_above_byte
;
854 unsigned char *pbeg
= SDATA (string
) + byte_index
;
859 while (!CHAR_HEAD_P (*p
)) p
--;
863 i_byte
= p
- SDATA (string
);
866 string_char_byte_cache_bytepos
= i_byte
;
867 string_char_byte_cache_charpos
= i
;
868 string_char_byte_cache_string
= string
;
873 /* Convert STRING to a multibyte string. */
876 string_make_multibyte (Lisp_Object string
)
883 if (STRING_MULTIBYTE (string
))
886 nbytes
= count_size_as_multibyte (SDATA (string
),
888 /* If all the chars are ASCII, they won't need any more bytes
889 once converted. In that case, we can return STRING itself. */
890 if (nbytes
== SBYTES (string
))
893 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
894 copy_text (SDATA (string
), buf
, SBYTES (string
),
897 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
904 /* Convert STRING (if unibyte) to a multibyte string without changing
905 the number of characters. Characters 0200 trough 0237 are
906 converted to eight-bit characters. */
909 string_to_multibyte (Lisp_Object string
)
916 if (STRING_MULTIBYTE (string
))
919 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
920 /* If all the chars are ASCII, they won't need any more bytes once
922 if (nbytes
== SBYTES (string
))
923 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
925 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
926 memcpy (buf
, SDATA (string
), SBYTES (string
));
927 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
929 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
936 /* Convert STRING to a single-byte string. */
939 string_make_unibyte (Lisp_Object string
)
946 if (! STRING_MULTIBYTE (string
))
949 nchars
= SCHARS (string
);
951 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
952 copy_text (SDATA (string
), buf
, SBYTES (string
),
955 ret
= make_unibyte_string (buf
, nchars
);
961 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
963 doc
: /* Return the multibyte equivalent of STRING.
964 If STRING is unibyte and contains non-ASCII characters, the function
965 `unibyte-char-to-multibyte' is used to convert each unibyte character
966 to a multibyte character. In this case, the returned string is a
967 newly created string with no text properties. If STRING is multibyte
968 or entirely ASCII, it is returned unchanged. In particular, when
969 STRING is unibyte and entirely ASCII, the returned string is unibyte.
970 \(When the characters are all ASCII, Emacs primitives will treat the
971 string the same way whether it is unibyte or multibyte.) */)
974 CHECK_STRING (string
);
976 return string_make_multibyte (string
);
979 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
981 doc
: /* Return the unibyte equivalent of STRING.
982 Multibyte character codes are converted to unibyte according to
983 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
984 If the lookup in the translation table fails, this function takes just
985 the low 8 bits of each character. */)
988 CHECK_STRING (string
);
990 return string_make_unibyte (string
);
993 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
995 doc
: /* Return a unibyte string with the same individual bytes as STRING.
996 If STRING is unibyte, the result is STRING itself.
997 Otherwise it is a newly created string, with no text properties.
998 If STRING is multibyte and contains a character of charset
999 `eight-bit', it is converted to the corresponding single byte. */)
1000 (Lisp_Object string
)
1002 CHECK_STRING (string
);
1004 if (STRING_MULTIBYTE (string
))
1006 int bytes
= SBYTES (string
);
1007 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1009 memcpy (str
, SDATA (string
), bytes
);
1010 bytes
= str_as_unibyte (str
, bytes
);
1011 string
= make_unibyte_string (str
, bytes
);
1017 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1019 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1020 If STRING is multibyte, the result is STRING itself.
1021 Otherwise it is a newly created string, with no text properties.
1023 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1024 part of a correct utf-8 sequence), it is converted to the corresponding
1025 multibyte character of charset `eight-bit'.
1026 See also `string-to-multibyte'.
1028 Beware, this often doesn't really do what you think it does.
1029 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1030 If you're not sure, whether to use `string-as-multibyte' or
1031 `string-to-multibyte', use `string-to-multibyte'. */)
1032 (Lisp_Object string
)
1034 CHECK_STRING (string
);
1036 if (! STRING_MULTIBYTE (string
))
1038 Lisp_Object new_string
;
1041 parse_str_as_multibyte (SDATA (string
),
1044 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1045 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1046 if (nbytes
!= SBYTES (string
))
1047 str_as_multibyte (SDATA (new_string
), nbytes
,
1048 SBYTES (string
), NULL
);
1049 string
= new_string
;
1050 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1055 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1057 doc
: /* Return a multibyte string with the same individual chars as STRING.
1058 If STRING is multibyte, the result is STRING itself.
1059 Otherwise it is a newly created string, with no text properties.
1061 If STRING is unibyte and contains an 8-bit byte, it is converted to
1062 the corresponding multibyte character of charset `eight-bit'.
1064 This differs from `string-as-multibyte' by converting each byte of a correct
1065 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1066 correct sequence. */)
1067 (Lisp_Object string
)
1069 CHECK_STRING (string
);
1071 return string_to_multibyte (string
);
1074 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1076 doc
: /* Return a unibyte string with the same individual chars as STRING.
1077 If STRING is unibyte, the result is STRING itself.
1078 Otherwise it is a newly created string, with no text properties,
1079 where each `eight-bit' character is converted to the corresponding byte.
1080 If STRING contains a non-ASCII, non-`eight-bit' character,
1081 an error is signaled. */)
1082 (Lisp_Object string
)
1084 CHECK_STRING (string
);
1086 if (STRING_MULTIBYTE (string
))
1088 EMACS_INT chars
= SCHARS (string
);
1089 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1090 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1092 if (converted
< chars
)
1093 error ("Can't convert the %dth character to unibyte", converted
);
1094 string
= make_unibyte_string (str
, chars
);
1101 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1102 doc
: /* Return a copy of ALIST.
1103 This is an alist which represents the same mapping from objects to objects,
1104 but does not share the alist structure with ALIST.
1105 The objects mapped (cars and cdrs of elements of the alist)
1106 are shared, however.
1107 Elements of ALIST that are not conses are also shared. */)
1110 register Lisp_Object tem
;
1115 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1116 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1118 register Lisp_Object car
;
1122 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1127 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1128 doc
: /* Return a new string whose contents are a substring of STRING.
1129 The returned string consists of the characters between index FROM
1130 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1131 zero-indexed: 0 means the first character of STRING. Negative values
1132 are counted from the end of STRING. If TO is nil, the substring runs
1133 to the end of STRING.
1135 The STRING argument may also be a vector. In that case, the return
1136 value is a new vector that contains the elements between index FROM
1137 \(inclusive) and index TO (exclusive) of that vector argument. */)
1138 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1143 int from_char
, to_char
;
1144 int from_byte
= 0, to_byte
= 0;
1146 CHECK_VECTOR_OR_STRING (string
);
1147 CHECK_NUMBER (from
);
1149 if (STRINGP (string
))
1151 size
= SCHARS (string
);
1152 size_byte
= SBYTES (string
);
1155 size
= ASIZE (string
);
1160 to_byte
= size_byte
;
1166 to_char
= XINT (to
);
1170 if (STRINGP (string
))
1171 to_byte
= string_char_to_byte (string
, to_char
);
1174 from_char
= XINT (from
);
1177 if (STRINGP (string
))
1178 from_byte
= string_char_to_byte (string
, from_char
);
1180 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1181 args_out_of_range_3 (string
, make_number (from_char
),
1182 make_number (to_char
));
1184 if (STRINGP (string
))
1186 res
= make_specified_string (SDATA (string
) + from_byte
,
1187 to_char
- from_char
, to_byte
- from_byte
,
1188 STRING_MULTIBYTE (string
));
1189 copy_text_properties (make_number (from_char
), make_number (to_char
),
1190 string
, make_number (0), res
, Qnil
);
1193 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1199 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1200 doc
: /* Return a substring of STRING, without text properties.
1201 It starts at index FROM and ends before TO.
1202 TO may be nil or omitted; then the substring runs to the end of STRING.
1203 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1204 If FROM or TO is negative, it counts from the end.
1206 With one argument, just copy STRING without its properties. */)
1207 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1209 int size
, size_byte
;
1210 int from_char
, to_char
;
1211 int from_byte
, to_byte
;
1213 CHECK_STRING (string
);
1215 size
= SCHARS (string
);
1216 size_byte
= SBYTES (string
);
1219 from_char
= from_byte
= 0;
1222 CHECK_NUMBER (from
);
1223 from_char
= XINT (from
);
1227 from_byte
= string_char_to_byte (string
, from_char
);
1233 to_byte
= size_byte
;
1239 to_char
= XINT (to
);
1243 to_byte
= string_char_to_byte (string
, to_char
);
1246 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1247 args_out_of_range_3 (string
, make_number (from_char
),
1248 make_number (to_char
));
1250 return make_specified_string (SDATA (string
) + from_byte
,
1251 to_char
- from_char
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1255 /* Extract a substring of STRING, giving start and end positions
1256 both in characters and in bytes. */
1259 substring_both (Lisp_Object string
, int from
, int from_byte
, int to
, int to_byte
)
1265 CHECK_VECTOR_OR_STRING (string
);
1267 if (STRINGP (string
))
1269 size
= SCHARS (string
);
1270 size_byte
= SBYTES (string
);
1273 size
= ASIZE (string
);
1275 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1276 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1278 if (STRINGP (string
))
1280 res
= make_specified_string (SDATA (string
) + from_byte
,
1281 to
- from
, to_byte
- from_byte
,
1282 STRING_MULTIBYTE (string
));
1283 copy_text_properties (make_number (from
), make_number (to
),
1284 string
, make_number (0), res
, Qnil
);
1287 res
= Fvector (to
- from
, &AREF (string
, from
));
1292 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1293 doc
: /* Take cdr N times on LIST, return the result. */)
1294 (Lisp_Object n
, Lisp_Object list
)
1296 register int i
, num
;
1299 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1302 CHECK_LIST_CONS (list
, list
);
1308 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1309 doc
: /* Return the Nth element of LIST.
1310 N counts from zero. If LIST is not that long, nil is returned. */)
1311 (Lisp_Object n
, Lisp_Object list
)
1313 return Fcar (Fnthcdr (n
, list
));
1316 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1317 doc
: /* Return element of SEQUENCE at index N. */)
1318 (register Lisp_Object sequence
, Lisp_Object n
)
1321 if (CONSP (sequence
) || NILP (sequence
))
1322 return Fcar (Fnthcdr (n
, sequence
));
1324 /* Faref signals a "not array" error, so check here. */
1325 CHECK_ARRAY (sequence
, Qsequencep
);
1326 return Faref (sequence
, n
);
1329 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1330 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1331 The value is actually the tail of LIST whose car is ELT. */)
1332 (register Lisp_Object elt
, Lisp_Object list
)
1334 register Lisp_Object tail
;
1335 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1337 register Lisp_Object tem
;
1338 CHECK_LIST_CONS (tail
, list
);
1340 if (! NILP (Fequal (elt
, tem
)))
1347 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1348 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1349 The value is actually the tail of LIST whose car is ELT. */)
1350 (register Lisp_Object elt
, Lisp_Object list
)
1354 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1358 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1362 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1373 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1374 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1375 The value is actually the tail of LIST whose car is ELT. */)
1376 (register Lisp_Object elt
, Lisp_Object list
)
1378 register Lisp_Object tail
;
1381 return Fmemq (elt
, list
);
1383 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1385 register Lisp_Object tem
;
1386 CHECK_LIST_CONS (tail
, list
);
1388 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1395 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1396 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1397 The value is actually the first element of LIST whose car is KEY.
1398 Elements of LIST that are not conses are ignored. */)
1399 (Lisp_Object key
, Lisp_Object list
)
1404 || (CONSP (XCAR (list
))
1405 && EQ (XCAR (XCAR (list
)), key
)))
1410 || (CONSP (XCAR (list
))
1411 && EQ (XCAR (XCAR (list
)), key
)))
1416 || (CONSP (XCAR (list
))
1417 && EQ (XCAR (XCAR (list
)), key
)))
1427 /* Like Fassq but never report an error and do not allow quits.
1428 Use only on lists known never to be circular. */
1431 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1434 && (!CONSP (XCAR (list
))
1435 || !EQ (XCAR (XCAR (list
)), key
)))
1438 return CAR_SAFE (list
);
1441 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1442 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1443 The value is actually the first element of LIST whose car equals KEY. */)
1444 (Lisp_Object key
, Lisp_Object list
)
1451 || (CONSP (XCAR (list
))
1452 && (car
= XCAR (XCAR (list
)),
1453 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1458 || (CONSP (XCAR (list
))
1459 && (car
= XCAR (XCAR (list
)),
1460 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1465 || (CONSP (XCAR (list
))
1466 && (car
= XCAR (XCAR (list
)),
1467 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1477 /* Like Fassoc but never report an error and do not allow quits.
1478 Use only on lists known never to be circular. */
1481 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1484 && (!CONSP (XCAR (list
))
1485 || (!EQ (XCAR (XCAR (list
)), key
)
1486 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1489 return CONSP (list
) ? XCAR (list
) : Qnil
;
1492 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1493 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1494 The value is actually the first element of LIST whose cdr is KEY. */)
1495 (register Lisp_Object key
, Lisp_Object list
)
1500 || (CONSP (XCAR (list
))
1501 && EQ (XCDR (XCAR (list
)), key
)))
1506 || (CONSP (XCAR (list
))
1507 && EQ (XCDR (XCAR (list
)), key
)))
1512 || (CONSP (XCAR (list
))
1513 && EQ (XCDR (XCAR (list
)), key
)))
1523 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1524 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1525 The value is actually the first element of LIST whose cdr equals KEY. */)
1526 (Lisp_Object key
, Lisp_Object list
)
1533 || (CONSP (XCAR (list
))
1534 && (cdr
= XCDR (XCAR (list
)),
1535 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1540 || (CONSP (XCAR (list
))
1541 && (cdr
= XCDR (XCAR (list
)),
1542 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1547 || (CONSP (XCAR (list
))
1548 && (cdr
= XCDR (XCAR (list
)),
1549 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1559 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1560 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1561 The modified LIST is returned. Comparison is done with `eq'.
1562 If the first member of LIST is ELT, there is no way to remove it by side effect;
1563 therefore, write `(setq foo (delq element foo))'
1564 to be sure of changing the value of `foo'. */)
1565 (register Lisp_Object elt
, Lisp_Object list
)
1567 register Lisp_Object tail
, prev
;
1568 register Lisp_Object tem
;
1572 while (!NILP (tail
))
1574 CHECK_LIST_CONS (tail
, list
);
1581 Fsetcdr (prev
, XCDR (tail
));
1591 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1592 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1593 SEQ must be a list, a vector, or a string.
1594 The modified SEQ is returned. Comparison is done with `equal'.
1595 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1596 is not a side effect; it is simply using a different sequence.
1597 Therefore, write `(setq foo (delete element foo))'
1598 to be sure of changing the value of `foo'. */)
1599 (Lisp_Object elt
, Lisp_Object seq
)
1605 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1606 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1609 if (n
!= ASIZE (seq
))
1611 struct Lisp_Vector
*p
= allocate_vector (n
);
1613 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1614 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1615 p
->contents
[n
++] = AREF (seq
, i
);
1617 XSETVECTOR (seq
, p
);
1620 else if (STRINGP (seq
))
1622 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1625 for (i
= nchars
= nbytes
= ibyte
= 0;
1627 ++i
, ibyte
+= cbytes
)
1629 if (STRING_MULTIBYTE (seq
))
1631 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1632 cbytes
= CHAR_BYTES (c
);
1640 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1647 if (nchars
!= SCHARS (seq
))
1651 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1652 if (!STRING_MULTIBYTE (seq
))
1653 STRING_SET_UNIBYTE (tem
);
1655 for (i
= nchars
= nbytes
= ibyte
= 0;
1657 ++i
, ibyte
+= cbytes
)
1659 if (STRING_MULTIBYTE (seq
))
1661 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1662 cbytes
= CHAR_BYTES (c
);
1670 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1672 unsigned char *from
= SDATA (seq
) + ibyte
;
1673 unsigned char *to
= SDATA (tem
) + nbytes
;
1679 for (n
= cbytes
; n
--; )
1689 Lisp_Object tail
, prev
;
1691 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1693 CHECK_LIST_CONS (tail
, seq
);
1695 if (!NILP (Fequal (elt
, XCAR (tail
))))
1700 Fsetcdr (prev
, XCDR (tail
));
1711 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1712 doc
: /* Reverse LIST by modifying cdr pointers.
1713 Return the reversed list. */)
1716 register Lisp_Object prev
, tail
, next
;
1718 if (NILP (list
)) return list
;
1721 while (!NILP (tail
))
1724 CHECK_LIST_CONS (tail
, list
);
1726 Fsetcdr (tail
, prev
);
1733 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1734 doc
: /* Reverse LIST, copying. Return the reversed list.
1735 See also the function `nreverse', which is used more often. */)
1740 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1743 new = Fcons (XCAR (list
), new);
1745 CHECK_LIST_END (list
, list
);
1749 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1751 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1752 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1753 Returns the sorted list. LIST is modified by side effects.
1754 PREDICATE is called with two elements of LIST, and should return non-nil
1755 if the first element should sort before the second. */)
1756 (Lisp_Object list
, Lisp_Object predicate
)
1758 Lisp_Object front
, back
;
1759 register Lisp_Object len
, tem
;
1760 struct gcpro gcpro1
, gcpro2
;
1761 register int length
;
1764 len
= Flength (list
);
1765 length
= XINT (len
);
1769 XSETINT (len
, (length
/ 2) - 1);
1770 tem
= Fnthcdr (len
, list
);
1772 Fsetcdr (tem
, Qnil
);
1774 GCPRO2 (front
, back
);
1775 front
= Fsort (front
, predicate
);
1776 back
= Fsort (back
, predicate
);
1778 return merge (front
, back
, predicate
);
1782 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1785 register Lisp_Object tail
;
1787 register Lisp_Object l1
, l2
;
1788 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1795 /* It is sufficient to protect org_l1 and org_l2.
1796 When l1 and l2 are updated, we copy the new values
1797 back into the org_ vars. */
1798 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1818 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1834 Fsetcdr (tail
, tem
);
1840 /* This does not check for quits. That is safe since it must terminate. */
1842 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1843 doc
: /* Extract a value from a property list.
1844 PLIST is a property list, which is a list of the form
1845 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1846 corresponding to the given PROP, or nil if PROP is not one of the
1847 properties on the list. This function never signals an error. */)
1848 (Lisp_Object plist
, Lisp_Object prop
)
1850 Lisp_Object tail
, halftail
;
1852 /* halftail is used to detect circular lists. */
1853 tail
= halftail
= plist
;
1854 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1856 if (EQ (prop
, XCAR (tail
)))
1857 return XCAR (XCDR (tail
));
1859 tail
= XCDR (XCDR (tail
));
1860 halftail
= XCDR (halftail
);
1861 if (EQ (tail
, halftail
))
1864 #if 0 /* Unsafe version. */
1865 /* This function can be called asynchronously
1866 (setup_coding_system). Don't QUIT in that case. */
1867 if (!interrupt_input_blocked
)
1875 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1876 doc
: /* Return the value of SYMBOL's PROPNAME property.
1877 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1878 (Lisp_Object symbol
, Lisp_Object propname
)
1880 CHECK_SYMBOL (symbol
);
1881 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1884 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1885 doc
: /* Change value in PLIST of PROP to VAL.
1886 PLIST is a property list, which is a list of the form
1887 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1888 If PROP is already a property on the list, its value is set to VAL,
1889 otherwise the new PROP VAL pair is added. The new plist is returned;
1890 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1891 The PLIST is modified by side effects. */)
1892 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1894 register Lisp_Object tail
, prev
;
1895 Lisp_Object newcell
;
1897 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1898 tail
= XCDR (XCDR (tail
)))
1900 if (EQ (prop
, XCAR (tail
)))
1902 Fsetcar (XCDR (tail
), val
);
1909 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1913 Fsetcdr (XCDR (prev
), newcell
);
1917 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1918 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1919 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1920 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1922 CHECK_SYMBOL (symbol
);
1923 XSYMBOL (symbol
)->plist
1924 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1928 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1929 doc
: /* Extract a value from a property list, comparing with `equal'.
1930 PLIST is a property list, which is a list of the form
1931 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1932 corresponding to the given PROP, or nil if PROP is not
1933 one of the properties on the list. */)
1934 (Lisp_Object plist
, Lisp_Object prop
)
1939 CONSP (tail
) && CONSP (XCDR (tail
));
1940 tail
= XCDR (XCDR (tail
)))
1942 if (! NILP (Fequal (prop
, XCAR (tail
))))
1943 return XCAR (XCDR (tail
));
1948 CHECK_LIST_END (tail
, prop
);
1953 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1954 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1955 PLIST is a property list, which is a list of the form
1956 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1957 If PROP is already a property on the list, its value is set to VAL,
1958 otherwise the new PROP VAL pair is added. The new plist is returned;
1959 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1960 The PLIST is modified by side effects. */)
1961 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1963 register Lisp_Object tail
, prev
;
1964 Lisp_Object newcell
;
1966 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1967 tail
= XCDR (XCDR (tail
)))
1969 if (! NILP (Fequal (prop
, XCAR (tail
))))
1971 Fsetcar (XCDR (tail
), val
);
1978 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1982 Fsetcdr (XCDR (prev
), newcell
);
1986 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1987 doc
: /* Return t if the two args are the same Lisp object.
1988 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1989 (Lisp_Object obj1
, Lisp_Object obj2
)
1992 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1994 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1997 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1998 doc
: /* Return t if two Lisp objects have similar structure and contents.
1999 They must have the same data type.
2000 Conses are compared by comparing the cars and the cdrs.
2001 Vectors and strings are compared element by element.
2002 Numbers are compared by value, but integers cannot equal floats.
2003 (Use `=' if you want integers and floats to be able to be equal.)
2004 Symbols must match exactly. */)
2005 (register Lisp_Object o1
, Lisp_Object o2
)
2007 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2010 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2011 doc
: /* Return t if two Lisp objects have similar structure and contents.
2012 This is like `equal' except that it compares the text properties
2013 of strings. (`equal' ignores text properties.) */)
2014 (register Lisp_Object o1
, Lisp_Object o2
)
2016 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2019 /* DEPTH is current depth of recursion. Signal an error if it
2021 PROPS, if non-nil, means compare string text properties too. */
2024 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2027 error ("Stack overflow in equal");
2033 if (XTYPE (o1
) != XTYPE (o2
))
2042 d1
= extract_float (o1
);
2043 d2
= extract_float (o2
);
2044 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2045 though they are not =. */
2046 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2050 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2057 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2061 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2063 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2066 o1
= XOVERLAY (o1
)->plist
;
2067 o2
= XOVERLAY (o2
)->plist
;
2072 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2073 && (XMARKER (o1
)->buffer
== 0
2074 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2078 case Lisp_Vectorlike
:
2081 EMACS_INT size
= ASIZE (o1
);
2082 /* Pseudovectors have the type encoded in the size field, so this test
2083 actually checks that the objects have the same type as well as the
2085 if (ASIZE (o2
) != size
)
2087 /* Boolvectors are compared much like strings. */
2088 if (BOOL_VECTOR_P (o1
))
2091 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2092 / BOOL_VECTOR_BITS_PER_CHAR
);
2094 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2096 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2101 if (WINDOW_CONFIGURATIONP (o1
))
2102 return compare_window_configurations (o1
, o2
, 0);
2104 /* Aside from them, only true vectors, char-tables, compiled
2105 functions, and fonts (font-spec, font-entity, font-ojbect)
2106 are sensible to compare, so eliminate the others now. */
2107 if (size
& PSEUDOVECTOR_FLAG
)
2109 if (!(size
& (PVEC_COMPILED
2110 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2112 size
&= PSEUDOVECTOR_SIZE_MASK
;
2114 for (i
= 0; i
< size
; i
++)
2119 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2127 if (SCHARS (o1
) != SCHARS (o2
))
2129 if (SBYTES (o1
) != SBYTES (o2
))
2131 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2133 if (props
&& !compare_string_intervals (o1
, o2
))
2145 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2146 doc
: /* Store each element of ARRAY with ITEM.
2147 ARRAY is a vector, string, char-table, or bool-vector. */)
2148 (Lisp_Object array
, Lisp_Object item
)
2150 register int size
, index
, charval
;
2151 if (VECTORP (array
))
2153 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2154 size
= ASIZE (array
);
2155 for (index
= 0; index
< size
; index
++)
2158 else if (CHAR_TABLE_P (array
))
2162 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2163 XCHAR_TABLE (array
)->contents
[i
] = item
;
2164 XCHAR_TABLE (array
)->defalt
= item
;
2166 else if (STRINGP (array
))
2168 register unsigned char *p
= SDATA (array
);
2169 CHECK_NUMBER (item
);
2170 charval
= XINT (item
);
2171 size
= SCHARS (array
);
2172 if (STRING_MULTIBYTE (array
))
2174 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2175 int len
= CHAR_STRING (charval
, str
);
2176 int size_byte
= SBYTES (array
);
2177 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2180 if (size
!= size_byte
)
2183 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2184 if (len
!= this_len
)
2185 error ("Attempt to change byte length of a string");
2188 for (i
= 0; i
< size_byte
; i
++)
2189 *p
++ = str
[i
% len
];
2192 for (index
= 0; index
< size
; index
++)
2195 else if (BOOL_VECTOR_P (array
))
2197 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2199 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2200 / BOOL_VECTOR_BITS_PER_CHAR
);
2202 charval
= (! NILP (item
) ? -1 : 0);
2203 for (index
= 0; index
< size_in_chars
- 1; index
++)
2205 if (index
< size_in_chars
)
2207 /* Mask out bits beyond the vector size. */
2208 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2209 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2214 wrong_type_argument (Qarrayp
, array
);
2218 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2220 doc
: /* Clear the contents of STRING.
2221 This makes STRING unibyte and may change its length. */)
2222 (Lisp_Object string
)
2225 CHECK_STRING (string
);
2226 len
= SBYTES (string
);
2227 memset (SDATA (string
), 0, len
);
2228 STRING_SET_CHARS (string
, len
);
2229 STRING_SET_UNIBYTE (string
);
2235 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2237 Lisp_Object args
[2];
2240 return Fnconc (2, args
);
2243 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2244 doc
: /* Concatenate any number of lists by altering them.
2245 Only the last argument is not altered, and need not be a list.
2246 usage: (nconc &rest LISTS) */)
2247 (int nargs
, Lisp_Object
*args
)
2249 register int argnum
;
2250 register Lisp_Object tail
, tem
, val
;
2254 for (argnum
= 0; argnum
< nargs
; argnum
++)
2257 if (NILP (tem
)) continue;
2262 if (argnum
+ 1 == nargs
) break;
2264 CHECK_LIST_CONS (tem
, tem
);
2273 tem
= args
[argnum
+ 1];
2274 Fsetcdr (tail
, tem
);
2276 args
[argnum
+ 1] = tail
;
2282 /* This is the guts of all mapping functions.
2283 Apply FN to each element of SEQ, one by one,
2284 storing the results into elements of VALS, a C vector of Lisp_Objects.
2285 LENI is the length of VALS, which should also be the length of SEQ. */
2288 mapcar1 (int leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2290 register Lisp_Object tail
;
2293 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2297 /* Don't let vals contain any garbage when GC happens. */
2298 for (i
= 0; i
< leni
; i
++)
2301 GCPRO3 (dummy
, fn
, seq
);
2303 gcpro1
.nvars
= leni
;
2307 /* We need not explicitly protect `tail' because it is used only on lists, and
2308 1) lists are not relocated and 2) the list is marked via `seq' so will not
2313 for (i
= 0; i
< leni
; i
++)
2315 dummy
= call1 (fn
, AREF (seq
, i
));
2320 else if (BOOL_VECTOR_P (seq
))
2322 for (i
= 0; i
< leni
; i
++)
2325 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2326 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2327 dummy
= call1 (fn
, dummy
);
2332 else if (STRINGP (seq
))
2336 for (i
= 0, i_byte
= 0; i
< leni
;)
2341 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2342 XSETFASTINT (dummy
, c
);
2343 dummy
= call1 (fn
, dummy
);
2345 vals
[i_before
] = dummy
;
2348 else /* Must be a list, since Flength did not get an error */
2351 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2353 dummy
= call1 (fn
, XCAR (tail
));
2363 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2364 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2365 In between each pair of results, stick in SEPARATOR. Thus, " " as
2366 SEPARATOR results in spaces between the values returned by FUNCTION.
2367 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2368 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2373 register Lisp_Object
*args
;
2375 struct gcpro gcpro1
;
2379 len
= Flength (sequence
);
2380 if (CHAR_TABLE_P (sequence
))
2381 wrong_type_argument (Qlistp
, sequence
);
2383 nargs
= leni
+ leni
- 1;
2384 if (nargs
< 0) return empty_unibyte_string
;
2386 SAFE_ALLOCA_LISP (args
, nargs
);
2389 mapcar1 (leni
, args
, function
, sequence
);
2392 for (i
= leni
- 1; i
> 0; i
--)
2393 args
[i
+ i
] = args
[i
];
2395 for (i
= 1; i
< nargs
; i
+= 2)
2396 args
[i
] = separator
;
2398 ret
= Fconcat (nargs
, args
);
2404 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2405 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2406 The result is a list just as long as SEQUENCE.
2407 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2408 (Lisp_Object function
, Lisp_Object sequence
)
2410 register Lisp_Object len
;
2412 register Lisp_Object
*args
;
2416 len
= Flength (sequence
);
2417 if (CHAR_TABLE_P (sequence
))
2418 wrong_type_argument (Qlistp
, sequence
);
2419 leni
= XFASTINT (len
);
2421 SAFE_ALLOCA_LISP (args
, leni
);
2423 mapcar1 (leni
, args
, function
, sequence
);
2425 ret
= Flist (leni
, args
);
2431 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2432 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2433 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2434 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2435 (Lisp_Object function
, Lisp_Object sequence
)
2439 leni
= XFASTINT (Flength (sequence
));
2440 if (CHAR_TABLE_P (sequence
))
2441 wrong_type_argument (Qlistp
, sequence
);
2442 mapcar1 (leni
, 0, function
, sequence
);
2447 /* This is how C code calls `yes-or-no-p' and allows the user
2450 Anything that calls this function must protect from GC! */
2453 do_yes_or_no_p (Lisp_Object prompt
)
2455 return call1 (intern ("yes-or-no-p"), prompt
);
2458 /* Anything that calls this function must protect from GC! */
2460 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2461 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2462 Takes one argument, which is the string to display to ask the question.
2463 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2464 The user must confirm the answer with RET,
2465 and can edit it until it has been confirmed.
2467 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2468 is nil, and `use-dialog-box' is non-nil. */)
2469 (Lisp_Object prompt
)
2471 register Lisp_Object ans
;
2472 Lisp_Object args
[2];
2473 struct gcpro gcpro1
;
2475 CHECK_STRING (prompt
);
2478 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2479 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2483 Lisp_Object pane
, menu
, obj
;
2484 redisplay_preserve_echo_area (4);
2485 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2486 Fcons (Fcons (build_string ("No"), Qnil
),
2489 menu
= Fcons (prompt
, pane
);
2490 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2494 #endif /* HAVE_MENUS */
2497 args
[1] = build_string ("(yes or no) ");
2498 prompt
= Fconcat (2, args
);
2504 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2505 Qyes_or_no_p_history
, Qnil
,
2507 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2512 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2520 message ("Please answer yes or no.");
2521 Fsleep_for (make_number (2), Qnil
);
2525 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2526 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2528 Each of the three load averages is multiplied by 100, then converted
2531 When USE-FLOATS is non-nil, floats will be used instead of integers.
2532 These floats are not multiplied by 100.
2534 If the 5-minute or 15-minute load averages are not available, return a
2535 shortened list, containing only those averages which are available.
2537 An error is thrown if the load average can't be obtained. In some
2538 cases making it work would require Emacs being installed setuid or
2539 setgid so that it can read kernel information, and that usually isn't
2541 (Lisp_Object use_floats
)
2544 int loads
= getloadavg (load_ave
, 3);
2545 Lisp_Object ret
= Qnil
;
2548 error ("load-average not implemented for this operating system");
2552 Lisp_Object load
= (NILP (use_floats
) ?
2553 make_number ((int) (100.0 * load_ave
[loads
]))
2554 : make_float (load_ave
[loads
]));
2555 ret
= Fcons (load
, ret
);
2561 Lisp_Object Vfeatures
, Qsubfeatures
;
2563 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2564 doc
: /* Return t if FEATURE is present in this Emacs.
2566 Use this to conditionalize execution of lisp code based on the
2567 presence or absence of Emacs or environment extensions.
2568 Use `provide' to declare that a feature is available. This function
2569 looks at the value of the variable `features'. The optional argument
2570 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2571 (Lisp_Object feature
, Lisp_Object subfeature
)
2573 register Lisp_Object tem
;
2574 CHECK_SYMBOL (feature
);
2575 tem
= Fmemq (feature
, Vfeatures
);
2576 if (!NILP (tem
) && !NILP (subfeature
))
2577 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2578 return (NILP (tem
)) ? Qnil
: Qt
;
2581 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2582 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2583 The optional argument SUBFEATURES should be a list of symbols listing
2584 particular subfeatures supported in this version of FEATURE. */)
2585 (Lisp_Object feature
, Lisp_Object subfeatures
)
2587 register Lisp_Object tem
;
2588 CHECK_SYMBOL (feature
);
2589 CHECK_LIST (subfeatures
);
2590 if (!NILP (Vautoload_queue
))
2591 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2593 tem
= Fmemq (feature
, Vfeatures
);
2595 Vfeatures
= Fcons (feature
, Vfeatures
);
2596 if (!NILP (subfeatures
))
2597 Fput (feature
, Qsubfeatures
, subfeatures
);
2598 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2600 /* Run any load-hooks for this file. */
2601 tem
= Fassq (feature
, Vafter_load_alist
);
2603 Fprogn (XCDR (tem
));
2608 /* `require' and its subroutines. */
2610 /* List of features currently being require'd, innermost first. */
2612 Lisp_Object require_nesting_list
;
2615 require_unwind (Lisp_Object old_value
)
2617 return require_nesting_list
= old_value
;
2620 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2621 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2622 If FEATURE is not a member of the list `features', then the feature
2623 is not loaded; so load the file FILENAME.
2624 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2625 and `load' will try to load this name appended with the suffix `.elc' or
2626 `.el', in that order. The name without appended suffix will not be used.
2627 If the optional third argument NOERROR is non-nil,
2628 then return nil if the file is not found instead of signaling an error.
2629 Normally the return value is FEATURE.
2630 The normal messages at start and end of loading FILENAME are suppressed. */)
2631 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2633 register Lisp_Object tem
;
2634 struct gcpro gcpro1
, gcpro2
;
2635 int from_file
= load_in_progress
;
2637 CHECK_SYMBOL (feature
);
2639 /* Record the presence of `require' in this file
2640 even if the feature specified is already loaded.
2641 But not more than once in any file,
2642 and not when we aren't loading or reading from a file. */
2644 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2645 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2650 tem
= Fcons (Qrequire
, feature
);
2651 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2652 LOADHIST_ATTACH (tem
);
2654 tem
= Fmemq (feature
, Vfeatures
);
2658 int count
= SPECPDL_INDEX ();
2661 /* This is to make sure that loadup.el gives a clear picture
2662 of what files are preloaded and when. */
2663 if (! NILP (Vpurify_flag
))
2664 error ("(require %s) while preparing to dump",
2665 SDATA (SYMBOL_NAME (feature
)));
2667 /* A certain amount of recursive `require' is legitimate,
2668 but if we require the same feature recursively 3 times,
2670 tem
= require_nesting_list
;
2671 while (! NILP (tem
))
2673 if (! NILP (Fequal (feature
, XCAR (tem
))))
2678 error ("Recursive `require' for feature `%s'",
2679 SDATA (SYMBOL_NAME (feature
)));
2681 /* Update the list for any nested `require's that occur. */
2682 record_unwind_protect (require_unwind
, require_nesting_list
);
2683 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2685 /* Value saved here is to be restored into Vautoload_queue */
2686 record_unwind_protect (un_autoload
, Vautoload_queue
);
2687 Vautoload_queue
= Qt
;
2689 /* Load the file. */
2690 GCPRO2 (feature
, filename
);
2691 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2692 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2695 /* If load failed entirely, return nil. */
2697 return unbind_to (count
, Qnil
);
2699 tem
= Fmemq (feature
, Vfeatures
);
2701 error ("Required feature `%s' was not provided",
2702 SDATA (SYMBOL_NAME (feature
)));
2704 /* Once loading finishes, don't undo it. */
2705 Vautoload_queue
= Qt
;
2706 feature
= unbind_to (count
, feature
);
2712 /* Primitives for work of the "widget" library.
2713 In an ideal world, this section would not have been necessary.
2714 However, lisp function calls being as slow as they are, it turns
2715 out that some functions in the widget library (wid-edit.el) are the
2716 bottleneck of Widget operation. Here is their translation to C,
2717 for the sole reason of efficiency. */
2719 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2720 doc
: /* Return non-nil if PLIST has the property PROP.
2721 PLIST is a property list, which is a list of the form
2722 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2723 Unlike `plist-get', this allows you to distinguish between a missing
2724 property and a property with the value nil.
2725 The value is actually the tail of PLIST whose car is PROP. */)
2726 (Lisp_Object plist
, Lisp_Object prop
)
2728 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2731 plist
= XCDR (plist
);
2732 plist
= CDR (plist
);
2737 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2738 doc
: /* In WIDGET, set PROPERTY to VALUE.
2739 The value can later be retrieved with `widget-get'. */)
2740 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2742 CHECK_CONS (widget
);
2743 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2747 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2748 doc
: /* In WIDGET, get the value of PROPERTY.
2749 The value could either be specified when the widget was created, or
2750 later with `widget-put'. */)
2751 (Lisp_Object widget
, Lisp_Object property
)
2759 CHECK_CONS (widget
);
2760 tmp
= Fplist_member (XCDR (widget
), property
);
2766 tmp
= XCAR (widget
);
2769 widget
= Fget (tmp
, Qwidget_type
);
2773 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2774 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2775 ARGS are passed as extra arguments to the function.
2776 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2777 (int nargs
, Lisp_Object
*args
)
2779 /* This function can GC. */
2780 Lisp_Object newargs
[3];
2781 struct gcpro gcpro1
, gcpro2
;
2784 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2785 newargs
[1] = args
[0];
2786 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2787 GCPRO2 (newargs
[0], newargs
[2]);
2788 result
= Fapply (3, newargs
);
2793 #ifdef HAVE_LANGINFO_CODESET
2794 #include <langinfo.h>
2797 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2798 doc
: /* Access locale data ITEM for the current C locale, if available.
2799 ITEM should be one of the following:
2801 `codeset', returning the character set as a string (locale item CODESET);
2803 `days', returning a 7-element vector of day names (locale items DAY_n);
2805 `months', returning a 12-element vector of month names (locale items MON_n);
2807 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2808 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2810 If the system can't provide such information through a call to
2811 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2813 See also Info node `(libc)Locales'.
2815 The data read from the system are decoded using `locale-coding-system'. */)
2819 #ifdef HAVE_LANGINFO_CODESET
2821 if (EQ (item
, Qcodeset
))
2823 str
= nl_langinfo (CODESET
);
2824 return build_string (str
);
2827 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2829 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2830 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2832 struct gcpro gcpro1
;
2834 synchronize_system_time_locale ();
2835 for (i
= 0; i
< 7; i
++)
2837 str
= nl_langinfo (days
[i
]);
2838 val
= make_unibyte_string (str
, strlen (str
));
2839 /* Fixme: Is this coding system necessarily right, even if
2840 it is consistent with CODESET? If not, what to do? */
2841 Faset (v
, make_number (i
),
2842 code_convert_string_norecord (val
, Vlocale_coding_system
,
2850 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2852 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2853 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2854 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2856 struct gcpro gcpro1
;
2858 synchronize_system_time_locale ();
2859 for (i
= 0; i
< 12; i
++)
2861 str
= nl_langinfo (months
[i
]);
2862 val
= make_unibyte_string (str
, strlen (str
));
2863 Faset (v
, make_number (i
),
2864 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2870 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2871 but is in the locale files. This could be used by ps-print. */
2873 else if (EQ (item
, Qpaper
))
2875 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2876 make_number (nl_langinfo (PAPER_HEIGHT
)));
2878 #endif /* PAPER_WIDTH */
2879 #endif /* HAVE_LANGINFO_CODESET*/
2883 /* base64 encode/decode functions (RFC 2045).
2884 Based on code from GNU recode. */
2886 #define MIME_LINE_LENGTH 76
2888 #define IS_ASCII(Character) \
2890 #define IS_BASE64(Character) \
2891 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2892 #define IS_BASE64_IGNORABLE(Character) \
2893 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2894 || (Character) == '\f' || (Character) == '\r')
2896 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2897 character or return retval if there are no characters left to
2899 #define READ_QUADRUPLET_BYTE(retval) \
2904 if (nchars_return) \
2905 *nchars_return = nchars; \
2910 while (IS_BASE64_IGNORABLE (c))
2912 /* Table of characters coding the 64 values. */
2913 static const char base64_value_to_char
[64] =
2915 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2916 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2917 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2918 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2919 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2920 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2921 '8', '9', '+', '/' /* 60-63 */
2924 /* Table of base64 values for first 128 characters. */
2925 static const short base64_char_to_value
[128] =
2927 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2928 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2929 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2930 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2931 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2932 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2933 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2934 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2935 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2936 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2937 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2938 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2939 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2942 /* The following diagram shows the logical steps by which three octets
2943 get transformed into four base64 characters.
2945 .--------. .--------. .--------.
2946 |aaaaaabb| |bbbbcccc| |ccdddddd|
2947 `--------' `--------' `--------'
2949 .--------+--------+--------+--------.
2950 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2951 `--------+--------+--------+--------'
2953 .--------+--------+--------+--------.
2954 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2955 `--------+--------+--------+--------'
2957 The octets are divided into 6 bit chunks, which are then encoded into
2958 base64 characters. */
2961 static int base64_encode_1 (const char *, char *, int, int, int);
2962 static int base64_decode_1 (const char *, char *, int, int, int *);
2964 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2966 doc
: /* Base64-encode the region between BEG and END.
2967 Return the length of the encoded text.
2968 Optional third argument NO-LINE-BREAK means do not break long lines
2969 into shorter lines. */)
2970 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2973 int allength
, length
;
2974 int ibeg
, iend
, encoded_length
;
2978 validate_region (&beg
, &end
);
2980 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2981 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2982 move_gap_both (XFASTINT (beg
), ibeg
);
2984 /* We need to allocate enough room for encoding the text.
2985 We need 33 1/3% more space, plus a newline every 76
2986 characters, and then we round up. */
2987 length
= iend
- ibeg
;
2988 allength
= length
+ length
/3 + 1;
2989 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2991 SAFE_ALLOCA (encoded
, char *, allength
);
2992 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2993 NILP (no_line_break
),
2994 !NILP (current_buffer
->enable_multibyte_characters
));
2995 if (encoded_length
> allength
)
2998 if (encoded_length
< 0)
3000 /* The encoding wasn't possible. */
3002 error ("Multibyte character in data for base64 encoding");
3005 /* Now we have encoded the region, so we insert the new contents
3006 and delete the old. (Insert first in order to preserve markers.) */
3007 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3008 insert (encoded
, encoded_length
);
3010 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3012 /* If point was outside of the region, restore it exactly; else just
3013 move to the beginning of the region. */
3014 if (old_pos
>= XFASTINT (end
))
3015 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3016 else if (old_pos
> XFASTINT (beg
))
3017 old_pos
= XFASTINT (beg
);
3020 /* We return the length of the encoded text. */
3021 return make_number (encoded_length
);
3024 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3026 doc
: /* Base64-encode STRING and return the result.
3027 Optional second argument NO-LINE-BREAK means do not break long lines
3028 into shorter lines. */)
3029 (Lisp_Object string
, Lisp_Object no_line_break
)
3031 int allength
, length
, encoded_length
;
3033 Lisp_Object encoded_string
;
3036 CHECK_STRING (string
);
3038 /* We need to allocate enough room for encoding the text.
3039 We need 33 1/3% more space, plus a newline every 76
3040 characters, and then we round up. */
3041 length
= SBYTES (string
);
3042 allength
= length
+ length
/3 + 1;
3043 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3045 /* We need to allocate enough room for decoding the text. */
3046 SAFE_ALLOCA (encoded
, char *, allength
);
3048 encoded_length
= base64_encode_1 (SDATA (string
),
3049 encoded
, length
, NILP (no_line_break
),
3050 STRING_MULTIBYTE (string
));
3051 if (encoded_length
> allength
)
3054 if (encoded_length
< 0)
3056 /* The encoding wasn't possible. */
3058 error ("Multibyte character in data for base64 encoding");
3061 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3064 return encoded_string
;
3068 base64_encode_1 (const char *from
, char *to
, int length
, int line_break
, int multibyte
)
3070 int counter
= 0, i
= 0;
3080 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3081 if (CHAR_BYTE8_P (c
))
3082 c
= CHAR_TO_BYTE8 (c
);
3090 /* Wrap line every 76 characters. */
3094 if (counter
< MIME_LINE_LENGTH
/ 4)
3103 /* Process first byte of a triplet. */
3105 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3106 value
= (0x03 & c
) << 4;
3108 /* Process second byte of a triplet. */
3112 *e
++ = base64_value_to_char
[value
];
3120 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3121 if (CHAR_BYTE8_P (c
))
3122 c
= CHAR_TO_BYTE8 (c
);
3130 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3131 value
= (0x0f & c
) << 2;
3133 /* Process third byte of a triplet. */
3137 *e
++ = base64_value_to_char
[value
];
3144 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3145 if (CHAR_BYTE8_P (c
))
3146 c
= CHAR_TO_BYTE8 (c
);
3154 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3155 *e
++ = base64_value_to_char
[0x3f & c
];
3162 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3164 doc
: /* Base64-decode the region between BEG and END.
3165 Return the length of the decoded text.
3166 If the region can't be decoded, signal an error and don't modify the buffer. */)
3167 (Lisp_Object beg
, Lisp_Object end
)
3169 int ibeg
, iend
, length
, allength
;
3174 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3177 validate_region (&beg
, &end
);
3179 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3180 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3182 length
= iend
- ibeg
;
3184 /* We need to allocate enough room for decoding the text. If we are
3185 working on a multibyte buffer, each decoded code may occupy at
3187 allength
= multibyte
? length
* 2 : length
;
3188 SAFE_ALLOCA (decoded
, char *, allength
);
3190 move_gap_both (XFASTINT (beg
), ibeg
);
3191 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3192 multibyte
, &inserted_chars
);
3193 if (decoded_length
> allength
)
3196 if (decoded_length
< 0)
3198 /* The decoding wasn't possible. */
3200 error ("Invalid base64 data");
3203 /* Now we have decoded the region, so we insert the new contents
3204 and delete the old. (Insert first in order to preserve markers.) */
3205 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3206 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3209 /* Delete the original text. */
3210 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3211 iend
+ decoded_length
, 1);
3213 /* If point was outside of the region, restore it exactly; else just
3214 move to the beginning of the region. */
3215 if (old_pos
>= XFASTINT (end
))
3216 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3217 else if (old_pos
> XFASTINT (beg
))
3218 old_pos
= XFASTINT (beg
);
3219 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3221 return make_number (inserted_chars
);
3224 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3226 doc
: /* Base64-decode STRING and return the result. */)
3227 (Lisp_Object string
)
3230 int length
, decoded_length
;
3231 Lisp_Object decoded_string
;
3234 CHECK_STRING (string
);
3236 length
= SBYTES (string
);
3237 /* We need to allocate enough room for decoding the text. */
3238 SAFE_ALLOCA (decoded
, char *, length
);
3240 /* The decoded result should be unibyte. */
3241 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3243 if (decoded_length
> length
)
3245 else if (decoded_length
>= 0)
3246 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3248 decoded_string
= Qnil
;
3251 if (!STRINGP (decoded_string
))
3252 error ("Invalid base64 data");
3254 return decoded_string
;
3257 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3258 MULTIBYTE is nonzero, the decoded result should be in multibyte
3259 form. If NCHARS_RETRUN is not NULL, store the number of produced
3260 characters in *NCHARS_RETURN. */
3263 base64_decode_1 (const char *from
, char *to
, int length
, int multibyte
, int *nchars_return
)
3268 unsigned long value
;
3273 /* Process first byte of a quadruplet. */
3275 READ_QUADRUPLET_BYTE (e
-to
);
3279 value
= base64_char_to_value
[c
] << 18;
3281 /* Process second byte of a quadruplet. */
3283 READ_QUADRUPLET_BYTE (-1);
3287 value
|= base64_char_to_value
[c
] << 12;
3289 c
= (unsigned char) (value
>> 16);
3290 if (multibyte
&& c
>= 128)
3291 e
+= BYTE8_STRING (c
, e
);
3296 /* Process third byte of a quadruplet. */
3298 READ_QUADRUPLET_BYTE (-1);
3302 READ_QUADRUPLET_BYTE (-1);
3311 value
|= base64_char_to_value
[c
] << 6;
3313 c
= (unsigned char) (0xff & value
>> 8);
3314 if (multibyte
&& c
>= 128)
3315 e
+= BYTE8_STRING (c
, e
);
3320 /* Process fourth byte of a quadruplet. */
3322 READ_QUADRUPLET_BYTE (-1);
3329 value
|= base64_char_to_value
[c
];
3331 c
= (unsigned char) (0xff & value
);
3332 if (multibyte
&& c
>= 128)
3333 e
+= BYTE8_STRING (c
, e
);
3342 /***********************************************************************
3344 ***** Hash Tables *****
3346 ***********************************************************************/
3348 /* Implemented by gerd@gnu.org. This hash table implementation was
3349 inspired by CMUCL hash tables. */
3353 1. For small tables, association lists are probably faster than
3354 hash tables because they have lower overhead.
3356 For uses of hash tables where the O(1) behavior of table
3357 operations is not a requirement, it might therefore be a good idea
3358 not to hash. Instead, we could just do a linear search in the
3359 key_and_value vector of the hash table. This could be done
3360 if a `:linear-search t' argument is given to make-hash-table. */
3363 /* The list of all weak hash tables. Don't staticpro this one. */
3365 struct Lisp_Hash_Table
*weak_hash_tables
;
3367 /* Various symbols. */
3369 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3370 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3371 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3373 /* Function prototypes. */
3375 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3376 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3377 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3378 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3379 Lisp_Object
, unsigned);
3380 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3381 Lisp_Object
, unsigned);
3382 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3383 unsigned, Lisp_Object
, unsigned);
3384 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3385 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3386 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3387 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3389 static unsigned sxhash_string (unsigned char *, int);
3390 static unsigned sxhash_list (Lisp_Object
, int);
3391 static unsigned sxhash_vector (Lisp_Object
, int);
3392 static unsigned sxhash_bool_vector (Lisp_Object
);
3393 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3397 /***********************************************************************
3399 ***********************************************************************/
3401 /* If OBJ is a Lisp hash table, return a pointer to its struct
3402 Lisp_Hash_Table. Otherwise, signal an error. */
3404 static struct Lisp_Hash_Table
*
3405 check_hash_table (Lisp_Object obj
)
3407 CHECK_HASH_TABLE (obj
);
3408 return XHASH_TABLE (obj
);
3412 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3416 next_almost_prime (int n
)
3428 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3429 which USED[I] is non-zero. If found at index I in ARGS, set
3430 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3431 -1. This function is used to extract a keyword/argument pair from
3432 a DEFUN parameter list. */
3435 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3439 for (i
= 0; i
< nargs
- 1; ++i
)
3440 if (!used
[i
] && EQ (args
[i
], key
))
3455 /* Return a Lisp vector which has the same contents as VEC but has
3456 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3457 vector that are not copied from VEC are set to INIT. */
3460 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3462 struct Lisp_Vector
*v
;
3465 xassert (VECTORP (vec
));
3466 old_size
= ASIZE (vec
);
3467 xassert (new_size
>= old_size
);
3469 v
= allocate_vector (new_size
);
3470 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3471 for (i
= old_size
; i
< new_size
; ++i
)
3472 v
->contents
[i
] = init
;
3473 XSETVECTOR (vec
, v
);
3478 /***********************************************************************
3480 ***********************************************************************/
3482 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3483 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3484 KEY2 are the same. */
3487 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3489 return (FLOATP (key1
)
3491 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3495 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3496 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3497 KEY2 are the same. */
3500 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3502 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3506 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3507 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3508 if KEY1 and KEY2 are the same. */
3511 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3515 Lisp_Object args
[3];
3517 args
[0] = h
->user_cmp_function
;
3520 return !NILP (Ffuncall (3, args
));
3527 /* Value is a hash code for KEY for use in hash table H which uses
3528 `eq' to compare keys. The hash code returned is guaranteed to fit
3529 in a Lisp integer. */
3532 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3534 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3535 xassert ((hash
& ~INTMASK
) == 0);
3540 /* Value is a hash code for KEY for use in hash table H which uses
3541 `eql' to compare keys. The hash code returned is guaranteed to fit
3542 in a Lisp integer. */
3545 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3549 hash
= sxhash (key
, 0);
3551 hash
= XUINT (key
) ^ XTYPE (key
);
3552 xassert ((hash
& ~INTMASK
) == 0);
3557 /* Value is a hash code for KEY for use in hash table H which uses
3558 `equal' to compare keys. The hash code returned is guaranteed to fit
3559 in a Lisp integer. */
3562 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3564 unsigned hash
= sxhash (key
, 0);
3565 xassert ((hash
& ~INTMASK
) == 0);
3570 /* Value is a hash code for KEY for use in hash table H which uses as
3571 user-defined function to compare keys. The hash code returned is
3572 guaranteed to fit in a Lisp integer. */
3575 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3577 Lisp_Object args
[2], hash
;
3579 args
[0] = h
->user_hash_function
;
3581 hash
= Ffuncall (2, args
);
3582 if (!INTEGERP (hash
))
3583 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3584 return XUINT (hash
);
3588 /* Create and initialize a new hash table.
3590 TEST specifies the test the hash table will use to compare keys.
3591 It must be either one of the predefined tests `eq', `eql' or
3592 `equal' or a symbol denoting a user-defined test named TEST with
3593 test and hash functions USER_TEST and USER_HASH.
3595 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3597 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3598 new size when it becomes full is computed by adding REHASH_SIZE to
3599 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3600 table's new size is computed by multiplying its old size with
3603 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3604 be resized when the ratio of (number of entries in the table) /
3605 (table size) is >= REHASH_THRESHOLD.
3607 WEAK specifies the weakness of the table. If non-nil, it must be
3608 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3611 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3612 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3613 Lisp_Object user_test
, Lisp_Object user_hash
)
3615 struct Lisp_Hash_Table
*h
;
3617 int index_size
, i
, sz
;
3619 /* Preconditions. */
3620 xassert (SYMBOLP (test
));
3621 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3622 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3623 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3624 xassert (FLOATP (rehash_threshold
)
3625 && XFLOATINT (rehash_threshold
) > 0
3626 && XFLOATINT (rehash_threshold
) <= 1.0);
3628 if (XFASTINT (size
) == 0)
3629 size
= make_number (1);
3631 /* Allocate a table and initialize it. */
3632 h
= allocate_hash_table ();
3634 /* Initialize hash table slots. */
3635 sz
= XFASTINT (size
);
3638 if (EQ (test
, Qeql
))
3640 h
->cmpfn
= cmpfn_eql
;
3641 h
->hashfn
= hashfn_eql
;
3643 else if (EQ (test
, Qeq
))
3646 h
->hashfn
= hashfn_eq
;
3648 else if (EQ (test
, Qequal
))
3650 h
->cmpfn
= cmpfn_equal
;
3651 h
->hashfn
= hashfn_equal
;
3655 h
->user_cmp_function
= user_test
;
3656 h
->user_hash_function
= user_hash
;
3657 h
->cmpfn
= cmpfn_user_defined
;
3658 h
->hashfn
= hashfn_user_defined
;
3662 h
->rehash_threshold
= rehash_threshold
;
3663 h
->rehash_size
= rehash_size
;
3665 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3666 h
->hash
= Fmake_vector (size
, Qnil
);
3667 h
->next
= Fmake_vector (size
, Qnil
);
3668 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3669 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3670 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3672 /* Set up the free list. */
3673 for (i
= 0; i
< sz
- 1; ++i
)
3674 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3675 h
->next_free
= make_number (0);
3677 XSET_HASH_TABLE (table
, h
);
3678 xassert (HASH_TABLE_P (table
));
3679 xassert (XHASH_TABLE (table
) == h
);
3681 /* Maybe add this hash table to the list of all weak hash tables. */
3683 h
->next_weak
= NULL
;
3686 h
->next_weak
= weak_hash_tables
;
3687 weak_hash_tables
= h
;
3694 /* Return a copy of hash table H1. Keys and values are not copied,
3695 only the table itself is. */
3698 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3701 struct Lisp_Hash_Table
*h2
;
3702 struct Lisp_Vector
*next
;
3704 h2
= allocate_hash_table ();
3705 next
= h2
->vec_next
;
3706 memcpy (h2
, h1
, sizeof *h2
);
3707 h2
->vec_next
= next
;
3708 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3709 h2
->hash
= Fcopy_sequence (h1
->hash
);
3710 h2
->next
= Fcopy_sequence (h1
->next
);
3711 h2
->index
= Fcopy_sequence (h1
->index
);
3712 XSET_HASH_TABLE (table
, h2
);
3714 /* Maybe add this hash table to the list of all weak hash tables. */
3715 if (!NILP (h2
->weak
))
3717 h2
->next_weak
= weak_hash_tables
;
3718 weak_hash_tables
= h2
;
3725 /* Resize hash table H if it's too full. If H cannot be resized
3726 because it's already too large, throw an error. */
3729 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3731 if (NILP (h
->next_free
))
3733 int old_size
= HASH_TABLE_SIZE (h
);
3734 int i
, new_size
, index_size
;
3737 if (INTEGERP (h
->rehash_size
))
3738 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3740 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3741 new_size
= max (old_size
+ 1, new_size
);
3742 index_size
= next_almost_prime ((int)
3744 / XFLOATINT (h
->rehash_threshold
)));
3745 /* Assignment to EMACS_INT stops GCC whining about limited range
3747 nsize
= max (index_size
, 2 * new_size
);
3748 if (nsize
> MOST_POSITIVE_FIXNUM
)
3749 error ("Hash table too large to resize");
3751 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3752 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3753 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3754 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3756 /* Update the free list. Do it so that new entries are added at
3757 the end of the free list. This makes some operations like
3759 for (i
= old_size
; i
< new_size
- 1; ++i
)
3760 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3762 if (!NILP (h
->next_free
))
3764 Lisp_Object last
, next
;
3766 last
= h
->next_free
;
3767 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3771 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3774 XSETFASTINT (h
->next_free
, old_size
);
3777 for (i
= 0; i
< old_size
; ++i
)
3778 if (!NILP (HASH_HASH (h
, i
)))
3780 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3781 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3782 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3783 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3789 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3790 the hash code of KEY. Value is the index of the entry in H
3791 matching KEY, or -1 if not found. */
3794 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3797 int start_of_bucket
;
3800 hash_code
= h
->hashfn (h
, key
);
3804 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3805 idx
= HASH_INDEX (h
, start_of_bucket
);
3807 /* We need not gcpro idx since it's either an integer or nil. */
3810 int i
= XFASTINT (idx
);
3811 if (EQ (key
, HASH_KEY (h
, i
))
3813 && h
->cmpfn (h
, key
, hash_code
,
3814 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3816 idx
= HASH_NEXT (h
, i
);
3819 return NILP (idx
) ? -1 : XFASTINT (idx
);
3823 /* Put an entry into hash table H that associates KEY with VALUE.
3824 HASH is a previously computed hash code of KEY.
3825 Value is the index of the entry in H matching KEY. */
3828 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3830 int start_of_bucket
, i
;
3832 xassert ((hash
& ~INTMASK
) == 0);
3834 /* Increment count after resizing because resizing may fail. */
3835 maybe_resize_hash_table (h
);
3838 /* Store key/value in the key_and_value vector. */
3839 i
= XFASTINT (h
->next_free
);
3840 h
->next_free
= HASH_NEXT (h
, i
);
3841 HASH_KEY (h
, i
) = key
;
3842 HASH_VALUE (h
, i
) = value
;
3844 /* Remember its hash code. */
3845 HASH_HASH (h
, i
) = make_number (hash
);
3847 /* Add new entry to its collision chain. */
3848 start_of_bucket
= hash
% ASIZE (h
->index
);
3849 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3850 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3855 /* Remove the entry matching KEY from hash table H, if there is one. */
3858 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3861 int start_of_bucket
;
3862 Lisp_Object idx
, prev
;
3864 hash_code
= h
->hashfn (h
, key
);
3865 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3866 idx
= HASH_INDEX (h
, start_of_bucket
);
3869 /* We need not gcpro idx, prev since they're either integers or nil. */
3872 int i
= XFASTINT (idx
);
3874 if (EQ (key
, HASH_KEY (h
, i
))
3876 && h
->cmpfn (h
, key
, hash_code
,
3877 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3879 /* Take entry out of collision chain. */
3881 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3883 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3885 /* Clear slots in key_and_value and add the slots to
3887 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3888 HASH_NEXT (h
, i
) = h
->next_free
;
3889 h
->next_free
= make_number (i
);
3891 xassert (h
->count
>= 0);
3897 idx
= HASH_NEXT (h
, i
);
3903 /* Clear hash table H. */
3906 hash_clear (struct Lisp_Hash_Table
*h
)
3910 int i
, size
= HASH_TABLE_SIZE (h
);
3912 for (i
= 0; i
< size
; ++i
)
3914 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3915 HASH_KEY (h
, i
) = Qnil
;
3916 HASH_VALUE (h
, i
) = Qnil
;
3917 HASH_HASH (h
, i
) = Qnil
;
3920 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3921 ASET (h
->index
, i
, Qnil
);
3923 h
->next_free
= make_number (0);
3930 /************************************************************************
3932 ************************************************************************/
3935 init_weak_hash_tables (void)
3937 weak_hash_tables
= NULL
;
3940 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3941 entries from the table that don't survive the current GC.
3942 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3943 non-zero if anything was marked. */
3946 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3948 int bucket
, n
, marked
;
3950 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3953 for (bucket
= 0; bucket
< n
; ++bucket
)
3955 Lisp_Object idx
, next
, prev
;
3957 /* Follow collision chain, removing entries that
3958 don't survive this garbage collection. */
3960 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3962 int i
= XFASTINT (idx
);
3963 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3964 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3967 if (EQ (h
->weak
, Qkey
))
3968 remove_p
= !key_known_to_survive_p
;
3969 else if (EQ (h
->weak
, Qvalue
))
3970 remove_p
= !value_known_to_survive_p
;
3971 else if (EQ (h
->weak
, Qkey_or_value
))
3972 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3973 else if (EQ (h
->weak
, Qkey_and_value
))
3974 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3978 next
= HASH_NEXT (h
, i
);
3980 if (remove_entries_p
)
3984 /* Take out of collision chain. */
3986 HASH_INDEX (h
, bucket
) = next
;
3988 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3990 /* Add to free list. */
3991 HASH_NEXT (h
, i
) = h
->next_free
;
3994 /* Clear key, value, and hash. */
3995 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3996 HASH_HASH (h
, i
) = Qnil
;
4009 /* Make sure key and value survive. */
4010 if (!key_known_to_survive_p
)
4012 mark_object (HASH_KEY (h
, i
));
4016 if (!value_known_to_survive_p
)
4018 mark_object (HASH_VALUE (h
, i
));
4029 /* Remove elements from weak hash tables that don't survive the
4030 current garbage collection. Remove weak tables that don't survive
4031 from Vweak_hash_tables. Called from gc_sweep. */
4034 sweep_weak_hash_tables (void)
4036 struct Lisp_Hash_Table
*h
, *used
, *next
;
4039 /* Mark all keys and values that are in use. Keep on marking until
4040 there is no more change. This is necessary for cases like
4041 value-weak table A containing an entry X -> Y, where Y is used in a
4042 key-weak table B, Z -> Y. If B comes after A in the list of weak
4043 tables, X -> Y might be removed from A, although when looking at B
4044 one finds that it shouldn't. */
4048 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4050 if (h
->size
& ARRAY_MARK_FLAG
)
4051 marked
|= sweep_weak_table (h
, 0);
4056 /* Remove tables and entries that aren't used. */
4057 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4059 next
= h
->next_weak
;
4061 if (h
->size
& ARRAY_MARK_FLAG
)
4063 /* TABLE is marked as used. Sweep its contents. */
4065 sweep_weak_table (h
, 1);
4067 /* Add table to the list of used weak hash tables. */
4068 h
->next_weak
= used
;
4073 weak_hash_tables
= used
;
4078 /***********************************************************************
4079 Hash Code Computation
4080 ***********************************************************************/
4082 /* Maximum depth up to which to dive into Lisp structures. */
4084 #define SXHASH_MAX_DEPTH 3
4086 /* Maximum length up to which to take list and vector elements into
4089 #define SXHASH_MAX_LEN 7
4091 /* Combine two integers X and Y for hashing. */
4093 #define SXHASH_COMBINE(X, Y) \
4094 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4098 /* Return a hash for string PTR which has length LEN. The hash
4099 code returned is guaranteed to fit in a Lisp integer. */
4102 sxhash_string (unsigned char *ptr
, int len
)
4104 unsigned char *p
= ptr
;
4105 unsigned char *end
= p
+ len
;
4114 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4117 return hash
& INTMASK
;
4121 /* Return a hash for list LIST. DEPTH is the current depth in the
4122 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4125 sxhash_list (Lisp_Object list
, int depth
)
4130 if (depth
< SXHASH_MAX_DEPTH
)
4132 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4133 list
= XCDR (list
), ++i
)
4135 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4136 hash
= SXHASH_COMBINE (hash
, hash2
);
4141 unsigned hash2
= sxhash (list
, depth
+ 1);
4142 hash
= SXHASH_COMBINE (hash
, hash2
);
4149 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4150 the Lisp structure. */
4153 sxhash_vector (Lisp_Object vec
, int depth
)
4155 unsigned hash
= ASIZE (vec
);
4158 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4159 for (i
= 0; i
< n
; ++i
)
4161 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4162 hash
= SXHASH_COMBINE (hash
, hash2
);
4169 /* Return a hash for bool-vector VECTOR. */
4172 sxhash_bool_vector (Lisp_Object vec
)
4174 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4177 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4178 for (i
= 0; i
< n
; ++i
)
4179 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4185 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4186 structure. Value is an unsigned integer clipped to INTMASK. */
4189 sxhash (Lisp_Object obj
, int depth
)
4193 if (depth
> SXHASH_MAX_DEPTH
)
4196 switch (XTYPE (obj
))
4207 obj
= SYMBOL_NAME (obj
);
4211 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4214 /* This can be everything from a vector to an overlay. */
4215 case Lisp_Vectorlike
:
4217 /* According to the CL HyperSpec, two arrays are equal only if
4218 they are `eq', except for strings and bit-vectors. In
4219 Emacs, this works differently. We have to compare element
4221 hash
= sxhash_vector (obj
, depth
);
4222 else if (BOOL_VECTOR_P (obj
))
4223 hash
= sxhash_bool_vector (obj
);
4225 /* Others are `equal' if they are `eq', so let's take their
4231 hash
= sxhash_list (obj
, depth
);
4236 double val
= XFLOAT_DATA (obj
);
4237 unsigned char *p
= (unsigned char *) &val
;
4238 unsigned char *e
= p
+ sizeof val
;
4239 for (hash
= 0; p
< e
; ++p
)
4240 hash
= SXHASH_COMBINE (hash
, *p
);
4248 return hash
& INTMASK
;
4253 /***********************************************************************
4255 ***********************************************************************/
4258 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4259 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4262 unsigned hash
= sxhash (obj
, 0);
4263 return make_number (hash
);
4267 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4268 doc
: /* Create and return a new hash table.
4270 Arguments are specified as keyword/argument pairs. The following
4271 arguments are defined:
4273 :test TEST -- TEST must be a symbol that specifies how to compare
4274 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4275 `equal'. User-supplied test and hash functions can be specified via
4276 `define-hash-table-test'.
4278 :size SIZE -- A hint as to how many elements will be put in the table.
4281 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4282 fills up. If REHASH-SIZE is an integer, increase the size by that
4283 amount. If it is a float, it must be > 1.0, and the new size is the
4284 old size multiplied by that factor. Default is 1.5.
4286 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4287 Resize the hash table when the ratio (number of entries / table size)
4288 is greater than or equal to THRESHOLD. Default is 0.8.
4290 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4291 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4292 returned is a weak table. Key/value pairs are removed from a weak
4293 hash table when there are no non-weak references pointing to their
4294 key, value, one of key or value, or both key and value, depending on
4295 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4298 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4299 (int nargs
, Lisp_Object
*args
)
4301 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4302 Lisp_Object user_test
, user_hash
;
4306 /* The vector `used' is used to keep track of arguments that
4307 have been consumed. */
4308 used
= (char *) alloca (nargs
* sizeof *used
);
4309 memset (used
, 0, nargs
* sizeof *used
);
4311 /* See if there's a `:test TEST' among the arguments. */
4312 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4313 test
= i
< 0 ? Qeql
: args
[i
];
4314 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4316 /* See if it is a user-defined test. */
4319 prop
= Fget (test
, Qhash_table_test
);
4320 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4321 signal_error ("Invalid hash table test", test
);
4322 user_test
= XCAR (prop
);
4323 user_hash
= XCAR (XCDR (prop
));
4326 user_test
= user_hash
= Qnil
;
4328 /* See if there's a `:size SIZE' argument. */
4329 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4330 size
= i
< 0 ? Qnil
: args
[i
];
4332 size
= make_number (DEFAULT_HASH_SIZE
);
4333 else if (!INTEGERP (size
) || XINT (size
) < 0)
4334 signal_error ("Invalid hash table size", size
);
4336 /* Look for `:rehash-size SIZE'. */
4337 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4338 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4339 if (!NUMBERP (rehash_size
)
4340 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4341 || XFLOATINT (rehash_size
) <= 1.0)
4342 signal_error ("Invalid hash table rehash size", rehash_size
);
4344 /* Look for `:rehash-threshold THRESHOLD'. */
4345 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4346 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4347 if (!FLOATP (rehash_threshold
)
4348 || XFLOATINT (rehash_threshold
) <= 0.0
4349 || XFLOATINT (rehash_threshold
) > 1.0)
4350 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4352 /* Look for `:weakness WEAK'. */
4353 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4354 weak
= i
< 0 ? Qnil
: args
[i
];
4356 weak
= Qkey_and_value
;
4359 && !EQ (weak
, Qvalue
)
4360 && !EQ (weak
, Qkey_or_value
)
4361 && !EQ (weak
, Qkey_and_value
))
4362 signal_error ("Invalid hash table weakness", weak
);
4364 /* Now, all args should have been used up, or there's a problem. */
4365 for (i
= 0; i
< nargs
; ++i
)
4367 signal_error ("Invalid argument list", args
[i
]);
4369 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4370 user_test
, user_hash
);
4374 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4375 doc
: /* Return a copy of hash table TABLE. */)
4378 return copy_hash_table (check_hash_table (table
));
4382 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4383 doc
: /* Return the number of elements in TABLE. */)
4386 return make_number (check_hash_table (table
)->count
);
4390 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4391 Shash_table_rehash_size
, 1, 1, 0,
4392 doc
: /* Return the current rehash size of TABLE. */)
4395 return check_hash_table (table
)->rehash_size
;
4399 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4400 Shash_table_rehash_threshold
, 1, 1, 0,
4401 doc
: /* Return the current rehash threshold of TABLE. */)
4404 return check_hash_table (table
)->rehash_threshold
;
4408 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4409 doc
: /* Return the size of TABLE.
4410 The size can be used as an argument to `make-hash-table' to create
4411 a hash table than can hold as many elements as TABLE holds
4412 without need for resizing. */)
4415 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4416 return make_number (HASH_TABLE_SIZE (h
));
4420 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4421 doc
: /* Return the test TABLE uses. */)
4424 return check_hash_table (table
)->test
;
4428 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4430 doc
: /* Return the weakness of TABLE. */)
4433 return check_hash_table (table
)->weak
;
4437 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4438 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4441 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4445 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4446 doc
: /* Clear hash table TABLE and return it. */)
4449 hash_clear (check_hash_table (table
));
4450 /* Be compatible with XEmacs. */
4455 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4456 doc
: /* Look up KEY in TABLE and return its associated value.
4457 If KEY is not found, return DFLT which defaults to nil. */)
4458 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4460 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4461 int i
= hash_lookup (h
, key
, NULL
);
4462 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4466 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4467 doc
: /* Associate KEY with VALUE in hash table TABLE.
4468 If KEY is already present in table, replace its current value with
4470 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4472 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4476 i
= hash_lookup (h
, key
, &hash
);
4478 HASH_VALUE (h
, i
) = value
;
4480 hash_put (h
, key
, value
, hash
);
4486 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4487 doc
: /* Remove KEY from TABLE. */)
4488 (Lisp_Object key
, Lisp_Object table
)
4490 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4491 hash_remove_from_table (h
, key
);
4496 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4497 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4498 FUNCTION is called with two arguments, KEY and VALUE. */)
4499 (Lisp_Object function
, Lisp_Object table
)
4501 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4502 Lisp_Object args
[3];
4505 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4506 if (!NILP (HASH_HASH (h
, i
)))
4509 args
[1] = HASH_KEY (h
, i
);
4510 args
[2] = HASH_VALUE (h
, i
);
4518 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4519 Sdefine_hash_table_test
, 3, 3, 0,
4520 doc
: /* Define a new hash table test with name NAME, a symbol.
4522 In hash tables created with NAME specified as test, use TEST to
4523 compare keys, and HASH for computing hash codes of keys.
4525 TEST must be a function taking two arguments and returning non-nil if
4526 both arguments are the same. HASH must be a function taking one
4527 argument and return an integer that is the hash code of the argument.
4528 Hash code computation should use the whole value range of integers,
4529 including negative integers. */)
4530 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4532 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4537 /************************************************************************
4539 ************************************************************************/
4543 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4544 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4546 A message digest is a cryptographic checksum of a document, and the
4547 algorithm to calculate it is defined in RFC 1321.
4549 The two optional arguments START and END are character positions
4550 specifying for which part of OBJECT the message digest should be
4551 computed. If nil or omitted, the digest is computed for the whole
4554 The MD5 message digest is computed from the result of encoding the
4555 text in a coding system, not directly from the internal Emacs form of
4556 the text. The optional fourth argument CODING-SYSTEM specifies which
4557 coding system to encode the text with. It should be the same coding
4558 system that you used or will use when actually writing the text into a
4561 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4562 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4563 system would be chosen by default for writing this text into a file.
4565 If OBJECT is a string, the most preferred coding system (see the
4566 command `prefer-coding-system') is used.
4568 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4569 guesswork fails. Normally, an error is signaled in such case. */)
4570 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4572 unsigned char digest
[16];
4573 unsigned char value
[33];
4577 int start_char
= 0, end_char
= 0;
4578 int start_byte
= 0, end_byte
= 0;
4580 register struct buffer
*bp
;
4583 if (STRINGP (object
))
4585 if (NILP (coding_system
))
4587 /* Decide the coding-system to encode the data with. */
4589 if (STRING_MULTIBYTE (object
))
4590 /* use default, we can't guess correct value */
4591 coding_system
= preferred_coding_system ();
4593 coding_system
= Qraw_text
;
4596 if (NILP (Fcoding_system_p (coding_system
)))
4598 /* Invalid coding system. */
4600 if (!NILP (noerror
))
4601 coding_system
= Qraw_text
;
4603 xsignal1 (Qcoding_system_error
, coding_system
);
4606 if (STRING_MULTIBYTE (object
))
4607 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4609 size
= SCHARS (object
);
4610 size_byte
= SBYTES (object
);
4614 CHECK_NUMBER (start
);
4616 start_char
= XINT (start
);
4621 start_byte
= string_char_to_byte (object
, start_char
);
4627 end_byte
= size_byte
;
4633 end_char
= XINT (end
);
4638 end_byte
= string_char_to_byte (object
, end_char
);
4641 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4642 args_out_of_range_3 (object
, make_number (start_char
),
4643 make_number (end_char
));
4647 struct buffer
*prev
= current_buffer
;
4649 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4651 CHECK_BUFFER (object
);
4653 bp
= XBUFFER (object
);
4654 if (bp
!= current_buffer
)
4655 set_buffer_internal (bp
);
4661 CHECK_NUMBER_COERCE_MARKER (start
);
4669 CHECK_NUMBER_COERCE_MARKER (end
);
4674 temp
= b
, b
= e
, e
= temp
;
4676 if (!(BEGV
<= b
&& e
<= ZV
))
4677 args_out_of_range (start
, end
);
4679 if (NILP (coding_system
))
4681 /* Decide the coding-system to encode the data with.
4682 See fileio.c:Fwrite-region */
4684 if (!NILP (Vcoding_system_for_write
))
4685 coding_system
= Vcoding_system_for_write
;
4688 int force_raw_text
= 0;
4690 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4691 if (NILP (coding_system
)
4692 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4694 coding_system
= Qnil
;
4695 if (NILP (current_buffer
->enable_multibyte_characters
))
4699 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4701 /* Check file-coding-system-alist. */
4702 Lisp_Object args
[4], val
;
4704 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4705 args
[3] = Fbuffer_file_name(object
);
4706 val
= Ffind_operation_coding_system (4, args
);
4707 if (CONSP (val
) && !NILP (XCDR (val
)))
4708 coding_system
= XCDR (val
);
4711 if (NILP (coding_system
)
4712 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4714 /* If we still have not decided a coding system, use the
4715 default value of buffer-file-coding-system. */
4716 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4720 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4721 /* Confirm that VAL can surely encode the current region. */
4722 coding_system
= call4 (Vselect_safe_coding_system_function
,
4723 make_number (b
), make_number (e
),
4724 coding_system
, Qnil
);
4727 coding_system
= Qraw_text
;
4730 if (NILP (Fcoding_system_p (coding_system
)))
4732 /* Invalid coding system. */
4734 if (!NILP (noerror
))
4735 coding_system
= Qraw_text
;
4737 xsignal1 (Qcoding_system_error
, coding_system
);
4741 object
= make_buffer_string (b
, e
, 0);
4742 if (prev
!= current_buffer
)
4743 set_buffer_internal (prev
);
4744 /* Discard the unwind protect for recovering the current
4748 if (STRING_MULTIBYTE (object
))
4749 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4752 md5_buffer (SDATA (object
) + start_byte
,
4753 SBYTES (object
) - (size_byte
- end_byte
),
4756 for (i
= 0; i
< 16; i
++)
4757 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4760 return make_string (value
, 32);
4767 /* Hash table stuff. */
4768 Qhash_table_p
= intern_c_string ("hash-table-p");
4769 staticpro (&Qhash_table_p
);
4770 Qeq
= intern_c_string ("eq");
4772 Qeql
= intern_c_string ("eql");
4774 Qequal
= intern_c_string ("equal");
4775 staticpro (&Qequal
);
4776 QCtest
= intern_c_string (":test");
4777 staticpro (&QCtest
);
4778 QCsize
= intern_c_string (":size");
4779 staticpro (&QCsize
);
4780 QCrehash_size
= intern_c_string (":rehash-size");
4781 staticpro (&QCrehash_size
);
4782 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4783 staticpro (&QCrehash_threshold
);
4784 QCweakness
= intern_c_string (":weakness");
4785 staticpro (&QCweakness
);
4786 Qkey
= intern_c_string ("key");
4788 Qvalue
= intern_c_string ("value");
4789 staticpro (&Qvalue
);
4790 Qhash_table_test
= intern_c_string ("hash-table-test");
4791 staticpro (&Qhash_table_test
);
4792 Qkey_or_value
= intern_c_string ("key-or-value");
4793 staticpro (&Qkey_or_value
);
4794 Qkey_and_value
= intern_c_string ("key-and-value");
4795 staticpro (&Qkey_and_value
);
4798 defsubr (&Smake_hash_table
);
4799 defsubr (&Scopy_hash_table
);
4800 defsubr (&Shash_table_count
);
4801 defsubr (&Shash_table_rehash_size
);
4802 defsubr (&Shash_table_rehash_threshold
);
4803 defsubr (&Shash_table_size
);
4804 defsubr (&Shash_table_test
);
4805 defsubr (&Shash_table_weakness
);
4806 defsubr (&Shash_table_p
);
4807 defsubr (&Sclrhash
);
4808 defsubr (&Sgethash
);
4809 defsubr (&Sputhash
);
4810 defsubr (&Sremhash
);
4811 defsubr (&Smaphash
);
4812 defsubr (&Sdefine_hash_table_test
);
4814 Qstring_lessp
= intern_c_string ("string-lessp");
4815 staticpro (&Qstring_lessp
);
4816 Qprovide
= intern_c_string ("provide");
4817 staticpro (&Qprovide
);
4818 Qrequire
= intern_c_string ("require");
4819 staticpro (&Qrequire
);
4820 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4821 staticpro (&Qyes_or_no_p_history
);
4822 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4823 staticpro (&Qcursor_in_echo_area
);
4824 Qwidget_type
= intern_c_string ("widget-type");
4825 staticpro (&Qwidget_type
);
4827 staticpro (&string_char_byte_cache_string
);
4828 string_char_byte_cache_string
= Qnil
;
4830 require_nesting_list
= Qnil
;
4831 staticpro (&require_nesting_list
);
4833 Fset (Qyes_or_no_p_history
, Qnil
);
4835 DEFVAR_LISP ("features", &Vfeatures
,
4836 doc
: /* A list of symbols which are the features of the executing Emacs.
4837 Used by `featurep' and `require', and altered by `provide'. */);
4838 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4839 Qsubfeatures
= intern_c_string ("subfeatures");
4840 staticpro (&Qsubfeatures
);
4842 #ifdef HAVE_LANGINFO_CODESET
4843 Qcodeset
= intern_c_string ("codeset");
4844 staticpro (&Qcodeset
);
4845 Qdays
= intern_c_string ("days");
4847 Qmonths
= intern_c_string ("months");
4848 staticpro (&Qmonths
);
4849 Qpaper
= intern_c_string ("paper");
4850 staticpro (&Qpaper
);
4851 #endif /* HAVE_LANGINFO_CODESET */
4853 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4854 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4855 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4856 invoked by mouse clicks and mouse menu items.
4858 On some platforms, file selection dialogs are also enabled if this is
4862 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
4863 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4864 This applies to commands from menus and tool bar buttons even when
4865 they are initiated from the keyboard. If `use-dialog-box' is nil,
4866 that disables the use of a file dialog, regardless of the value of
4868 use_file_dialog
= 1;
4870 defsubr (&Sidentity
);
4873 defsubr (&Ssafe_length
);
4874 defsubr (&Sstring_bytes
);
4875 defsubr (&Sstring_equal
);
4876 defsubr (&Scompare_strings
);
4877 defsubr (&Sstring_lessp
);
4880 defsubr (&Svconcat
);
4881 defsubr (&Scopy_sequence
);
4882 defsubr (&Sstring_make_multibyte
);
4883 defsubr (&Sstring_make_unibyte
);
4884 defsubr (&Sstring_as_multibyte
);
4885 defsubr (&Sstring_as_unibyte
);
4886 defsubr (&Sstring_to_multibyte
);
4887 defsubr (&Sstring_to_unibyte
);
4888 defsubr (&Scopy_alist
);
4889 defsubr (&Ssubstring
);
4890 defsubr (&Ssubstring_no_properties
);
4903 defsubr (&Snreverse
);
4904 defsubr (&Sreverse
);
4906 defsubr (&Splist_get
);
4908 defsubr (&Splist_put
);
4910 defsubr (&Slax_plist_get
);
4911 defsubr (&Slax_plist_put
);
4914 defsubr (&Sequal_including_properties
);
4915 defsubr (&Sfillarray
);
4916 defsubr (&Sclear_string
);
4920 defsubr (&Smapconcat
);
4921 defsubr (&Syes_or_no_p
);
4922 defsubr (&Sload_average
);
4923 defsubr (&Sfeaturep
);
4924 defsubr (&Srequire
);
4925 defsubr (&Sprovide
);
4926 defsubr (&Splist_member
);
4927 defsubr (&Swidget_put
);
4928 defsubr (&Swidget_get
);
4929 defsubr (&Swidget_apply
);
4930 defsubr (&Sbase64_encode_region
);
4931 defsubr (&Sbase64_decode_region
);
4932 defsubr (&Sbase64_encode_string
);
4933 defsubr (&Sbase64_decode_string
);
4935 defsubr (&Slocale_info
);
4944 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
4945 (do not change this comment) */