1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
33 #include "intervals.h"
36 #include "blockinput.h"
38 #if defined (HAVE_X_WINDOWS)
41 #endif /* HAVE_MENUS */
44 #define NULL ((POINTER_TYPE *)0)
47 Lisp_Object Qstring_lessp
;
48 static Lisp_Object Qprovide
, Qrequire
;
49 static Lisp_Object Qyes_or_no_p_history
;
50 Lisp_Object Qcursor_in_echo_area
;
51 static Lisp_Object Qwidget_type
;
52 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
54 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
56 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
62 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
63 doc
: /* Return the argument unchanged. */)
69 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
70 doc
: /* Return a pseudo-random number.
71 All integers representable in Lisp are equally likely.
72 On most systems, this is 29 bits' worth.
73 With positive integer LIMIT, return random number in interval [0,LIMIT).
74 With argument t, set the random number seed from the current time and pid.
75 Other values of LIMIT are ignored. */)
79 Lisp_Object lispy_val
;
80 EMACS_UINT denominator
;
83 seed_random (getpid () + time (NULL
));
84 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
86 /* Try to take our random number from the higher bits of VAL,
87 not the lower, since (says Gentzel) the low bits of `random'
88 are less random than the higher ones. We do this by using the
89 quotient rather than the remainder. At the high end of the RNG
90 it's possible to get a quotient larger than n; discarding
91 these values eliminates the bias that would otherwise appear
92 when using a large n. */
93 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
95 val
= get_random () / denominator
;
96 while (val
>= XFASTINT (limit
));
100 XSETINT (lispy_val
, val
);
104 /* Heuristic on how many iterations of a tight loop can be safely done
105 before it's time to do a QUIT. This must be a power of 2. */
106 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
108 /* Random data-structure functions */
110 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
111 doc
: /* Return the length of vector, list or string SEQUENCE.
112 A byte-code function object is also allowed.
113 If the string contains multibyte characters, this is not necessarily
114 the number of bytes in the string; it is the number of characters.
115 To get the number of bytes, use `string-bytes'. */)
116 (register Lisp_Object sequence
)
118 register Lisp_Object val
;
120 if (STRINGP (sequence
))
121 XSETFASTINT (val
, SCHARS (sequence
));
122 else if (VECTORP (sequence
))
123 XSETFASTINT (val
, ASIZE (sequence
));
124 else if (CHAR_TABLE_P (sequence
))
125 XSETFASTINT (val
, MAX_CHAR
);
126 else if (BOOL_VECTOR_P (sequence
))
127 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
128 else if (COMPILEDP (sequence
))
129 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
130 else if (CONSP (sequence
))
137 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
139 if (MOST_POSITIVE_FIXNUM
< i
)
140 error ("List too long");
143 sequence
= XCDR (sequence
);
145 while (CONSP (sequence
));
147 CHECK_LIST_END (sequence
, sequence
);
149 val
= make_number (i
);
151 else if (NILP (sequence
))
152 XSETFASTINT (val
, 0);
154 wrong_type_argument (Qsequencep
, sequence
);
159 /* This does not check for quits. That is safe since it must terminate. */
161 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
162 doc
: /* Return the length of a list, but avoid error or infinite loop.
163 This function never gets an error. If LIST is not really a list,
164 it returns 0. If LIST is circular, it returns a finite value
165 which is at least the number of distinct elements. */)
168 Lisp_Object tail
, halftail
;
173 return make_number (0);
175 /* halftail is used to detect circular lists. */
176 for (tail
= halftail
= list
; ; )
181 if (EQ (tail
, halftail
))
184 if ((lolen
& 1) == 0)
186 halftail
= XCDR (halftail
);
187 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
191 hilen
+= UINTMAX_MAX
+ 1.0;
196 /* If the length does not fit into a fixnum, return a float.
197 On all known practical machines this returns an upper bound on
199 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
202 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
203 doc
: /* Return the number of bytes in STRING.
204 If STRING is multibyte, this may be greater than the length of STRING. */)
207 CHECK_STRING (string
);
208 return make_number (SBYTES (string
));
211 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
212 doc
: /* Return t if two strings have identical contents.
213 Case is significant, but text properties are ignored.
214 Symbols are also allowed; their print names are used instead. */)
215 (register Lisp_Object s1
, Lisp_Object s2
)
218 s1
= SYMBOL_NAME (s1
);
220 s2
= SYMBOL_NAME (s2
);
224 if (SCHARS (s1
) != SCHARS (s2
)
225 || SBYTES (s1
) != SBYTES (s2
)
226 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
231 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
232 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
233 In string STR1, skip the first START1 characters and stop at END1.
234 In string STR2, skip the first START2 characters and stop at END2.
235 END1 and END2 default to the full lengths of the respective strings.
237 Case is significant in this comparison if IGNORE-CASE is nil.
238 Unibyte strings are converted to multibyte for comparison.
240 The value is t if the strings (or specified portions) match.
241 If string STR1 is less, the value is a negative number N;
242 - 1 - N is the number of characters that match at the beginning.
243 If string STR1 is greater, the value is a positive number N;
244 N - 1 is the number of characters that match at the beginning. */)
245 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
247 register EMACS_INT end1_char
, end2_char
;
248 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
253 start1
= make_number (0);
255 start2
= make_number (0);
256 CHECK_NATNUM (start1
);
257 CHECK_NATNUM (start2
);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 end1_char
= SCHARS (str1
);
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
273 end2_char
= SCHARS (str2
);
274 if (! NILP (end2
) && end2_char
> XINT (end2
))
275 end2_char
= XINT (end2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
287 c1
= SREF (str1
, i1
++);
288 MAKE_CHAR_MULTIBYTE (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
295 c2
= SREF (str2
, i2
++);
296 MAKE_CHAR_MULTIBYTE (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
+ XINT (start1
));
321 return make_number (i1
- XINT (start1
));
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 doc
: /* Return t if first arg string is less than second in lexicographic order.
335 Symbols are also allowed; their print names are used instead. */)
336 (register Lisp_Object s1
, Lisp_Object s2
)
338 register EMACS_INT end
;
339 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
342 s1
= SYMBOL_NAME (s1
);
344 s2
= SYMBOL_NAME (s2
);
348 i1
= i1_byte
= i2
= i2_byte
= 0;
351 if (end
> SCHARS (s2
))
356 /* When we find a mismatch, we must compare the
357 characters, not just the bytes. */
360 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
361 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
364 return c1
< c2
? Qt
: Qnil
;
366 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
369 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
370 enum Lisp_Type target_type
, int last_special
);
374 concat2 (Lisp_Object s1
, Lisp_Object s2
)
379 return concat (2, args
, Lisp_String
, 0);
384 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
390 return concat (3, args
, Lisp_String
, 0);
393 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
394 doc
: /* Concatenate all the arguments and make the result a list.
395 The result is a list whose elements are the elements of all the arguments.
396 Each argument may be a list, vector or string.
397 The last argument is not copied, just used as the tail of the new list.
398 usage: (append &rest SEQUENCES) */)
399 (ptrdiff_t nargs
, Lisp_Object
*args
)
401 return concat (nargs
, args
, Lisp_Cons
, 1);
404 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
405 doc
: /* Concatenate all the arguments and make the result a string.
406 The result is a string whose elements are the elements of all the arguments.
407 Each argument may be a string or a list or vector of characters (integers).
408 usage: (concat &rest SEQUENCES) */)
409 (ptrdiff_t nargs
, Lisp_Object
*args
)
411 return concat (nargs
, args
, Lisp_String
, 0);
414 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
415 doc
: /* Concatenate all the arguments and make the result a vector.
416 The result is a vector whose elements are the elements of all the arguments.
417 Each argument may be a list, vector or string.
418 usage: (vconcat &rest SEQUENCES) */)
419 (ptrdiff_t nargs
, Lisp_Object
*args
)
421 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
425 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
426 doc
: /* Return a copy of a list, vector, string or char-table.
427 The elements of a list or vector are not copied; they are shared
428 with the original. */)
431 if (NILP (arg
)) return arg
;
433 if (CHAR_TABLE_P (arg
))
435 return copy_char_table (arg
);
438 if (BOOL_VECTOR_P (arg
))
441 ptrdiff_t size_in_chars
442 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
443 / BOOL_VECTOR_BITS_PER_CHAR
);
445 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
446 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
451 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
452 wrong_type_argument (Qsequencep
, arg
);
454 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
457 /* This structure holds information of an argument of `concat' that is
458 a string and has text properties to be copied. */
461 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
462 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
463 EMACS_INT to
; /* refer to VAL (the target string) */
467 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
468 enum Lisp_Type target_type
, int last_special
)
471 register Lisp_Object tail
;
472 register Lisp_Object
this;
474 EMACS_INT toindex_byte
= 0;
475 register EMACS_INT result_len
;
476 register EMACS_INT result_len_byte
;
478 Lisp_Object last_tail
;
481 /* When we make a multibyte string, we can't copy text properties
482 while concatenating each string because the length of resulting
483 string can't be decided until we finish the whole concatenation.
484 So, we record strings that have text properties to be copied
485 here, and copy the text properties after the concatenation. */
486 struct textprop_rec
*textprops
= NULL
;
487 /* Number of elements in textprops. */
488 ptrdiff_t num_textprops
= 0;
493 /* In append, the last arg isn't treated like the others */
494 if (last_special
&& nargs
> 0)
497 last_tail
= args
[nargs
];
502 /* Check each argument. */
503 for (argnum
= 0; argnum
< nargs
; argnum
++)
506 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
507 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
508 wrong_type_argument (Qsequencep
, this);
511 /* Compute total length in chars of arguments in RESULT_LEN.
512 If desired output is a string, also compute length in bytes
513 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
514 whether the result should be a multibyte string. */
518 for (argnum
= 0; argnum
< nargs
; argnum
++)
522 len
= XFASTINT (Flength (this));
523 if (target_type
== Lisp_String
)
525 /* We must count the number of bytes needed in the string
526 as well as the number of characters. */
530 EMACS_INT this_len_byte
;
532 if (VECTORP (this) || COMPILEDP (this))
533 for (i
= 0; i
< len
; i
++)
536 CHECK_CHARACTER (ch
);
538 this_len_byte
= CHAR_BYTES (c
);
539 result_len_byte
+= this_len_byte
;
540 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
543 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
544 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
545 else if (CONSP (this))
546 for (; CONSP (this); this = XCDR (this))
549 CHECK_CHARACTER (ch
);
551 this_len_byte
= CHAR_BYTES (c
);
552 result_len_byte
+= this_len_byte
;
553 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
556 else if (STRINGP (this))
558 if (STRING_MULTIBYTE (this))
561 result_len_byte
+= SBYTES (this);
564 result_len_byte
+= count_size_as_multibyte (SDATA (this),
571 error ("String overflow");
574 if (! some_multibyte
)
575 result_len_byte
= result_len
;
577 /* Create the output object. */
578 if (target_type
== Lisp_Cons
)
579 val
= Fmake_list (make_number (result_len
), Qnil
);
580 else if (target_type
== Lisp_Vectorlike
)
581 val
= Fmake_vector (make_number (result_len
), Qnil
);
582 else if (some_multibyte
)
583 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
585 val
= make_uninit_string (result_len
);
587 /* In `append', if all but last arg are nil, return last arg. */
588 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
591 /* Copy the contents of the args into the result. */
593 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
595 toindex
= 0, toindex_byte
= 0;
599 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
601 for (argnum
= 0; argnum
< nargs
; argnum
++)
604 EMACS_INT thisleni
= 0;
605 register EMACS_INT thisindex
= 0;
606 register EMACS_INT thisindex_byte
= 0;
610 thislen
= Flength (this), thisleni
= XINT (thislen
);
612 /* Between strings of the same kind, copy fast. */
613 if (STRINGP (this) && STRINGP (val
)
614 && STRING_MULTIBYTE (this) == some_multibyte
)
616 EMACS_INT thislen_byte
= SBYTES (this);
618 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
619 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
621 textprops
[num_textprops
].argnum
= argnum
;
622 textprops
[num_textprops
].from
= 0;
623 textprops
[num_textprops
++].to
= toindex
;
625 toindex_byte
+= thislen_byte
;
628 /* Copy a single-byte string to a multibyte string. */
629 else if (STRINGP (this) && STRINGP (val
))
631 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
633 textprops
[num_textprops
].argnum
= argnum
;
634 textprops
[num_textprops
].from
= 0;
635 textprops
[num_textprops
++].to
= toindex
;
637 toindex_byte
+= copy_text (SDATA (this),
638 SDATA (val
) + toindex_byte
,
639 SCHARS (this), 0, 1);
643 /* Copy element by element. */
646 register Lisp_Object elt
;
648 /* Fetch next element of `this' arg into `elt', or break if
649 `this' is exhausted. */
650 if (NILP (this)) break;
652 elt
= XCAR (this), this = XCDR (this);
653 else if (thisindex
>= thisleni
)
655 else if (STRINGP (this))
658 if (STRING_MULTIBYTE (this))
659 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
664 c
= SREF (this, thisindex
); thisindex
++;
665 if (some_multibyte
&& !ASCII_CHAR_P (c
))
666 c
= BYTE8_TO_CHAR (c
);
668 XSETFASTINT (elt
, c
);
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
);
701 CHECK_CHARACTER (elt
);
704 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
706 SSET (val
, toindex_byte
++, c
);
712 XSETCDR (prev
, last_tail
);
714 if (num_textprops
> 0)
717 EMACS_INT last_to_end
= -1;
719 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
721 this = args
[textprops
[argnum
].argnum
];
722 props
= text_property_list (this,
724 make_number (SCHARS (this)),
726 /* If successive arguments have properties, be sure that the
727 value of `composition' property be the copy. */
728 if (last_to_end
== textprops
[argnum
].to
)
729 make_composition_value_copy (props
);
730 add_text_properties_from_list (val
, props
,
731 make_number (textprops
[argnum
].to
));
732 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
740 static Lisp_Object string_char_byte_cache_string
;
741 static EMACS_INT string_char_byte_cache_charpos
;
742 static EMACS_INT string_char_byte_cache_bytepos
;
745 clear_string_char_byte_cache (void)
747 string_char_byte_cache_string
= Qnil
;
750 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
753 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
756 EMACS_INT best_below
, best_below_byte
;
757 EMACS_INT best_above
, best_above_byte
;
759 best_below
= best_below_byte
= 0;
760 best_above
= SCHARS (string
);
761 best_above_byte
= SBYTES (string
);
762 if (best_above
== best_above_byte
)
765 if (EQ (string
, string_char_byte_cache_string
))
767 if (string_char_byte_cache_charpos
< char_index
)
769 best_below
= string_char_byte_cache_charpos
;
770 best_below_byte
= string_char_byte_cache_bytepos
;
774 best_above
= string_char_byte_cache_charpos
;
775 best_above_byte
= string_char_byte_cache_bytepos
;
779 if (char_index
- best_below
< best_above
- char_index
)
781 unsigned char *p
= SDATA (string
) + best_below_byte
;
783 while (best_below
< char_index
)
785 p
+= BYTES_BY_CHAR_HEAD (*p
);
788 i_byte
= p
- SDATA (string
);
792 unsigned char *p
= SDATA (string
) + best_above_byte
;
794 while (best_above
> char_index
)
797 while (!CHAR_HEAD_P (*p
)) p
--;
800 i_byte
= p
- SDATA (string
);
803 string_char_byte_cache_bytepos
= i_byte
;
804 string_char_byte_cache_charpos
= char_index
;
805 string_char_byte_cache_string
= string
;
810 /* Return the character index corresponding to BYTE_INDEX in STRING. */
813 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
816 EMACS_INT best_below
, best_below_byte
;
817 EMACS_INT best_above
, best_above_byte
;
819 best_below
= best_below_byte
= 0;
820 best_above
= SCHARS (string
);
821 best_above_byte
= SBYTES (string
);
822 if (best_above
== best_above_byte
)
825 if (EQ (string
, string_char_byte_cache_string
))
827 if (string_char_byte_cache_bytepos
< byte_index
)
829 best_below
= string_char_byte_cache_charpos
;
830 best_below_byte
= string_char_byte_cache_bytepos
;
834 best_above
= string_char_byte_cache_charpos
;
835 best_above_byte
= string_char_byte_cache_bytepos
;
839 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
841 unsigned char *p
= SDATA (string
) + best_below_byte
;
842 unsigned char *pend
= SDATA (string
) + byte_index
;
846 p
+= BYTES_BY_CHAR_HEAD (*p
);
850 i_byte
= p
- SDATA (string
);
854 unsigned char *p
= SDATA (string
) + best_above_byte
;
855 unsigned char *pbeg
= SDATA (string
) + byte_index
;
860 while (!CHAR_HEAD_P (*p
)) p
--;
864 i_byte
= p
- SDATA (string
);
867 string_char_byte_cache_bytepos
= i_byte
;
868 string_char_byte_cache_charpos
= i
;
869 string_char_byte_cache_string
= string
;
874 /* Convert STRING to a multibyte string. */
877 string_make_multibyte (Lisp_Object string
)
884 if (STRING_MULTIBYTE (string
))
887 nbytes
= count_size_as_multibyte (SDATA (string
),
889 /* If all the chars are ASCII, they won't need any more bytes
890 once converted. In that case, we can return STRING itself. */
891 if (nbytes
== SBYTES (string
))
894 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
895 copy_text (SDATA (string
), buf
, SBYTES (string
),
898 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
905 /* Convert STRING (if unibyte) to a multibyte string without changing
906 the number of characters. Characters 0200 trough 0237 are
907 converted to eight-bit characters. */
910 string_to_multibyte (Lisp_Object string
)
917 if (STRING_MULTIBYTE (string
))
920 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
921 /* If all the chars are ASCII, they won't need any more bytes once
923 if (nbytes
== SBYTES (string
))
924 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
926 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
927 memcpy (buf
, SDATA (string
), SBYTES (string
));
928 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
930 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
937 /* Convert STRING to a single-byte string. */
940 string_make_unibyte (Lisp_Object string
)
947 if (! STRING_MULTIBYTE (string
))
950 nchars
= SCHARS (string
);
952 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
953 copy_text (SDATA (string
), buf
, SBYTES (string
),
956 ret
= make_unibyte_string ((char *) buf
, nchars
);
962 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
964 doc
: /* Return the multibyte equivalent of STRING.
965 If STRING is unibyte and contains non-ASCII characters, the function
966 `unibyte-char-to-multibyte' is used to convert each unibyte character
967 to a multibyte character. In this case, the returned string is a
968 newly created string with no text properties. If STRING is multibyte
969 or entirely ASCII, it is returned unchanged. In particular, when
970 STRING is unibyte and entirely ASCII, the returned string is unibyte.
971 \(When the characters are all ASCII, Emacs primitives will treat the
972 string the same way whether it is unibyte or multibyte.) */)
975 CHECK_STRING (string
);
977 return string_make_multibyte (string
);
980 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
982 doc
: /* Return the unibyte equivalent of STRING.
983 Multibyte character codes are converted to unibyte according to
984 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
985 If the lookup in the translation table fails, this function takes just
986 the low 8 bits of each character. */)
989 CHECK_STRING (string
);
991 return string_make_unibyte (string
);
994 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
996 doc
: /* Return a unibyte string with the same individual bytes as STRING.
997 If STRING is unibyte, the result is STRING itself.
998 Otherwise it is a newly created string, with no text properties.
999 If STRING is multibyte and contains a character of charset
1000 `eight-bit', it is converted to the corresponding single byte. */)
1001 (Lisp_Object string
)
1003 CHECK_STRING (string
);
1005 if (STRING_MULTIBYTE (string
))
1007 EMACS_INT bytes
= SBYTES (string
);
1008 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1010 memcpy (str
, SDATA (string
), bytes
);
1011 bytes
= str_as_unibyte (str
, bytes
);
1012 string
= make_unibyte_string ((char *) str
, bytes
);
1018 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1020 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1021 If STRING is multibyte, the result is STRING itself.
1022 Otherwise it is a newly created string, with no text properties.
1024 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1025 part of a correct utf-8 sequence), it is converted to the corresponding
1026 multibyte character of charset `eight-bit'.
1027 See also `string-to-multibyte'.
1029 Beware, this often doesn't really do what you think it does.
1030 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1031 If you're not sure, whether to use `string-as-multibyte' or
1032 `string-to-multibyte', use `string-to-multibyte'. */)
1033 (Lisp_Object string
)
1035 CHECK_STRING (string
);
1037 if (! STRING_MULTIBYTE (string
))
1039 Lisp_Object new_string
;
1040 EMACS_INT nchars
, nbytes
;
1042 parse_str_as_multibyte (SDATA (string
),
1045 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1046 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1047 if (nbytes
!= SBYTES (string
))
1048 str_as_multibyte (SDATA (new_string
), nbytes
,
1049 SBYTES (string
), NULL
);
1050 string
= new_string
;
1051 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1056 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1058 doc
: /* Return a multibyte string with the same individual chars as STRING.
1059 If STRING is multibyte, the result is STRING itself.
1060 Otherwise it is a newly created string, with no text properties.
1062 If STRING is unibyte and contains an 8-bit byte, it is converted to
1063 the corresponding multibyte character of charset `eight-bit'.
1065 This differs from `string-as-multibyte' by converting each byte of a correct
1066 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1067 correct sequence. */)
1068 (Lisp_Object string
)
1070 CHECK_STRING (string
);
1072 return string_to_multibyte (string
);
1075 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1077 doc
: /* Return a unibyte string with the same individual chars as STRING.
1078 If STRING is unibyte, the result is STRING itself.
1079 Otherwise it is a newly created string, with no text properties,
1080 where each `eight-bit' character is converted to the corresponding byte.
1081 If STRING contains a non-ASCII, non-`eight-bit' character,
1082 an error is signaled. */)
1083 (Lisp_Object string
)
1085 CHECK_STRING (string
);
1087 if (STRING_MULTIBYTE (string
))
1089 EMACS_INT chars
= SCHARS (string
);
1090 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1091 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1093 if (converted
< chars
)
1094 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1095 string
= make_unibyte_string ((char *) str
, chars
);
1102 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1103 doc
: /* Return a copy of ALIST.
1104 This is an alist which represents the same mapping from objects to objects,
1105 but does not share the alist structure with ALIST.
1106 The objects mapped (cars and cdrs of elements of the alist)
1107 are shared, however.
1108 Elements of ALIST that are not conses are also shared. */)
1111 register Lisp_Object tem
;
1116 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1117 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1119 register Lisp_Object car
;
1123 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1128 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1129 doc
: /* Return a new string whose contents are a substring of STRING.
1130 The returned string consists of the characters between index FROM
1131 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1132 zero-indexed: 0 means the first character of STRING. Negative values
1133 are counted from the end of STRING. If TO is nil, the substring runs
1134 to the end of STRING.
1136 The STRING argument may also be a vector. In that case, the return
1137 value is a new vector that contains the elements between index FROM
1138 \(inclusive) and index TO (exclusive) of that vector argument. */)
1139 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1143 EMACS_INT size_byte
= 0;
1144 EMACS_INT from_char
, to_char
;
1145 EMACS_INT from_byte
= 0, to_byte
= 0;
1147 CHECK_VECTOR_OR_STRING (string
);
1148 CHECK_NUMBER (from
);
1150 if (STRINGP (string
))
1152 size
= SCHARS (string
);
1153 size_byte
= SBYTES (string
);
1156 size
= ASIZE (string
);
1161 to_byte
= size_byte
;
1167 to_char
= XINT (to
);
1171 if (STRINGP (string
))
1172 to_byte
= string_char_to_byte (string
, to_char
);
1175 from_char
= XINT (from
);
1178 if (STRINGP (string
))
1179 from_byte
= string_char_to_byte (string
, from_char
);
1181 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1182 args_out_of_range_3 (string
, make_number (from_char
),
1183 make_number (to_char
));
1185 if (STRINGP (string
))
1187 res
= make_specified_string (SSDATA (string
) + from_byte
,
1188 to_char
- from_char
, to_byte
- from_byte
,
1189 STRING_MULTIBYTE (string
));
1190 copy_text_properties (make_number (from_char
), make_number (to_char
),
1191 string
, make_number (0), res
, Qnil
);
1194 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1200 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1201 doc
: /* Return a substring of STRING, without text properties.
1202 It starts at index FROM and ends before TO.
1203 TO may be nil or omitted; then the substring runs to the end of STRING.
1204 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1205 If FROM or TO is negative, it counts from the end.
1207 With one argument, just copy STRING without its properties. */)
1208 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1210 EMACS_INT size
, size_byte
;
1211 EMACS_INT from_char
, to_char
;
1212 EMACS_INT from_byte
, to_byte
;
1214 CHECK_STRING (string
);
1216 size
= SCHARS (string
);
1217 size_byte
= SBYTES (string
);
1220 from_char
= from_byte
= 0;
1223 CHECK_NUMBER (from
);
1224 from_char
= XINT (from
);
1228 from_byte
= string_char_to_byte (string
, from_char
);
1234 to_byte
= size_byte
;
1240 to_char
= XINT (to
);
1244 to_byte
= string_char_to_byte (string
, to_char
);
1247 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1248 args_out_of_range_3 (string
, make_number (from_char
),
1249 make_number (to_char
));
1251 return make_specified_string (SSDATA (string
) + from_byte
,
1252 to_char
- from_char
, to_byte
- from_byte
,
1253 STRING_MULTIBYTE (string
));
1256 /* Extract a substring of STRING, giving start and end positions
1257 both in characters and in bytes. */
1260 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1261 EMACS_INT to
, EMACS_INT to_byte
)
1266 CHECK_VECTOR_OR_STRING (string
);
1268 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1270 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1271 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1273 if (STRINGP (string
))
1275 res
= make_specified_string (SSDATA (string
) + from_byte
,
1276 to
- from
, to_byte
- from_byte
,
1277 STRING_MULTIBYTE (string
));
1278 copy_text_properties (make_number (from
), make_number (to
),
1279 string
, make_number (0), res
, Qnil
);
1282 res
= Fvector (to
- from
, &AREF (string
, from
));
1287 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1288 doc
: /* Take cdr N times on LIST, return the result. */)
1289 (Lisp_Object n
, Lisp_Object list
)
1294 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1297 CHECK_LIST_CONS (list
, list
);
1303 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1304 doc
: /* Return the Nth element of LIST.
1305 N counts from zero. If LIST is not that long, nil is returned. */)
1306 (Lisp_Object n
, Lisp_Object list
)
1308 return Fcar (Fnthcdr (n
, list
));
1311 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1312 doc
: /* Return element of SEQUENCE at index N. */)
1313 (register Lisp_Object sequence
, Lisp_Object n
)
1316 if (CONSP (sequence
) || NILP (sequence
))
1317 return Fcar (Fnthcdr (n
, sequence
));
1319 /* Faref signals a "not array" error, so check here. */
1320 CHECK_ARRAY (sequence
, Qsequencep
);
1321 return Faref (sequence
, n
);
1324 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1325 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1326 The value is actually the tail of LIST whose car is ELT. */)
1327 (register Lisp_Object elt
, Lisp_Object list
)
1329 register Lisp_Object tail
;
1330 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1332 register Lisp_Object tem
;
1333 CHECK_LIST_CONS (tail
, list
);
1335 if (! NILP (Fequal (elt
, tem
)))
1342 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1343 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1344 The value is actually the tail of LIST whose car is ELT. */)
1345 (register Lisp_Object elt
, Lisp_Object list
)
1349 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1353 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1368 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1369 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1370 The value is actually the tail of LIST whose car is ELT. */)
1371 (register Lisp_Object elt
, Lisp_Object list
)
1373 register Lisp_Object tail
;
1376 return Fmemq (elt
, list
);
1378 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1380 register Lisp_Object tem
;
1381 CHECK_LIST_CONS (tail
, list
);
1383 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1390 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1391 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1392 The value is actually the first element of LIST whose car is KEY.
1393 Elements of LIST that are not conses are ignored. */)
1394 (Lisp_Object key
, Lisp_Object list
)
1399 || (CONSP (XCAR (list
))
1400 && EQ (XCAR (XCAR (list
)), key
)))
1405 || (CONSP (XCAR (list
))
1406 && EQ (XCAR (XCAR (list
)), key
)))
1411 || (CONSP (XCAR (list
))
1412 && EQ (XCAR (XCAR (list
)), key
)))
1422 /* Like Fassq but never report an error and do not allow quits.
1423 Use only on lists known never to be circular. */
1426 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1429 && (!CONSP (XCAR (list
))
1430 || !EQ (XCAR (XCAR (list
)), key
)))
1433 return CAR_SAFE (list
);
1436 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1437 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1438 The value is actually the first element of LIST whose car equals KEY. */)
1439 (Lisp_Object key
, Lisp_Object list
)
1446 || (CONSP (XCAR (list
))
1447 && (car
= XCAR (XCAR (list
)),
1448 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1453 || (CONSP (XCAR (list
))
1454 && (car
= XCAR (XCAR (list
)),
1455 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1460 || (CONSP (XCAR (list
))
1461 && (car
= XCAR (XCAR (list
)),
1462 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1472 /* Like Fassoc but never report an error and do not allow quits.
1473 Use only on lists known never to be circular. */
1476 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1479 && (!CONSP (XCAR (list
))
1480 || (!EQ (XCAR (XCAR (list
)), key
)
1481 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1484 return CONSP (list
) ? XCAR (list
) : Qnil
;
1487 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1488 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1489 The value is actually the first element of LIST whose cdr is KEY. */)
1490 (register Lisp_Object key
, Lisp_Object list
)
1495 || (CONSP (XCAR (list
))
1496 && EQ (XCDR (XCAR (list
)), key
)))
1501 || (CONSP (XCAR (list
))
1502 && EQ (XCDR (XCAR (list
)), key
)))
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCDR (XCAR (list
)), key
)))
1518 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1519 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1520 The value is actually the first element of LIST whose cdr equals KEY. */)
1521 (Lisp_Object key
, Lisp_Object list
)
1528 || (CONSP (XCAR (list
))
1529 && (cdr
= XCDR (XCAR (list
)),
1530 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1535 || (CONSP (XCAR (list
))
1536 && (cdr
= XCDR (XCAR (list
)),
1537 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1542 || (CONSP (XCAR (list
))
1543 && (cdr
= XCDR (XCAR (list
)),
1544 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1554 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1555 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1556 The modified LIST is returned. Comparison is done with `eq'.
1557 If the first member of LIST is ELT, there is no way to remove it by side effect;
1558 therefore, write `(setq foo (delq element foo))'
1559 to be sure of changing the value of `foo'. */)
1560 (register Lisp_Object elt
, Lisp_Object list
)
1562 register Lisp_Object tail
, prev
;
1563 register Lisp_Object tem
;
1567 while (!NILP (tail
))
1569 CHECK_LIST_CONS (tail
, list
);
1576 Fsetcdr (prev
, XCDR (tail
));
1586 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1587 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1588 SEQ must be a list, a vector, or a string.
1589 The modified SEQ is returned. Comparison is done with `equal'.
1590 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1591 is not a side effect; it is simply using a different sequence.
1592 Therefore, write `(setq foo (delete element foo))'
1593 to be sure of changing the value of `foo'. */)
1594 (Lisp_Object elt
, Lisp_Object seq
)
1600 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1601 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1604 if (n
!= ASIZE (seq
))
1606 struct Lisp_Vector
*p
= allocate_vector (n
);
1608 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1609 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1610 p
->contents
[n
++] = AREF (seq
, i
);
1612 XSETVECTOR (seq
, p
);
1615 else if (STRINGP (seq
))
1617 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1620 for (i
= nchars
= nbytes
= ibyte
= 0;
1622 ++i
, ibyte
+= cbytes
)
1624 if (STRING_MULTIBYTE (seq
))
1626 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1627 cbytes
= CHAR_BYTES (c
);
1635 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1642 if (nchars
!= SCHARS (seq
))
1646 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1647 if (!STRING_MULTIBYTE (seq
))
1648 STRING_SET_UNIBYTE (tem
);
1650 for (i
= nchars
= nbytes
= ibyte
= 0;
1652 ++i
, ibyte
+= cbytes
)
1654 if (STRING_MULTIBYTE (seq
))
1656 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1657 cbytes
= CHAR_BYTES (c
);
1665 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1667 unsigned char *from
= SDATA (seq
) + ibyte
;
1668 unsigned char *to
= SDATA (tem
) + nbytes
;
1674 for (n
= cbytes
; n
--; )
1684 Lisp_Object tail
, prev
;
1686 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1688 CHECK_LIST_CONS (tail
, seq
);
1690 if (!NILP (Fequal (elt
, XCAR (tail
))))
1695 Fsetcdr (prev
, XCDR (tail
));
1706 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1707 doc
: /* Reverse LIST by modifying cdr pointers.
1708 Return the reversed list. */)
1711 register Lisp_Object prev
, tail
, next
;
1713 if (NILP (list
)) return list
;
1716 while (!NILP (tail
))
1719 CHECK_LIST_CONS (tail
, list
);
1721 Fsetcdr (tail
, prev
);
1728 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1729 doc
: /* Reverse LIST, copying. Return the reversed list.
1730 See also the function `nreverse', which is used more often. */)
1735 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1738 new = Fcons (XCAR (list
), new);
1740 CHECK_LIST_END (list
, list
);
1744 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1746 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1747 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1748 Returns the sorted list. LIST is modified by side effects.
1749 PREDICATE is called with two elements of LIST, and should return non-nil
1750 if the first element should sort before the second. */)
1751 (Lisp_Object list
, Lisp_Object predicate
)
1753 Lisp_Object front
, back
;
1754 register Lisp_Object len
, tem
;
1755 struct gcpro gcpro1
, gcpro2
;
1759 len
= Flength (list
);
1760 length
= XINT (len
);
1764 XSETINT (len
, (length
/ 2) - 1);
1765 tem
= Fnthcdr (len
, list
);
1767 Fsetcdr (tem
, Qnil
);
1769 GCPRO2 (front
, back
);
1770 front
= Fsort (front
, predicate
);
1771 back
= Fsort (back
, predicate
);
1773 return merge (front
, back
, predicate
);
1777 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1780 register Lisp_Object tail
;
1782 register Lisp_Object l1
, l2
;
1783 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1790 /* It is sufficient to protect org_l1 and org_l2.
1791 When l1 and l2 are updated, we copy the new values
1792 back into the org_ vars. */
1793 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1813 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1829 Fsetcdr (tail
, tem
);
1835 /* This does not check for quits. That is safe since it must terminate. */
1837 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1838 doc
: /* Extract a value from a property list.
1839 PLIST is a property list, which is a list of the form
1840 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1841 corresponding to the given PROP, or nil if PROP is not one of the
1842 properties on the list. This function never signals an error. */)
1843 (Lisp_Object plist
, Lisp_Object prop
)
1845 Lisp_Object tail
, halftail
;
1847 /* halftail is used to detect circular lists. */
1848 tail
= halftail
= plist
;
1849 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1851 if (EQ (prop
, XCAR (tail
)))
1852 return XCAR (XCDR (tail
));
1854 tail
= XCDR (XCDR (tail
));
1855 halftail
= XCDR (halftail
);
1856 if (EQ (tail
, halftail
))
1859 #if 0 /* Unsafe version. */
1860 /* This function can be called asynchronously
1861 (setup_coding_system). Don't QUIT in that case. */
1862 if (!interrupt_input_blocked
)
1870 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1871 doc
: /* Return the value of SYMBOL's PROPNAME property.
1872 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1873 (Lisp_Object symbol
, Lisp_Object propname
)
1875 CHECK_SYMBOL (symbol
);
1876 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1879 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1880 doc
: /* Change value in PLIST of PROP to VAL.
1881 PLIST is a property list, which is a list of the form
1882 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1883 If PROP is already a property on the list, its value is set to VAL,
1884 otherwise the new PROP VAL pair is added. The new plist is returned;
1885 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1886 The PLIST is modified by side effects. */)
1887 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1889 register Lisp_Object tail
, prev
;
1890 Lisp_Object newcell
;
1892 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1893 tail
= XCDR (XCDR (tail
)))
1895 if (EQ (prop
, XCAR (tail
)))
1897 Fsetcar (XCDR (tail
), val
);
1904 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1908 Fsetcdr (XCDR (prev
), newcell
);
1912 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1913 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1914 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1915 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1917 CHECK_SYMBOL (symbol
);
1918 XSYMBOL (symbol
)->plist
1919 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1923 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1924 doc
: /* Extract a value from a property list, comparing with `equal'.
1925 PLIST is a property list, which is a list of the form
1926 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1927 corresponding to the given PROP, or nil if PROP is not
1928 one of the properties on the list. */)
1929 (Lisp_Object plist
, Lisp_Object prop
)
1934 CONSP (tail
) && CONSP (XCDR (tail
));
1935 tail
= XCDR (XCDR (tail
)))
1937 if (! NILP (Fequal (prop
, XCAR (tail
))))
1938 return XCAR (XCDR (tail
));
1943 CHECK_LIST_END (tail
, prop
);
1948 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1949 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1950 PLIST is a property list, which is a list of the form
1951 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1952 If PROP is already a property on the list, its value is set to VAL,
1953 otherwise the new PROP VAL pair is added. The new plist is returned;
1954 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1955 The PLIST is modified by side effects. */)
1956 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1958 register Lisp_Object tail
, prev
;
1959 Lisp_Object newcell
;
1961 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1962 tail
= XCDR (XCDR (tail
)))
1964 if (! NILP (Fequal (prop
, XCAR (tail
))))
1966 Fsetcar (XCDR (tail
), val
);
1973 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1977 Fsetcdr (XCDR (prev
), newcell
);
1981 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1982 doc
: /* Return t if the two args are the same Lisp object.
1983 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1984 (Lisp_Object obj1
, Lisp_Object obj2
)
1987 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1989 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1992 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1993 doc
: /* Return t if two Lisp objects have similar structure and contents.
1994 They must have the same data type.
1995 Conses are compared by comparing the cars and the cdrs.
1996 Vectors and strings are compared element by element.
1997 Numbers are compared by value, but integers cannot equal floats.
1998 (Use `=' if you want integers and floats to be able to be equal.)
1999 Symbols must match exactly. */)
2000 (register Lisp_Object o1
, Lisp_Object o2
)
2002 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2005 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2006 doc
: /* Return t if two Lisp objects have similar structure and contents.
2007 This is like `equal' except that it compares the text properties
2008 of strings. (`equal' ignores text properties.) */)
2009 (register Lisp_Object o1
, Lisp_Object o2
)
2011 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2014 /* DEPTH is current depth of recursion. Signal an error if it
2016 PROPS, if non-nil, means compare string text properties too. */
2019 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2022 error ("Stack overflow in equal");
2028 if (XTYPE (o1
) != XTYPE (o2
))
2037 d1
= extract_float (o1
);
2038 d2
= extract_float (o2
);
2039 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2040 though they are not =. */
2041 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2045 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2052 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2056 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2058 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2061 o1
= XOVERLAY (o1
)->plist
;
2062 o2
= XOVERLAY (o2
)->plist
;
2067 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2068 && (XMARKER (o1
)->buffer
== 0
2069 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2073 case Lisp_Vectorlike
:
2076 EMACS_INT size
= ASIZE (o1
);
2077 /* Pseudovectors have the type encoded in the size field, so this test
2078 actually checks that the objects have the same type as well as the
2080 if (ASIZE (o2
) != size
)
2082 /* Boolvectors are compared much like strings. */
2083 if (BOOL_VECTOR_P (o1
))
2085 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2087 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2088 ((XBOOL_VECTOR (o1
)->size
2089 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2090 / BOOL_VECTOR_BITS_PER_CHAR
)))
2094 if (WINDOW_CONFIGURATIONP (o1
))
2095 return compare_window_configurations (o1
, o2
, 0);
2097 /* Aside from them, only true vectors, char-tables, compiled
2098 functions, and fonts (font-spec, font-entity, font-object)
2099 are sensible to compare, so eliminate the others now. */
2100 if (size
& PSEUDOVECTOR_FLAG
)
2102 if (!(size
& (PVEC_COMPILED
2103 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2105 size
&= PSEUDOVECTOR_SIZE_MASK
;
2107 for (i
= 0; i
< size
; i
++)
2112 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2120 if (SCHARS (o1
) != SCHARS (o2
))
2122 if (SBYTES (o1
) != SBYTES (o2
))
2124 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2126 if (props
&& !compare_string_intervals (o1
, o2
))
2138 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2139 doc
: /* Store each element of ARRAY with ITEM.
2140 ARRAY is a vector, string, char-table, or bool-vector. */)
2141 (Lisp_Object array
, Lisp_Object item
)
2143 register EMACS_INT size
, idx
;
2146 if (VECTORP (array
))
2148 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2149 size
= ASIZE (array
);
2150 for (idx
= 0; idx
< size
; idx
++)
2153 else if (CHAR_TABLE_P (array
))
2157 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2158 XCHAR_TABLE (array
)->contents
[i
] = item
;
2159 XCHAR_TABLE (array
)->defalt
= item
;
2161 else if (STRINGP (array
))
2163 register unsigned char *p
= SDATA (array
);
2164 CHECK_NUMBER (item
);
2165 charval
= XINT (item
);
2166 size
= SCHARS (array
);
2167 if (STRING_MULTIBYTE (array
))
2169 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2170 int len
= CHAR_STRING (charval
, str
);
2171 EMACS_INT size_byte
= SBYTES (array
);
2172 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2175 if (size
!= size_byte
)
2178 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2179 if (len
!= this_len
)
2180 error ("Attempt to change byte length of a string");
2183 for (i
= 0; i
< size_byte
; i
++)
2184 *p
++ = str
[i
% len
];
2187 for (idx
= 0; idx
< size
; idx
++)
2190 else if (BOOL_VECTOR_P (array
))
2192 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2194 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2195 / BOOL_VECTOR_BITS_PER_CHAR
);
2197 charval
= (! NILP (item
) ? -1 : 0);
2198 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2200 if (idx
< size_in_chars
)
2202 /* Mask out bits beyond the vector size. */
2203 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2204 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2209 wrong_type_argument (Qarrayp
, array
);
2213 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2215 doc
: /* Clear the contents of STRING.
2216 This makes STRING unibyte and may change its length. */)
2217 (Lisp_Object string
)
2220 CHECK_STRING (string
);
2221 len
= SBYTES (string
);
2222 memset (SDATA (string
), 0, len
);
2223 STRING_SET_CHARS (string
, len
);
2224 STRING_SET_UNIBYTE (string
);
2230 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2232 Lisp_Object args
[2];
2235 return Fnconc (2, args
);
2238 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2239 doc
: /* Concatenate any number of lists by altering them.
2240 Only the last argument is not altered, and need not be a list.
2241 usage: (nconc &rest LISTS) */)
2242 (ptrdiff_t nargs
, Lisp_Object
*args
)
2245 register Lisp_Object tail
, tem
, val
;
2249 for (argnum
= 0; argnum
< nargs
; argnum
++)
2252 if (NILP (tem
)) continue;
2257 if (argnum
+ 1 == nargs
) break;
2259 CHECK_LIST_CONS (tem
, tem
);
2268 tem
= args
[argnum
+ 1];
2269 Fsetcdr (tail
, tem
);
2271 args
[argnum
+ 1] = tail
;
2277 /* This is the guts of all mapping functions.
2278 Apply FN to each element of SEQ, one by one,
2279 storing the results into elements of VALS, a C vector of Lisp_Objects.
2280 LENI is the length of VALS, which should also be the length of SEQ. */
2283 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2285 register Lisp_Object tail
;
2287 register EMACS_INT i
;
2288 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2292 /* Don't let vals contain any garbage when GC happens. */
2293 for (i
= 0; i
< leni
; i
++)
2296 GCPRO3 (dummy
, fn
, seq
);
2298 gcpro1
.nvars
= leni
;
2302 /* We need not explicitly protect `tail' because it is used only on lists, and
2303 1) lists are not relocated and 2) the list is marked via `seq' so will not
2306 if (VECTORP (seq
) || COMPILEDP (seq
))
2308 for (i
= 0; i
< leni
; i
++)
2310 dummy
= call1 (fn
, AREF (seq
, i
));
2315 else if (BOOL_VECTOR_P (seq
))
2317 for (i
= 0; i
< leni
; i
++)
2320 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2321 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2322 dummy
= call1 (fn
, dummy
);
2327 else if (STRINGP (seq
))
2331 for (i
= 0, i_byte
= 0; i
< leni
;)
2334 EMACS_INT i_before
= i
;
2336 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2337 XSETFASTINT (dummy
, c
);
2338 dummy
= call1 (fn
, dummy
);
2340 vals
[i_before
] = dummy
;
2343 else /* Must be a list, since Flength did not get an error */
2346 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2348 dummy
= call1 (fn
, XCAR (tail
));
2358 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2359 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2360 In between each pair of results, stick in SEPARATOR. Thus, " " as
2361 SEPARATOR results in spaces between the values returned by FUNCTION.
2362 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2363 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2366 register EMACS_INT leni
;
2368 register Lisp_Object
*args
;
2369 struct gcpro gcpro1
;
2373 len
= Flength (sequence
);
2374 if (CHAR_TABLE_P (sequence
))
2375 wrong_type_argument (Qlistp
, sequence
);
2377 nargs
= leni
+ leni
- 1;
2378 if (nargs
< 0) return empty_unibyte_string
;
2380 SAFE_ALLOCA_LISP (args
, nargs
);
2383 mapcar1 (leni
, args
, function
, sequence
);
2386 for (i
= leni
- 1; i
> 0; i
--)
2387 args
[i
+ i
] = args
[i
];
2389 for (i
= 1; i
< nargs
; i
+= 2)
2390 args
[i
] = separator
;
2392 ret
= Fconcat (nargs
, args
);
2398 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2399 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2400 The result is a list just as long as SEQUENCE.
2401 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2402 (Lisp_Object function
, Lisp_Object sequence
)
2404 register Lisp_Object len
;
2405 register EMACS_INT leni
;
2406 register Lisp_Object
*args
;
2410 len
= Flength (sequence
);
2411 if (CHAR_TABLE_P (sequence
))
2412 wrong_type_argument (Qlistp
, sequence
);
2413 leni
= XFASTINT (len
);
2415 SAFE_ALLOCA_LISP (args
, leni
);
2417 mapcar1 (leni
, args
, function
, sequence
);
2419 ret
= Flist (leni
, args
);
2425 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2426 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2427 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2428 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2429 (Lisp_Object function
, Lisp_Object sequence
)
2431 register EMACS_INT leni
;
2433 leni
= XFASTINT (Flength (sequence
));
2434 if (CHAR_TABLE_P (sequence
))
2435 wrong_type_argument (Qlistp
, sequence
);
2436 mapcar1 (leni
, 0, function
, sequence
);
2441 /* This is how C code calls `yes-or-no-p' and allows the user
2444 Anything that calls this function must protect from GC! */
2447 do_yes_or_no_p (Lisp_Object prompt
)
2449 return call1 (intern ("yes-or-no-p"), prompt
);
2452 /* Anything that calls this function must protect from GC! */
2454 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2455 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2456 PROMPT is the string to display to ask the question. It should end in
2457 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2459 The user must confirm the answer with RET, and can edit it until it
2462 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2463 is nil, and `use-dialog-box' is non-nil. */)
2464 (Lisp_Object prompt
)
2466 register Lisp_Object ans
;
2467 Lisp_Object args
[2];
2468 struct gcpro gcpro1
;
2470 CHECK_STRING (prompt
);
2473 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2474 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2478 Lisp_Object pane
, menu
, obj
;
2479 redisplay_preserve_echo_area (4);
2480 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2481 Fcons (Fcons (build_string ("No"), Qnil
),
2484 menu
= Fcons (prompt
, pane
);
2485 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2489 #endif /* HAVE_MENUS */
2492 args
[1] = build_string ("(yes or no) ");
2493 prompt
= Fconcat (2, args
);
2499 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2500 Qyes_or_no_p_history
, Qnil
,
2502 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2507 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2515 message ("Please answer yes or no.");
2516 Fsleep_for (make_number (2), Qnil
);
2520 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2521 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2523 Each of the three load averages is multiplied by 100, then converted
2526 When USE-FLOATS is non-nil, floats will be used instead of integers.
2527 These floats are not multiplied by 100.
2529 If the 5-minute or 15-minute load averages are not available, return a
2530 shortened list, containing only those averages which are available.
2532 An error is thrown if the load average can't be obtained. In some
2533 cases making it work would require Emacs being installed setuid or
2534 setgid so that it can read kernel information, and that usually isn't
2536 (Lisp_Object use_floats
)
2539 int loads
= getloadavg (load_ave
, 3);
2540 Lisp_Object ret
= Qnil
;
2543 error ("load-average not implemented for this operating system");
2547 Lisp_Object load
= (NILP (use_floats
)
2548 ? make_number (100.0 * load_ave
[loads
])
2549 : make_float (load_ave
[loads
]));
2550 ret
= Fcons (load
, ret
);
2556 static Lisp_Object Qsubfeatures
;
2558 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2559 doc
: /* Return t if FEATURE is present in this Emacs.
2561 Use this to conditionalize execution of lisp code based on the
2562 presence or absence of Emacs or environment extensions.
2563 Use `provide' to declare that a feature is available. This function
2564 looks at the value of the variable `features'. The optional argument
2565 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2566 (Lisp_Object feature
, Lisp_Object subfeature
)
2568 register Lisp_Object tem
;
2569 CHECK_SYMBOL (feature
);
2570 tem
= Fmemq (feature
, Vfeatures
);
2571 if (!NILP (tem
) && !NILP (subfeature
))
2572 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2573 return (NILP (tem
)) ? Qnil
: Qt
;
2576 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2577 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2578 The optional argument SUBFEATURES should be a list of symbols listing
2579 particular subfeatures supported in this version of FEATURE. */)
2580 (Lisp_Object feature
, Lisp_Object subfeatures
)
2582 register Lisp_Object tem
;
2583 CHECK_SYMBOL (feature
);
2584 CHECK_LIST (subfeatures
);
2585 if (!NILP (Vautoload_queue
))
2586 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2588 tem
= Fmemq (feature
, Vfeatures
);
2590 Vfeatures
= Fcons (feature
, Vfeatures
);
2591 if (!NILP (subfeatures
))
2592 Fput (feature
, Qsubfeatures
, subfeatures
);
2593 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2595 /* Run any load-hooks for this file. */
2596 tem
= Fassq (feature
, Vafter_load_alist
);
2598 Fprogn (XCDR (tem
));
2603 /* `require' and its subroutines. */
2605 /* List of features currently being require'd, innermost first. */
2607 static Lisp_Object require_nesting_list
;
2610 require_unwind (Lisp_Object old_value
)
2612 return require_nesting_list
= old_value
;
2615 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2616 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2617 If FEATURE is not a member of the list `features', then the feature
2618 is not loaded; so load the file FILENAME.
2619 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2620 and `load' will try to load this name appended with the suffix `.elc' or
2621 `.el', in that order. The name without appended suffix will not be used.
2622 If the optional third argument NOERROR is non-nil,
2623 then return nil if the file is not found instead of signaling an error.
2624 Normally the return value is FEATURE.
2625 The normal messages at start and end of loading FILENAME are suppressed. */)
2626 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2628 register Lisp_Object tem
;
2629 struct gcpro gcpro1
, gcpro2
;
2630 int from_file
= load_in_progress
;
2632 CHECK_SYMBOL (feature
);
2634 /* Record the presence of `require' in this file
2635 even if the feature specified is already loaded.
2636 But not more than once in any file,
2637 and not when we aren't loading or reading from a file. */
2639 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2640 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2645 tem
= Fcons (Qrequire
, feature
);
2646 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2647 LOADHIST_ATTACH (tem
);
2649 tem
= Fmemq (feature
, Vfeatures
);
2653 int count
= SPECPDL_INDEX ();
2656 /* This is to make sure that loadup.el gives a clear picture
2657 of what files are preloaded and when. */
2658 if (! NILP (Vpurify_flag
))
2659 error ("(require %s) while preparing to dump",
2660 SDATA (SYMBOL_NAME (feature
)));
2662 /* A certain amount of recursive `require' is legitimate,
2663 but if we require the same feature recursively 3 times,
2665 tem
= require_nesting_list
;
2666 while (! NILP (tem
))
2668 if (! NILP (Fequal (feature
, XCAR (tem
))))
2673 error ("Recursive `require' for feature `%s'",
2674 SDATA (SYMBOL_NAME (feature
)));
2676 /* Update the list for any nested `require's that occur. */
2677 record_unwind_protect (require_unwind
, require_nesting_list
);
2678 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2680 /* Value saved here is to be restored into Vautoload_queue */
2681 record_unwind_protect (un_autoload
, Vautoload_queue
);
2682 Vautoload_queue
= Qt
;
2684 /* Load the file. */
2685 GCPRO2 (feature
, filename
);
2686 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2687 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2690 /* If load failed entirely, return nil. */
2692 return unbind_to (count
, Qnil
);
2694 tem
= Fmemq (feature
, Vfeatures
);
2696 error ("Required feature `%s' was not provided",
2697 SDATA (SYMBOL_NAME (feature
)));
2699 /* Once loading finishes, don't undo it. */
2700 Vautoload_queue
= Qt
;
2701 feature
= unbind_to (count
, feature
);
2707 /* Primitives for work of the "widget" library.
2708 In an ideal world, this section would not have been necessary.
2709 However, lisp function calls being as slow as they are, it turns
2710 out that some functions in the widget library (wid-edit.el) are the
2711 bottleneck of Widget operation. Here is their translation to C,
2712 for the sole reason of efficiency. */
2714 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2715 doc
: /* Return non-nil if PLIST has the property PROP.
2716 PLIST is a property list, which is a list of the form
2717 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2718 Unlike `plist-get', this allows you to distinguish between a missing
2719 property and a property with the value nil.
2720 The value is actually the tail of PLIST whose car is PROP. */)
2721 (Lisp_Object plist
, Lisp_Object prop
)
2723 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2726 plist
= XCDR (plist
);
2727 plist
= CDR (plist
);
2732 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2733 doc
: /* In WIDGET, set PROPERTY to VALUE.
2734 The value can later be retrieved with `widget-get'. */)
2735 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2737 CHECK_CONS (widget
);
2738 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2742 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2743 doc
: /* In WIDGET, get the value of PROPERTY.
2744 The value could either be specified when the widget was created, or
2745 later with `widget-put'. */)
2746 (Lisp_Object widget
, Lisp_Object property
)
2754 CHECK_CONS (widget
);
2755 tmp
= Fplist_member (XCDR (widget
), property
);
2761 tmp
= XCAR (widget
);
2764 widget
= Fget (tmp
, Qwidget_type
);
2768 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2769 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2770 ARGS are passed as extra arguments to the function.
2771 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2772 (ptrdiff_t nargs
, Lisp_Object
*args
)
2774 /* This function can GC. */
2775 Lisp_Object newargs
[3];
2776 struct gcpro gcpro1
, gcpro2
;
2779 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2780 newargs
[1] = args
[0];
2781 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2782 GCPRO2 (newargs
[0], newargs
[2]);
2783 result
= Fapply (3, newargs
);
2788 #ifdef HAVE_LANGINFO_CODESET
2789 #include <langinfo.h>
2792 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2793 doc
: /* Access locale data ITEM for the current C locale, if available.
2794 ITEM should be one of the following:
2796 `codeset', returning the character set as a string (locale item CODESET);
2798 `days', returning a 7-element vector of day names (locale items DAY_n);
2800 `months', returning a 12-element vector of month names (locale items MON_n);
2802 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2803 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2805 If the system can't provide such information through a call to
2806 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2808 See also Info node `(libc)Locales'.
2810 The data read from the system are decoded using `locale-coding-system'. */)
2814 #ifdef HAVE_LANGINFO_CODESET
2816 if (EQ (item
, Qcodeset
))
2818 str
= nl_langinfo (CODESET
);
2819 return build_string (str
);
2822 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2824 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2825 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2827 struct gcpro gcpro1
;
2829 synchronize_system_time_locale ();
2830 for (i
= 0; i
< 7; i
++)
2832 str
= nl_langinfo (days
[i
]);
2833 val
= make_unibyte_string (str
, strlen (str
));
2834 /* Fixme: Is this coding system necessarily right, even if
2835 it is consistent with CODESET? If not, what to do? */
2836 Faset (v
, make_number (i
),
2837 code_convert_string_norecord (val
, Vlocale_coding_system
,
2845 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2847 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2848 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2849 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2851 struct gcpro gcpro1
;
2853 synchronize_system_time_locale ();
2854 for (i
= 0; i
< 12; i
++)
2856 str
= nl_langinfo (months
[i
]);
2857 val
= make_unibyte_string (str
, strlen (str
));
2858 Faset (v
, make_number (i
),
2859 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2865 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2866 but is in the locale files. This could be used by ps-print. */
2868 else if (EQ (item
, Qpaper
))
2870 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2871 make_number (nl_langinfo (PAPER_HEIGHT
)));
2873 #endif /* PAPER_WIDTH */
2874 #endif /* HAVE_LANGINFO_CODESET*/
2878 /* base64 encode/decode functions (RFC 2045).
2879 Based on code from GNU recode. */
2881 #define MIME_LINE_LENGTH 76
2883 #define IS_ASCII(Character) \
2885 #define IS_BASE64(Character) \
2886 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2887 #define IS_BASE64_IGNORABLE(Character) \
2888 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2889 || (Character) == '\f' || (Character) == '\r')
2891 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2892 character or return retval if there are no characters left to
2894 #define READ_QUADRUPLET_BYTE(retval) \
2899 if (nchars_return) \
2900 *nchars_return = nchars; \
2905 while (IS_BASE64_IGNORABLE (c))
2907 /* Table of characters coding the 64 values. */
2908 static const char base64_value_to_char
[64] =
2910 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2911 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2912 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2913 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2914 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2915 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2916 '8', '9', '+', '/' /* 60-63 */
2919 /* Table of base64 values for first 128 characters. */
2920 static const short base64_char_to_value
[128] =
2922 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2923 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2924 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2925 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2926 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2927 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2928 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2929 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2930 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2931 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2932 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2933 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2934 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2937 /* The following diagram shows the logical steps by which three octets
2938 get transformed into four base64 characters.
2940 .--------. .--------. .--------.
2941 |aaaaaabb| |bbbbcccc| |ccdddddd|
2942 `--------' `--------' `--------'
2944 .--------+--------+--------+--------.
2945 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2946 `--------+--------+--------+--------'
2948 .--------+--------+--------+--------.
2949 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2950 `--------+--------+--------+--------'
2952 The octets are divided into 6 bit chunks, which are then encoded into
2953 base64 characters. */
2956 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2957 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2960 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2962 doc
: /* Base64-encode the region between BEG and END.
2963 Return the length of the encoded text.
2964 Optional third argument NO-LINE-BREAK means do not break long lines
2965 into shorter lines. */)
2966 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2969 EMACS_INT allength
, length
;
2970 EMACS_INT ibeg
, iend
, encoded_length
;
2971 EMACS_INT old_pos
= PT
;
2974 validate_region (&beg
, &end
);
2976 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2977 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2978 move_gap_both (XFASTINT (beg
), ibeg
);
2980 /* We need to allocate enough room for encoding the text.
2981 We need 33 1/3% more space, plus a newline every 76
2982 characters, and then we round up. */
2983 length
= iend
- ibeg
;
2984 allength
= length
+ length
/3 + 1;
2985 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2987 SAFE_ALLOCA (encoded
, char *, allength
);
2988 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2989 encoded
, length
, NILP (no_line_break
),
2990 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2991 if (encoded_length
> allength
)
2994 if (encoded_length
< 0)
2996 /* The encoding wasn't possible. */
2998 error ("Multibyte character in data for base64 encoding");
3001 /* Now we have encoded the region, so we insert the new contents
3002 and delete the old. (Insert first in order to preserve markers.) */
3003 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3004 insert (encoded
, encoded_length
);
3006 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3008 /* If point was outside of the region, restore it exactly; else just
3009 move to the beginning of the region. */
3010 if (old_pos
>= XFASTINT (end
))
3011 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3012 else if (old_pos
> XFASTINT (beg
))
3013 old_pos
= XFASTINT (beg
);
3016 /* We return the length of the encoded text. */
3017 return make_number (encoded_length
);
3020 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3022 doc
: /* Base64-encode STRING and return the result.
3023 Optional second argument NO-LINE-BREAK means do not break long lines
3024 into shorter lines. */)
3025 (Lisp_Object string
, Lisp_Object no_line_break
)
3027 EMACS_INT allength
, length
, encoded_length
;
3029 Lisp_Object encoded_string
;
3032 CHECK_STRING (string
);
3034 /* We need to allocate enough room for encoding the text.
3035 We need 33 1/3% more space, plus a newline every 76
3036 characters, and then we round up. */
3037 length
= SBYTES (string
);
3038 allength
= length
+ length
/3 + 1;
3039 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3041 /* We need to allocate enough room for decoding the text. */
3042 SAFE_ALLOCA (encoded
, char *, allength
);
3044 encoded_length
= base64_encode_1 (SSDATA (string
),
3045 encoded
, length
, NILP (no_line_break
),
3046 STRING_MULTIBYTE (string
));
3047 if (encoded_length
> allength
)
3050 if (encoded_length
< 0)
3052 /* The encoding wasn't possible. */
3054 error ("Multibyte character in data for base64 encoding");
3057 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3060 return encoded_string
;
3064 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3065 int line_break
, int multibyte
)
3078 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3079 if (CHAR_BYTE8_P (c
))
3080 c
= CHAR_TO_BYTE8 (c
);
3088 /* Wrap line every 76 characters. */
3092 if (counter
< MIME_LINE_LENGTH
/ 4)
3101 /* Process first byte of a triplet. */
3103 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3104 value
= (0x03 & c
) << 4;
3106 /* Process second byte of a triplet. */
3110 *e
++ = base64_value_to_char
[value
];
3118 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3119 if (CHAR_BYTE8_P (c
))
3120 c
= CHAR_TO_BYTE8 (c
);
3128 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3129 value
= (0x0f & c
) << 2;
3131 /* Process third byte of a triplet. */
3135 *e
++ = base64_value_to_char
[value
];
3142 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3143 if (CHAR_BYTE8_P (c
))
3144 c
= CHAR_TO_BYTE8 (c
);
3152 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3153 *e
++ = base64_value_to_char
[0x3f & c
];
3160 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3162 doc
: /* Base64-decode the region between BEG and END.
3163 Return the length of the decoded text.
3164 If the region can't be decoded, signal an error and don't modify the buffer. */)
3165 (Lisp_Object beg
, Lisp_Object end
)
3167 EMACS_INT ibeg
, iend
, length
, allength
;
3169 EMACS_INT old_pos
= PT
;
3170 EMACS_INT decoded_length
;
3171 EMACS_INT inserted_chars
;
3172 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3175 validate_region (&beg
, &end
);
3177 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3178 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3180 length
= iend
- ibeg
;
3182 /* We need to allocate enough room for decoding the text. If we are
3183 working on a multibyte buffer, each decoded code may occupy at
3185 allength
= multibyte
? length
* 2 : length
;
3186 SAFE_ALLOCA (decoded
, char *, allength
);
3188 move_gap_both (XFASTINT (beg
), ibeg
);
3189 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3191 multibyte
, &inserted_chars
);
3192 if (decoded_length
> allength
)
3195 if (decoded_length
< 0)
3197 /* The decoding wasn't possible. */
3199 error ("Invalid base64 data");
3202 /* Now we have decoded the region, so we insert the new contents
3203 and delete the old. (Insert first in order to preserve markers.) */
3204 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3205 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3208 /* Delete the original text. */
3209 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3210 iend
+ decoded_length
, 1);
3212 /* If point was outside of the region, restore it exactly; else just
3213 move to the beginning of the region. */
3214 if (old_pos
>= XFASTINT (end
))
3215 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3216 else if (old_pos
> XFASTINT (beg
))
3217 old_pos
= XFASTINT (beg
);
3218 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3220 return make_number (inserted_chars
);
3223 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3225 doc
: /* Base64-decode STRING and return the result. */)
3226 (Lisp_Object string
)
3229 EMACS_INT length
, decoded_length
;
3230 Lisp_Object decoded_string
;
3233 CHECK_STRING (string
);
3235 length
= SBYTES (string
);
3236 /* We need to allocate enough room for decoding the text. */
3237 SAFE_ALLOCA (decoded
, char *, length
);
3239 /* The decoded result should be unibyte. */
3240 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3242 if (decoded_length
> length
)
3244 else if (decoded_length
>= 0)
3245 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3247 decoded_string
= Qnil
;
3250 if (!STRINGP (decoded_string
))
3251 error ("Invalid base64 data");
3253 return decoded_string
;
3256 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3257 MULTIBYTE is nonzero, the decoded result should be in multibyte
3258 form. If NCHARS_RETRUN is not NULL, store the number of produced
3259 characters in *NCHARS_RETURN. */
3262 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3263 int multibyte
, EMACS_INT
*nchars_return
)
3265 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3268 unsigned long value
;
3269 EMACS_INT nchars
= 0;
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 static struct Lisp_Hash_Table
*weak_hash_tables
;
3367 /* Various symbols. */
3369 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3370 Lisp_Object Qeq
, Qeql
, Qequal
;
3371 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3372 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3374 /* Function prototypes. */
3376 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3377 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3378 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3379 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3383 /***********************************************************************
3385 ***********************************************************************/
3387 /* If OBJ is a Lisp hash table, return a pointer to its struct
3388 Lisp_Hash_Table. Otherwise, signal an error. */
3390 static struct Lisp_Hash_Table
*
3391 check_hash_table (Lisp_Object obj
)
3393 CHECK_HASH_TABLE (obj
);
3394 return XHASH_TABLE (obj
);
3398 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3402 next_almost_prime (EMACS_INT n
)
3404 for (n
|= 1; ; n
+= 2)
3405 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3410 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3411 which USED[I] is non-zero. If found at index I in ARGS, set
3412 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3413 0. This function is used to extract a keyword/argument pair from
3414 a DEFUN parameter list. */
3417 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3421 for (i
= 1; i
< nargs
; i
++)
3422 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3433 /* Return a Lisp vector which has the same contents as VEC but has
3434 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3435 vector that are not copied from VEC are set to INIT. */
3438 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3440 struct Lisp_Vector
*v
;
3441 EMACS_INT i
, old_size
;
3443 xassert (VECTORP (vec
));
3444 old_size
= ASIZE (vec
);
3445 xassert (new_size
>= old_size
);
3447 v
= allocate_vector (new_size
);
3448 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3449 for (i
= old_size
; i
< new_size
; ++i
)
3450 v
->contents
[i
] = init
;
3451 XSETVECTOR (vec
, v
);
3456 /***********************************************************************
3458 ***********************************************************************/
3460 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3461 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3462 KEY2 are the same. */
3465 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3466 Lisp_Object key1
, EMACS_UINT hash1
,
3467 Lisp_Object key2
, EMACS_UINT hash2
)
3469 return (FLOATP (key1
)
3471 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3475 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3476 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3477 KEY2 are the same. */
3480 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3481 Lisp_Object key1
, EMACS_UINT hash1
,
3482 Lisp_Object key2
, EMACS_UINT hash2
)
3484 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3488 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3489 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3490 if KEY1 and KEY2 are the same. */
3493 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3494 Lisp_Object key1
, EMACS_UINT hash1
,
3495 Lisp_Object key2
, EMACS_UINT hash2
)
3499 Lisp_Object args
[3];
3501 args
[0] = h
->user_cmp_function
;
3504 return !NILP (Ffuncall (3, args
));
3511 /* Value is a hash code for KEY for use in hash table H which uses
3512 `eq' to compare keys. The hash code returned is guaranteed to fit
3513 in a Lisp integer. */
3516 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3518 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3519 xassert ((hash
& ~INTMASK
) == 0);
3524 /* Value is a hash code for KEY for use in hash table H which uses
3525 `eql' to compare keys. The hash code returned is guaranteed to fit
3526 in a Lisp integer. */
3529 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3533 hash
= sxhash (key
, 0);
3535 hash
= XUINT (key
) ^ XTYPE (key
);
3536 xassert ((hash
& ~INTMASK
) == 0);
3541 /* Value is a hash code for KEY for use in hash table H which uses
3542 `equal' to compare keys. The hash code returned is guaranteed to fit
3543 in a Lisp integer. */
3546 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3548 EMACS_UINT hash
= sxhash (key
, 0);
3549 xassert ((hash
& ~INTMASK
) == 0);
3554 /* Value is a hash code for KEY for use in hash table H which uses as
3555 user-defined function to compare keys. The hash code returned is
3556 guaranteed to fit in a Lisp integer. */
3559 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3561 Lisp_Object args
[2], hash
;
3563 args
[0] = h
->user_hash_function
;
3565 hash
= Ffuncall (2, args
);
3566 if (!INTEGERP (hash
))
3567 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3568 return XUINT (hash
);
3572 /* Create and initialize a new hash table.
3574 TEST specifies the test the hash table will use to compare keys.
3575 It must be either one of the predefined tests `eq', `eql' or
3576 `equal' or a symbol denoting a user-defined test named TEST with
3577 test and hash functions USER_TEST and USER_HASH.
3579 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3581 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3582 new size when it becomes full is computed by adding REHASH_SIZE to
3583 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3584 table's new size is computed by multiplying its old size with
3587 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3588 be resized when the ratio of (number of entries in the table) /
3589 (table size) is >= REHASH_THRESHOLD.
3591 WEAK specifies the weakness of the table. If non-nil, it must be
3592 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3595 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3596 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3597 Lisp_Object user_test
, Lisp_Object user_hash
)
3599 struct Lisp_Hash_Table
*h
;
3601 EMACS_INT index_size
, i
, sz
;
3604 /* Preconditions. */
3605 xassert (SYMBOLP (test
));
3606 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3607 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3608 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3609 xassert (FLOATP (rehash_threshold
)
3610 && 0 < XFLOAT_DATA (rehash_threshold
)
3611 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3613 if (XFASTINT (size
) == 0)
3614 size
= make_number (1);
3616 sz
= XFASTINT (size
);
3617 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3618 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3619 ? next_almost_prime (index_float
)
3620 : MOST_POSITIVE_FIXNUM
+ 1);
3621 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3622 error ("Hash table too large");
3624 /* Allocate a table and initialize it. */
3625 h
= allocate_hash_table ();
3627 /* Initialize hash table slots. */
3629 if (EQ (test
, Qeql
))
3631 h
->cmpfn
= cmpfn_eql
;
3632 h
->hashfn
= hashfn_eql
;
3634 else if (EQ (test
, Qeq
))
3637 h
->hashfn
= hashfn_eq
;
3639 else if (EQ (test
, Qequal
))
3641 h
->cmpfn
= cmpfn_equal
;
3642 h
->hashfn
= hashfn_equal
;
3646 h
->user_cmp_function
= user_test
;
3647 h
->user_hash_function
= user_hash
;
3648 h
->cmpfn
= cmpfn_user_defined
;
3649 h
->hashfn
= hashfn_user_defined
;
3653 h
->rehash_threshold
= rehash_threshold
;
3654 h
->rehash_size
= rehash_size
;
3656 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3657 h
->hash
= Fmake_vector (size
, Qnil
);
3658 h
->next
= Fmake_vector (size
, Qnil
);
3659 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3661 /* Set up the free list. */
3662 for (i
= 0; i
< sz
- 1; ++i
)
3663 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3664 h
->next_free
= make_number (0);
3666 XSET_HASH_TABLE (table
, h
);
3667 xassert (HASH_TABLE_P (table
));
3668 xassert (XHASH_TABLE (table
) == h
);
3670 /* Maybe add this hash table to the list of all weak hash tables. */
3672 h
->next_weak
= NULL
;
3675 h
->next_weak
= weak_hash_tables
;
3676 weak_hash_tables
= h
;
3683 /* Return a copy of hash table H1. Keys and values are not copied,
3684 only the table itself is. */
3687 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3690 struct Lisp_Hash_Table
*h2
;
3691 struct Lisp_Vector
*next
;
3693 h2
= allocate_hash_table ();
3694 next
= h2
->header
.next
.vector
;
3695 memcpy (h2
, h1
, sizeof *h2
);
3696 h2
->header
.next
.vector
= next
;
3697 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3698 h2
->hash
= Fcopy_sequence (h1
->hash
);
3699 h2
->next
= Fcopy_sequence (h1
->next
);
3700 h2
->index
= Fcopy_sequence (h1
->index
);
3701 XSET_HASH_TABLE (table
, h2
);
3703 /* Maybe add this hash table to the list of all weak hash tables. */
3704 if (!NILP (h2
->weak
))
3706 h2
->next_weak
= weak_hash_tables
;
3707 weak_hash_tables
= h2
;
3714 /* Resize hash table H if it's too full. If H cannot be resized
3715 because it's already too large, throw an error. */
3718 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3720 if (NILP (h
->next_free
))
3722 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3723 EMACS_INT i
, new_size
, index_size
;
3727 if (INTEGERP (h
->rehash_size
))
3728 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3731 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3732 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3734 new_size
= float_new_size
;
3735 if (new_size
<= old_size
)
3736 new_size
= old_size
+ 1;
3739 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3741 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3742 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3743 ? next_almost_prime (index_float
)
3744 : MOST_POSITIVE_FIXNUM
+ 1);
3745 nsize
= max (index_size
, 2 * new_size
);
3746 if (nsize
> MOST_POSITIVE_FIXNUM
)
3747 error ("Hash table too large to resize");
3749 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3750 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3751 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3752 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3754 /* Update the free list. Do it so that new entries are added at
3755 the end of the free list. This makes some operations like
3757 for (i
= old_size
; i
< new_size
- 1; ++i
)
3758 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3760 if (!NILP (h
->next_free
))
3762 Lisp_Object last
, next
;
3764 last
= h
->next_free
;
3765 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3769 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3772 XSETFASTINT (h
->next_free
, old_size
);
3775 for (i
= 0; i
< old_size
; ++i
)
3776 if (!NILP (HASH_HASH (h
, i
)))
3778 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3779 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3780 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3781 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3787 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3788 the hash code of KEY. Value is the index of the entry in H
3789 matching KEY, or -1 if not found. */
3792 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3794 EMACS_UINT hash_code
;
3795 EMACS_INT start_of_bucket
;
3798 hash_code
= h
->hashfn (h
, key
);
3802 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3803 idx
= HASH_INDEX (h
, start_of_bucket
);
3805 /* We need not gcpro idx since it's either an integer or nil. */
3808 EMACS_INT i
= XFASTINT (idx
);
3809 if (EQ (key
, HASH_KEY (h
, i
))
3811 && h
->cmpfn (h
, key
, hash_code
,
3812 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3814 idx
= HASH_NEXT (h
, i
);
3817 return NILP (idx
) ? -1 : XFASTINT (idx
);
3821 /* Put an entry into hash table H that associates KEY with VALUE.
3822 HASH is a previously computed hash code of KEY.
3823 Value is the index of the entry in H matching KEY. */
3826 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3829 EMACS_INT start_of_bucket
, i
;
3831 xassert ((hash
& ~INTMASK
) == 0);
3833 /* Increment count after resizing because resizing may fail. */
3834 maybe_resize_hash_table (h
);
3837 /* Store key/value in the key_and_value vector. */
3838 i
= XFASTINT (h
->next_free
);
3839 h
->next_free
= HASH_NEXT (h
, i
);
3840 HASH_KEY (h
, i
) = key
;
3841 HASH_VALUE (h
, i
) = value
;
3843 /* Remember its hash code. */
3844 HASH_HASH (h
, i
) = make_number (hash
);
3846 /* Add new entry to its collision chain. */
3847 start_of_bucket
= hash
% ASIZE (h
->index
);
3848 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3849 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3854 /* Remove the entry matching KEY from hash table H, if there is one. */
3857 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3859 EMACS_UINT hash_code
;
3860 EMACS_INT start_of_bucket
;
3861 Lisp_Object idx
, prev
;
3863 hash_code
= h
->hashfn (h
, key
);
3864 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3865 idx
= HASH_INDEX (h
, start_of_bucket
);
3868 /* We need not gcpro idx, prev since they're either integers or nil. */
3871 EMACS_INT i
= XFASTINT (idx
);
3873 if (EQ (key
, HASH_KEY (h
, i
))
3875 && h
->cmpfn (h
, key
, hash_code
,
3876 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3878 /* Take entry out of collision chain. */
3880 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3882 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3884 /* Clear slots in key_and_value and add the slots to
3886 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3887 HASH_NEXT (h
, i
) = h
->next_free
;
3888 h
->next_free
= make_number (i
);
3890 xassert (h
->count
>= 0);
3896 idx
= HASH_NEXT (h
, i
);
3902 /* Clear hash table H. */
3905 hash_clear (struct Lisp_Hash_Table
*h
)
3909 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3911 for (i
= 0; i
< size
; ++i
)
3913 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3914 HASH_KEY (h
, i
) = Qnil
;
3915 HASH_VALUE (h
, i
) = Qnil
;
3916 HASH_HASH (h
, i
) = Qnil
;
3919 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3920 ASET (h
->index
, i
, Qnil
);
3922 h
->next_free
= make_number (0);
3929 /************************************************************************
3931 ************************************************************************/
3934 init_weak_hash_tables (void)
3936 weak_hash_tables
= NULL
;
3939 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3940 entries from the table that don't survive the current GC.
3941 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3942 non-zero if anything was marked. */
3945 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3947 EMACS_INT bucket
, n
;
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 EMACS_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
->header
.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
->header
.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. The result might not fit
4092 into a Lisp integer. */
4094 #define SXHASH_COMBINE(X, Y) \
4095 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4098 /* Hash X, returning a value that fits into a Lisp integer. */
4099 #define SXHASH_REDUCE(X) \
4100 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4102 /* Return a hash for string PTR which has length LEN. The hash
4103 code returned is guaranteed to fit in a Lisp integer. */
4106 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4108 unsigned char *p
= ptr
;
4109 unsigned char *end
= p
+ len
;
4111 EMACS_UINT hash
= 0;
4118 hash
= SXHASH_COMBINE (hash
, c
);
4121 return SXHASH_REDUCE (hash
);
4124 /* Return a hash for the floating point value VAL. */
4127 sxhash_float (double val
)
4129 EMACS_UINT hash
= 0;
4131 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4132 + (sizeof val
% sizeof hash
!= 0))
4136 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4140 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4141 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4142 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4143 return SXHASH_REDUCE (hash
);
4146 /* Return a hash for list LIST. DEPTH is the current depth in the
4147 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4150 sxhash_list (Lisp_Object list
, int depth
)
4152 EMACS_UINT hash
= 0;
4155 if (depth
< SXHASH_MAX_DEPTH
)
4157 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4158 list
= XCDR (list
), ++i
)
4160 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4161 hash
= SXHASH_COMBINE (hash
, hash2
);
4166 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4167 hash
= SXHASH_COMBINE (hash
, hash2
);
4170 return SXHASH_REDUCE (hash
);
4174 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4175 the Lisp structure. */
4178 sxhash_vector (Lisp_Object vec
, int depth
)
4180 EMACS_UINT hash
= ASIZE (vec
);
4183 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4184 for (i
= 0; i
< n
; ++i
)
4186 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4187 hash
= SXHASH_COMBINE (hash
, hash2
);
4190 return SXHASH_REDUCE (hash
);
4193 /* Return a hash for bool-vector VECTOR. */
4196 sxhash_bool_vector (Lisp_Object vec
)
4198 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4201 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4202 for (i
= 0; i
< n
; ++i
)
4203 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4205 return SXHASH_REDUCE (hash
);
4209 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4210 structure. Value is an unsigned integer clipped to INTMASK. */
4213 sxhash (Lisp_Object obj
, int depth
)
4217 if (depth
> SXHASH_MAX_DEPTH
)
4220 switch (XTYPE (obj
))
4231 obj
= SYMBOL_NAME (obj
);
4235 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4238 /* This can be everything from a vector to an overlay. */
4239 case Lisp_Vectorlike
:
4241 /* According to the CL HyperSpec, two arrays are equal only if
4242 they are `eq', except for strings and bit-vectors. In
4243 Emacs, this works differently. We have to compare element
4245 hash
= sxhash_vector (obj
, depth
);
4246 else if (BOOL_VECTOR_P (obj
))
4247 hash
= sxhash_bool_vector (obj
);
4249 /* Others are `equal' if they are `eq', so let's take their
4255 hash
= sxhash_list (obj
, depth
);
4259 hash
= sxhash_float (XFLOAT_DATA (obj
));
4271 /***********************************************************************
4273 ***********************************************************************/
4276 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4277 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4280 EMACS_UINT hash
= sxhash (obj
, 0);
4281 return make_number (hash
);
4285 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4286 doc
: /* Create and return a new hash table.
4288 Arguments are specified as keyword/argument pairs. The following
4289 arguments are defined:
4291 :test TEST -- TEST must be a symbol that specifies how to compare
4292 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4293 `equal'. User-supplied test and hash functions can be specified via
4294 `define-hash-table-test'.
4296 :size SIZE -- A hint as to how many elements will be put in the table.
4299 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4300 fills up. If REHASH-SIZE is an integer, increase the size by that
4301 amount. If it is a float, it must be > 1.0, and the new size is the
4302 old size multiplied by that factor. Default is 1.5.
4304 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4305 Resize the hash table when the ratio (number of entries / table size)
4306 is greater than or equal to THRESHOLD. Default is 0.8.
4308 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4309 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4310 returned is a weak table. Key/value pairs are removed from a weak
4311 hash table when there are no non-weak references pointing to their
4312 key, value, one of key or value, or both key and value, depending on
4313 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4316 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4317 (ptrdiff_t nargs
, Lisp_Object
*args
)
4319 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4320 Lisp_Object user_test
, user_hash
;
4324 /* The vector `used' is used to keep track of arguments that
4325 have been consumed. */
4326 used
= (char *) alloca (nargs
* sizeof *used
);
4327 memset (used
, 0, nargs
* sizeof *used
);
4329 /* See if there's a `:test TEST' among the arguments. */
4330 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4331 test
= i
? args
[i
] : Qeql
;
4332 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4334 /* See if it is a user-defined test. */
4337 prop
= Fget (test
, Qhash_table_test
);
4338 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4339 signal_error ("Invalid hash table test", test
);
4340 user_test
= XCAR (prop
);
4341 user_hash
= XCAR (XCDR (prop
));
4344 user_test
= user_hash
= Qnil
;
4346 /* See if there's a `:size SIZE' argument. */
4347 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4348 size
= i
? args
[i
] : Qnil
;
4350 size
= make_number (DEFAULT_HASH_SIZE
);
4351 else if (!INTEGERP (size
) || XINT (size
) < 0)
4352 signal_error ("Invalid hash table size", size
);
4354 /* Look for `:rehash-size SIZE'. */
4355 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4356 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4357 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4358 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4359 signal_error ("Invalid hash table rehash size", rehash_size
);
4361 /* Look for `:rehash-threshold THRESHOLD'. */
4362 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4363 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4364 if (! (FLOATP (rehash_threshold
)
4365 && 0 < XFLOAT_DATA (rehash_threshold
)
4366 && XFLOAT_DATA (rehash_threshold
) <= 1))
4367 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4369 /* Look for `:weakness WEAK'. */
4370 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4371 weak
= i
? args
[i
] : Qnil
;
4373 weak
= Qkey_and_value
;
4376 && !EQ (weak
, Qvalue
)
4377 && !EQ (weak
, Qkey_or_value
)
4378 && !EQ (weak
, Qkey_and_value
))
4379 signal_error ("Invalid hash table weakness", weak
);
4381 /* Now, all args should have been used up, or there's a problem. */
4382 for (i
= 0; i
< nargs
; ++i
)
4384 signal_error ("Invalid argument list", args
[i
]);
4386 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4387 user_test
, user_hash
);
4391 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4392 doc
: /* Return a copy of hash table TABLE. */)
4395 return copy_hash_table (check_hash_table (table
));
4399 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4400 doc
: /* Return the number of elements in TABLE. */)
4403 return make_number (check_hash_table (table
)->count
);
4407 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4408 Shash_table_rehash_size
, 1, 1, 0,
4409 doc
: /* Return the current rehash size of TABLE. */)
4412 return check_hash_table (table
)->rehash_size
;
4416 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4417 Shash_table_rehash_threshold
, 1, 1, 0,
4418 doc
: /* Return the current rehash threshold of TABLE. */)
4421 return check_hash_table (table
)->rehash_threshold
;
4425 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4426 doc
: /* Return the size of TABLE.
4427 The size can be used as an argument to `make-hash-table' to create
4428 a hash table than can hold as many elements as TABLE holds
4429 without need for resizing. */)
4432 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4433 return make_number (HASH_TABLE_SIZE (h
));
4437 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4438 doc
: /* Return the test TABLE uses. */)
4441 return check_hash_table (table
)->test
;
4445 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4447 doc
: /* Return the weakness of TABLE. */)
4450 return check_hash_table (table
)->weak
;
4454 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4455 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4458 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4462 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4463 doc
: /* Clear hash table TABLE and return it. */)
4466 hash_clear (check_hash_table (table
));
4467 /* Be compatible with XEmacs. */
4472 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4473 doc
: /* Look up KEY in TABLE and return its associated value.
4474 If KEY is not found, return DFLT which defaults to nil. */)
4475 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4477 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4478 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4479 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4483 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4484 doc
: /* Associate KEY with VALUE in hash table TABLE.
4485 If KEY is already present in table, replace its current value with
4486 VALUE. In any case, return VALUE. */)
4487 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4489 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4493 i
= hash_lookup (h
, key
, &hash
);
4495 HASH_VALUE (h
, i
) = value
;
4497 hash_put (h
, key
, value
, hash
);
4503 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4504 doc
: /* Remove KEY from TABLE. */)
4505 (Lisp_Object key
, Lisp_Object table
)
4507 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4508 hash_remove_from_table (h
, key
);
4513 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4514 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4515 FUNCTION is called with two arguments, KEY and VALUE. */)
4516 (Lisp_Object function
, Lisp_Object table
)
4518 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4519 Lisp_Object args
[3];
4522 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4523 if (!NILP (HASH_HASH (h
, i
)))
4526 args
[1] = HASH_KEY (h
, i
);
4527 args
[2] = HASH_VALUE (h
, i
);
4535 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4536 Sdefine_hash_table_test
, 3, 3, 0,
4537 doc
: /* Define a new hash table test with name NAME, a symbol.
4539 In hash tables created with NAME specified as test, use TEST to
4540 compare keys, and HASH for computing hash codes of keys.
4542 TEST must be a function taking two arguments and returning non-nil if
4543 both arguments are the same. HASH must be a function taking one
4544 argument and return an integer that is the hash code of the argument.
4545 Hash code computation should use the whole value range of integers,
4546 including negative integers. */)
4547 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4549 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4554 /************************************************************************
4555 MD5, SHA-1, and SHA-2
4556 ************************************************************************/
4563 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4566 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4570 EMACS_INT size_byte
= 0;
4571 EMACS_INT start_char
= 0, end_char
= 0;
4572 EMACS_INT start_byte
= 0, end_byte
= 0;
4573 register EMACS_INT b
, e
;
4574 register struct buffer
*bp
;
4577 void *(*hash_func
) (const char *, size_t, void *);
4580 CHECK_SYMBOL (algorithm
);
4582 if (STRINGP (object
))
4584 if (NILP (coding_system
))
4586 /* Decide the coding-system to encode the data with. */
4588 if (STRING_MULTIBYTE (object
))
4589 /* use default, we can't guess correct value */
4590 coding_system
= preferred_coding_system ();
4592 coding_system
= Qraw_text
;
4595 if (NILP (Fcoding_system_p (coding_system
)))
4597 /* Invalid coding system. */
4599 if (!NILP (noerror
))
4600 coding_system
= Qraw_text
;
4602 xsignal1 (Qcoding_system_error
, coding_system
);
4605 if (STRING_MULTIBYTE (object
))
4606 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4608 size
= SCHARS (object
);
4609 size_byte
= SBYTES (object
);
4613 CHECK_NUMBER (start
);
4615 start_char
= XINT (start
);
4620 start_byte
= string_char_to_byte (object
, start_char
);
4626 end_byte
= size_byte
;
4632 end_char
= XINT (end
);
4637 end_byte
= string_char_to_byte (object
, end_char
);
4640 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4641 args_out_of_range_3 (object
, make_number (start_char
),
4642 make_number (end_char
));
4646 struct buffer
*prev
= current_buffer
;
4648 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4650 CHECK_BUFFER (object
);
4652 bp
= XBUFFER (object
);
4653 if (bp
!= current_buffer
)
4654 set_buffer_internal (bp
);
4660 CHECK_NUMBER_COERCE_MARKER (start
);
4668 CHECK_NUMBER_COERCE_MARKER (end
);
4673 temp
= b
, b
= e
, e
= temp
;
4675 if (!(BEGV
<= b
&& e
<= ZV
))
4676 args_out_of_range (start
, end
);
4678 if (NILP (coding_system
))
4680 /* Decide the coding-system to encode the data with.
4681 See fileio.c:Fwrite-region */
4683 if (!NILP (Vcoding_system_for_write
))
4684 coding_system
= Vcoding_system_for_write
;
4687 int force_raw_text
= 0;
4689 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4690 if (NILP (coding_system
)
4691 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4693 coding_system
= Qnil
;
4694 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4698 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4700 /* Check file-coding-system-alist. */
4701 Lisp_Object args
[4], val
;
4703 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4704 args
[3] = Fbuffer_file_name(object
);
4705 val
= Ffind_operation_coding_system (4, args
);
4706 if (CONSP (val
) && !NILP (XCDR (val
)))
4707 coding_system
= XCDR (val
);
4710 if (NILP (coding_system
)
4711 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4713 /* If we still have not decided a coding system, use the
4714 default value of buffer-file-coding-system. */
4715 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4719 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4720 /* Confirm that VAL can surely encode the current region. */
4721 coding_system
= call4 (Vselect_safe_coding_system_function
,
4722 make_number (b
), make_number (e
),
4723 coding_system
, Qnil
);
4726 coding_system
= Qraw_text
;
4729 if (NILP (Fcoding_system_p (coding_system
)))
4731 /* Invalid coding system. */
4733 if (!NILP (noerror
))
4734 coding_system
= Qraw_text
;
4736 xsignal1 (Qcoding_system_error
, coding_system
);
4740 object
= make_buffer_string (b
, e
, 0);
4741 if (prev
!= current_buffer
)
4742 set_buffer_internal (prev
);
4743 /* Discard the unwind protect for recovering the current
4747 if (STRING_MULTIBYTE (object
))
4748 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4751 if (EQ (algorithm
, Qmd5
))
4753 digest_size
= MD5_DIGEST_SIZE
;
4754 hash_func
= md5_buffer
;
4756 else if (EQ (algorithm
, Qsha1
))
4758 digest_size
= SHA1_DIGEST_SIZE
;
4759 hash_func
= sha1_buffer
;
4761 else if (EQ (algorithm
, Qsha224
))
4763 digest_size
= SHA224_DIGEST_SIZE
;
4764 hash_func
= sha224_buffer
;
4766 else if (EQ (algorithm
, Qsha256
))
4768 digest_size
= SHA256_DIGEST_SIZE
;
4769 hash_func
= sha256_buffer
;
4771 else if (EQ (algorithm
, Qsha384
))
4773 digest_size
= SHA384_DIGEST_SIZE
;
4774 hash_func
= sha384_buffer
;
4776 else if (EQ (algorithm
, Qsha512
))
4778 digest_size
= SHA512_DIGEST_SIZE
;
4779 hash_func
= sha512_buffer
;
4782 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4784 /* allocate 2 x digest_size so that it can be re-used to hold the
4786 digest
= make_uninit_string (digest_size
* 2);
4788 hash_func (SSDATA (object
) + start_byte
,
4789 SBYTES (object
) - (size_byte
- end_byte
),
4794 unsigned char *p
= SDATA (digest
);
4795 for (i
= digest_size
- 1; i
>= 0; i
--)
4797 static char const hexdigit
[16] = "0123456789abcdef";
4799 p
[2 * i
] = hexdigit
[p_i
>> 4];
4800 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4805 return make_unibyte_string (SDATA (digest
), digest_size
);
4808 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4809 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4811 A message digest is a cryptographic checksum of a document, and the
4812 algorithm to calculate it is defined in RFC 1321.
4814 The two optional arguments START and END are character positions
4815 specifying for which part of OBJECT the message digest should be
4816 computed. If nil or omitted, the digest is computed for the whole
4819 The MD5 message digest is computed from the result of encoding the
4820 text in a coding system, not directly from the internal Emacs form of
4821 the text. The optional fourth argument CODING-SYSTEM specifies which
4822 coding system to encode the text with. It should be the same coding
4823 system that you used or will use when actually writing the text into a
4826 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4827 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4828 system would be chosen by default for writing this text into a file.
4830 If OBJECT is a string, the most preferred coding system (see the
4831 command `prefer-coding-system') is used.
4833 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4834 guesswork fails. Normally, an error is signaled in such case. */)
4835 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4837 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4840 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4841 doc
: /* Return the secure hash of an OBJECT.
4842 ALGORITHM is a symbol: md5, sha1, sha224, sha256, sha384 or sha512.
4843 OBJECT is either a string or a buffer.
4844 Optional arguments START and END are character positions specifying
4845 which portion of OBJECT for computing the hash. If BINARY is non-nil,
4846 return a string in binary form. */)
4847 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4849 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4855 DEFSYM (Qmd5
, "md5");
4856 DEFSYM (Qsha1
, "sha1");
4857 DEFSYM (Qsha224
, "sha224");
4858 DEFSYM (Qsha256
, "sha256");
4859 DEFSYM (Qsha384
, "sha384");
4860 DEFSYM (Qsha512
, "sha512");
4862 /* Hash table stuff. */
4863 Qhash_table_p
= intern_c_string ("hash-table-p");
4864 staticpro (&Qhash_table_p
);
4865 Qeq
= intern_c_string ("eq");
4867 Qeql
= intern_c_string ("eql");
4869 Qequal
= intern_c_string ("equal");
4870 staticpro (&Qequal
);
4871 QCtest
= intern_c_string (":test");
4872 staticpro (&QCtest
);
4873 QCsize
= intern_c_string (":size");
4874 staticpro (&QCsize
);
4875 QCrehash_size
= intern_c_string (":rehash-size");
4876 staticpro (&QCrehash_size
);
4877 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4878 staticpro (&QCrehash_threshold
);
4879 QCweakness
= intern_c_string (":weakness");
4880 staticpro (&QCweakness
);
4881 Qkey
= intern_c_string ("key");
4883 Qvalue
= intern_c_string ("value");
4884 staticpro (&Qvalue
);
4885 Qhash_table_test
= intern_c_string ("hash-table-test");
4886 staticpro (&Qhash_table_test
);
4887 Qkey_or_value
= intern_c_string ("key-or-value");
4888 staticpro (&Qkey_or_value
);
4889 Qkey_and_value
= intern_c_string ("key-and-value");
4890 staticpro (&Qkey_and_value
);
4893 defsubr (&Smake_hash_table
);
4894 defsubr (&Scopy_hash_table
);
4895 defsubr (&Shash_table_count
);
4896 defsubr (&Shash_table_rehash_size
);
4897 defsubr (&Shash_table_rehash_threshold
);
4898 defsubr (&Shash_table_size
);
4899 defsubr (&Shash_table_test
);
4900 defsubr (&Shash_table_weakness
);
4901 defsubr (&Shash_table_p
);
4902 defsubr (&Sclrhash
);
4903 defsubr (&Sgethash
);
4904 defsubr (&Sputhash
);
4905 defsubr (&Sremhash
);
4906 defsubr (&Smaphash
);
4907 defsubr (&Sdefine_hash_table_test
);
4909 Qstring_lessp
= intern_c_string ("string-lessp");
4910 staticpro (&Qstring_lessp
);
4911 Qprovide
= intern_c_string ("provide");
4912 staticpro (&Qprovide
);
4913 Qrequire
= intern_c_string ("require");
4914 staticpro (&Qrequire
);
4915 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4916 staticpro (&Qyes_or_no_p_history
);
4917 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4918 staticpro (&Qcursor_in_echo_area
);
4919 Qwidget_type
= intern_c_string ("widget-type");
4920 staticpro (&Qwidget_type
);
4922 staticpro (&string_char_byte_cache_string
);
4923 string_char_byte_cache_string
= Qnil
;
4925 require_nesting_list
= Qnil
;
4926 staticpro (&require_nesting_list
);
4928 Fset (Qyes_or_no_p_history
, Qnil
);
4930 DEFVAR_LISP ("features", Vfeatures
,
4931 doc
: /* A list of symbols which are the features of the executing Emacs.
4932 Used by `featurep' and `require', and altered by `provide'. */);
4933 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4934 Qsubfeatures
= intern_c_string ("subfeatures");
4935 staticpro (&Qsubfeatures
);
4937 #ifdef HAVE_LANGINFO_CODESET
4938 Qcodeset
= intern_c_string ("codeset");
4939 staticpro (&Qcodeset
);
4940 Qdays
= intern_c_string ("days");
4942 Qmonths
= intern_c_string ("months");
4943 staticpro (&Qmonths
);
4944 Qpaper
= intern_c_string ("paper");
4945 staticpro (&Qpaper
);
4946 #endif /* HAVE_LANGINFO_CODESET */
4948 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4949 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4950 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4951 invoked by mouse clicks and mouse menu items.
4953 On some platforms, file selection dialogs are also enabled if this is
4957 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4958 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4959 This applies to commands from menus and tool bar buttons even when
4960 they are initiated from the keyboard. If `use-dialog-box' is nil,
4961 that disables the use of a file dialog, regardless of the value of
4963 use_file_dialog
= 1;
4965 defsubr (&Sidentity
);
4968 defsubr (&Ssafe_length
);
4969 defsubr (&Sstring_bytes
);
4970 defsubr (&Sstring_equal
);
4971 defsubr (&Scompare_strings
);
4972 defsubr (&Sstring_lessp
);
4975 defsubr (&Svconcat
);
4976 defsubr (&Scopy_sequence
);
4977 defsubr (&Sstring_make_multibyte
);
4978 defsubr (&Sstring_make_unibyte
);
4979 defsubr (&Sstring_as_multibyte
);
4980 defsubr (&Sstring_as_unibyte
);
4981 defsubr (&Sstring_to_multibyte
);
4982 defsubr (&Sstring_to_unibyte
);
4983 defsubr (&Scopy_alist
);
4984 defsubr (&Ssubstring
);
4985 defsubr (&Ssubstring_no_properties
);
4998 defsubr (&Snreverse
);
4999 defsubr (&Sreverse
);
5001 defsubr (&Splist_get
);
5003 defsubr (&Splist_put
);
5005 defsubr (&Slax_plist_get
);
5006 defsubr (&Slax_plist_put
);
5009 defsubr (&Sequal_including_properties
);
5010 defsubr (&Sfillarray
);
5011 defsubr (&Sclear_string
);
5015 defsubr (&Smapconcat
);
5016 defsubr (&Syes_or_no_p
);
5017 defsubr (&Sload_average
);
5018 defsubr (&Sfeaturep
);
5019 defsubr (&Srequire
);
5020 defsubr (&Sprovide
);
5021 defsubr (&Splist_member
);
5022 defsubr (&Swidget_put
);
5023 defsubr (&Swidget_get
);
5024 defsubr (&Swidget_apply
);
5025 defsubr (&Sbase64_encode_region
);
5026 defsubr (&Sbase64_decode_region
);
5027 defsubr (&Sbase64_encode_string
);
5028 defsubr (&Sbase64_decode_string
);
5030 defsubr (&Ssecure_hash
);
5031 defsubr (&Slocale_info
);