1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
43 Lisp_Object Qstring_lessp
;
44 static Lisp_Object Qprovide
, Qrequire
;
45 static Lisp_Object Qyes_or_no_p_history
;
46 Lisp_Object Qcursor_in_echo_area
;
47 static Lisp_Object Qwidget_type
;
48 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
50 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
52 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
54 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
55 doc
: /* Return the argument unchanged. */)
61 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
62 doc
: /* Return a pseudo-random number.
63 All integers representable in Lisp, i.e. between `most-negative-fixnum'
64 and `most-positive-fixnum', inclusive, are equally likely.
66 With positive integer LIMIT, return random number in interval [0,LIMIT).
67 With argument t, set the random number seed from the current time and pid.
68 With a string argument, set the seed based on the string's contents.
69 Other values of LIMIT are ignored.
71 See Info node `(elisp)Random Numbers' for more details. */)
78 else if (STRINGP (limit
))
79 seed_random (SSDATA (limit
), SBYTES (limit
));
82 if (INTEGERP (limit
) && 0 < XINT (limit
))
85 /* Return the remainder, except reject the rare case where
86 get_random returns a number so close to INTMASK that the
87 remainder isn't random. */
88 EMACS_INT remainder
= val
% XINT (limit
);
89 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
90 return make_number (remainder
);
93 return make_number (val
);
96 /* Heuristic on how many iterations of a tight loop can be safely done
97 before it's time to do a QUIT. This must be a power of 2. */
98 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
100 /* Random data-structure functions. */
103 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
105 CHECK_TYPE (NILP (x
), Qlistp
, y
);
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
118 if (STRINGP (sequence
))
119 XSETFASTINT (val
, SCHARS (sequence
));
120 else if (VECTORP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
));
122 else if (CHAR_TABLE_P (sequence
))
123 XSETFASTINT (val
, MAX_CHAR
);
124 else if (BOOL_VECTOR_P (sequence
))
125 XSETFASTINT (val
, bool_vector_size (sequence
));
126 else if (COMPILEDP (sequence
))
127 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
128 else if (CONSP (sequence
))
135 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
137 if (MOST_POSITIVE_FIXNUM
< i
)
138 error ("List too long");
141 sequence
= XCDR (sequence
);
143 while (CONSP (sequence
));
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
158 doc
: /* Return the length of a list, but avoid error or infinite loop.
159 This function never gets an error. If LIST is not really a list,
160 it returns 0. If LIST is circular, it returns a finite value
161 which is at least the number of distinct elements. */)
164 Lisp_Object tail
, halftail
;
169 return make_number (0);
171 /* halftail is used to detect circular lists. */
172 for (tail
= halftail
= list
; ; )
177 if (EQ (tail
, halftail
))
180 if ((lolen
& 1) == 0)
182 halftail
= XCDR (halftail
);
183 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
187 hilen
+= UINTMAX_MAX
+ 1.0;
192 /* If the length does not fit into a fixnum, return a float.
193 On all known practical machines this returns an upper bound on
195 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 doc
: /* Return the number of bytes in STRING.
200 If STRING is multibyte, this may be greater than the length of STRING. */)
203 CHECK_STRING (string
);
204 return make_number (SBYTES (string
));
207 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
208 doc
: /* Return t if two strings have identical contents.
209 Case is significant, but text properties are ignored.
210 Symbols are also allowed; their print names are used instead. */)
211 (register Lisp_Object s1
, Lisp_Object s2
)
214 s1
= SYMBOL_NAME (s1
);
216 s2
= SYMBOL_NAME (s2
);
220 if (SCHARS (s1
) != SCHARS (s2
)
221 || SBYTES (s1
) != SBYTES (s2
)
222 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
227 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
228 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
229 The arguments START1, END1, START2, and END2, if non-nil, are
230 positions specifying which parts of STR1 or STR2 to compare. In
231 string STR1, compare the part between START1 (inclusive) and END1
232 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
233 the string; if END1 is nil, it defaults to the length of the string.
234 Likewise, in string STR2, compare the part between START2 and END2.
235 Like in `substring', negative values are counted from the end.
237 The strings are compared by the numeric values of their characters.
238 For instance, STR1 is "less than" STR2 if its first differing
239 character has a smaller numeric value. If IGNORE-CASE is non-nil,
240 characters are converted to lower-case before comparing them. Unibyte
241 strings are converted to multibyte for comparison.
243 The value is t if the strings (or specified portions) match.
244 If string STR1 is less, the value is a negative number N;
245 - 1 - N is the number of characters that match at the beginning.
246 If string STR1 is greater, the value is a positive number N;
247 N - 1 is the number of characters that match at the beginning. */)
248 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
249 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
251 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
256 /* For backward compatibility, silently bring too-large positive end
257 values into range. */
258 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
259 end1
= make_number (SCHARS (str1
));
260 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
261 end2
= make_number (SCHARS (str2
));
263 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
264 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
269 i1_byte
= string_char_to_byte (str1
, i1
);
270 i2_byte
= string_char_to_byte (str2
, i2
);
272 while (i1
< to1
&& i2
< to2
)
274 /* When we find a mismatch, we must compare the
275 characters, not just the bytes. */
278 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
279 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
284 if (! NILP (ignore_case
))
286 c1
= XINT (Fupcase (make_number (c1
)));
287 c2
= XINT (Fupcase (make_number (c2
)));
293 /* Note that I1 has already been incremented
294 past the character that we are comparing;
295 hence we don't add or subtract 1 here. */
297 return make_number (- i1
+ from1
);
299 return make_number (i1
- from1
);
303 return make_number (i1
- from1
+ 1);
305 return make_number (- i1
+ from1
- 1);
310 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
311 doc
: /* Return t if first arg string is less than second in lexicographic order.
313 Symbols are also allowed; their print names are used instead. */)
314 (register Lisp_Object s1
, Lisp_Object s2
)
316 register ptrdiff_t end
;
317 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
320 s1
= SYMBOL_NAME (s1
);
322 s2
= SYMBOL_NAME (s2
);
326 i1
= i1_byte
= i2
= i2_byte
= 0;
329 if (end
> SCHARS (s2
))
334 /* When we find a mismatch, we must compare the
335 characters, not just the bytes. */
338 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
339 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
342 return c1
< c2
? Qt
: Qnil
;
344 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
347 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
348 enum Lisp_Type target_type
, bool last_special
);
352 concat2 (Lisp_Object s1
, Lisp_Object s2
)
357 return concat (2, args
, Lisp_String
, 0);
362 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
368 return concat (3, args
, Lisp_String
, 0);
371 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
372 doc
: /* Concatenate all the arguments and make the result a list.
373 The result is a list whose elements are the elements of all the arguments.
374 Each argument may be a list, vector or string.
375 The last argument is not copied, just used as the tail of the new list.
376 usage: (append &rest SEQUENCES) */)
377 (ptrdiff_t nargs
, Lisp_Object
*args
)
379 return concat (nargs
, args
, Lisp_Cons
, 1);
382 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
383 doc
: /* Concatenate all the arguments and make the result a string.
384 The result is a string whose elements are the elements of all the arguments.
385 Each argument may be a string or a list or vector of characters (integers).
386 usage: (concat &rest SEQUENCES) */)
387 (ptrdiff_t nargs
, Lisp_Object
*args
)
389 return concat (nargs
, args
, Lisp_String
, 0);
392 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
393 doc
: /* Concatenate all the arguments and make the result a vector.
394 The result is a vector whose elements are the elements of all the arguments.
395 Each argument may be a list, vector or string.
396 usage: (vconcat &rest SEQUENCES) */)
397 (ptrdiff_t nargs
, Lisp_Object
*args
)
399 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
403 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
404 doc
: /* Return a copy of a list, vector, string or char-table.
405 The elements of a list or vector are not copied; they are shared
406 with the original. */)
409 if (NILP (arg
)) return arg
;
411 if (CHAR_TABLE_P (arg
))
413 return copy_char_table (arg
);
416 if (BOOL_VECTOR_P (arg
))
418 EMACS_INT nbits
= bool_vector_size (arg
);
419 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
420 Lisp_Object val
= make_uninit_bool_vector (nbits
);
421 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
425 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
426 wrong_type_argument (Qsequencep
, arg
);
428 return concat (1, &arg
, XTYPE (arg
), 0);
431 /* This structure holds information of an argument of `concat' that is
432 a string and has text properties to be copied. */
435 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
436 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
437 ptrdiff_t to
; /* refer to VAL (the target string) */
441 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
442 enum Lisp_Type target_type
, bool last_special
)
448 ptrdiff_t toindex_byte
= 0;
449 EMACS_INT result_len
;
450 EMACS_INT result_len_byte
;
452 Lisp_Object last_tail
;
455 /* When we make a multibyte string, we can't copy text properties
456 while concatenating each string because the length of resulting
457 string can't be decided until we finish the whole concatenation.
458 So, we record strings that have text properties to be copied
459 here, and copy the text properties after the concatenation. */
460 struct textprop_rec
*textprops
= NULL
;
461 /* Number of elements in textprops. */
462 ptrdiff_t num_textprops
= 0;
467 /* In append, the last arg isn't treated like the others */
468 if (last_special
&& nargs
> 0)
471 last_tail
= args
[nargs
];
476 /* Check each argument. */
477 for (argnum
= 0; argnum
< nargs
; argnum
++)
480 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
481 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
482 wrong_type_argument (Qsequencep
, this);
485 /* Compute total length in chars of arguments in RESULT_LEN.
486 If desired output is a string, also compute length in bytes
487 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
488 whether the result should be a multibyte string. */
492 for (argnum
= 0; argnum
< nargs
; argnum
++)
496 len
= XFASTINT (Flength (this));
497 if (target_type
== Lisp_String
)
499 /* We must count the number of bytes needed in the string
500 as well as the number of characters. */
504 ptrdiff_t this_len_byte
;
506 if (VECTORP (this) || COMPILEDP (this))
507 for (i
= 0; i
< len
; i
++)
510 CHECK_CHARACTER (ch
);
512 this_len_byte
= CHAR_BYTES (c
);
513 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
515 result_len_byte
+= this_len_byte
;
516 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
519 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
520 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
521 else if (CONSP (this))
522 for (; CONSP (this); this = XCDR (this))
525 CHECK_CHARACTER (ch
);
527 this_len_byte
= CHAR_BYTES (c
);
528 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
530 result_len_byte
+= this_len_byte
;
531 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
534 else if (STRINGP (this))
536 if (STRING_MULTIBYTE (this))
539 this_len_byte
= SBYTES (this);
542 this_len_byte
= count_size_as_multibyte (SDATA (this),
544 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
546 result_len_byte
+= this_len_byte
;
551 if (MOST_POSITIVE_FIXNUM
< result_len
)
552 memory_full (SIZE_MAX
);
555 if (! some_multibyte
)
556 result_len_byte
= result_len
;
558 /* Create the output object. */
559 if (target_type
== Lisp_Cons
)
560 val
= Fmake_list (make_number (result_len
), Qnil
);
561 else if (target_type
== Lisp_Vectorlike
)
562 val
= Fmake_vector (make_number (result_len
), Qnil
);
563 else if (some_multibyte
)
564 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
566 val
= make_uninit_string (result_len
);
568 /* In `append', if all but last arg are nil, return last arg. */
569 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
572 /* Copy the contents of the args into the result. */
574 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
576 toindex
= 0, toindex_byte
= 0;
580 SAFE_NALLOCA (textprops
, 1, nargs
);
582 for (argnum
= 0; argnum
< nargs
; argnum
++)
585 ptrdiff_t thisleni
= 0;
586 register ptrdiff_t thisindex
= 0;
587 register ptrdiff_t thisindex_byte
= 0;
591 thislen
= Flength (this), thisleni
= XINT (thislen
);
593 /* Between strings of the same kind, copy fast. */
594 if (STRINGP (this) && STRINGP (val
)
595 && STRING_MULTIBYTE (this) == some_multibyte
)
597 ptrdiff_t thislen_byte
= SBYTES (this);
599 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
600 if (string_intervals (this))
602 textprops
[num_textprops
].argnum
= argnum
;
603 textprops
[num_textprops
].from
= 0;
604 textprops
[num_textprops
++].to
= toindex
;
606 toindex_byte
+= thislen_byte
;
609 /* Copy a single-byte string to a multibyte string. */
610 else if (STRINGP (this) && STRINGP (val
))
612 if (string_intervals (this))
614 textprops
[num_textprops
].argnum
= argnum
;
615 textprops
[num_textprops
].from
= 0;
616 textprops
[num_textprops
++].to
= toindex
;
618 toindex_byte
+= copy_text (SDATA (this),
619 SDATA (val
) + toindex_byte
,
620 SCHARS (this), 0, 1);
624 /* Copy element by element. */
627 register Lisp_Object elt
;
629 /* Fetch next element of `this' arg into `elt', or break if
630 `this' is exhausted. */
631 if (NILP (this)) break;
633 elt
= XCAR (this), this = XCDR (this);
634 else if (thisindex
>= thisleni
)
636 else if (STRINGP (this))
639 if (STRING_MULTIBYTE (this))
640 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
645 c
= SREF (this, thisindex
); thisindex
++;
646 if (some_multibyte
&& !ASCII_CHAR_P (c
))
647 c
= BYTE8_TO_CHAR (c
);
649 XSETFASTINT (elt
, c
);
651 else if (BOOL_VECTOR_P (this))
653 elt
= bool_vector_ref (this, thisindex
);
658 elt
= AREF (this, thisindex
);
662 /* Store this element into the result. */
669 else if (VECTORP (val
))
671 ASET (val
, toindex
, elt
);
677 CHECK_CHARACTER (elt
);
680 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
682 SSET (val
, toindex_byte
++, c
);
688 XSETCDR (prev
, last_tail
);
690 if (num_textprops
> 0)
693 ptrdiff_t last_to_end
= -1;
695 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
697 this = args
[textprops
[argnum
].argnum
];
698 props
= text_property_list (this,
700 make_number (SCHARS (this)),
702 /* If successive arguments have properties, be sure that the
703 value of `composition' property be the copy. */
704 if (last_to_end
== textprops
[argnum
].to
)
705 make_composition_value_copy (props
);
706 add_text_properties_from_list (val
, props
,
707 make_number (textprops
[argnum
].to
));
708 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
716 static Lisp_Object string_char_byte_cache_string
;
717 static ptrdiff_t string_char_byte_cache_charpos
;
718 static ptrdiff_t string_char_byte_cache_bytepos
;
721 clear_string_char_byte_cache (void)
723 string_char_byte_cache_string
= Qnil
;
726 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
729 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
732 ptrdiff_t best_below
, best_below_byte
;
733 ptrdiff_t best_above
, best_above_byte
;
735 best_below
= best_below_byte
= 0;
736 best_above
= SCHARS (string
);
737 best_above_byte
= SBYTES (string
);
738 if (best_above
== best_above_byte
)
741 if (EQ (string
, string_char_byte_cache_string
))
743 if (string_char_byte_cache_charpos
< char_index
)
745 best_below
= string_char_byte_cache_charpos
;
746 best_below_byte
= string_char_byte_cache_bytepos
;
750 best_above
= string_char_byte_cache_charpos
;
751 best_above_byte
= string_char_byte_cache_bytepos
;
755 if (char_index
- best_below
< best_above
- char_index
)
757 unsigned char *p
= SDATA (string
) + best_below_byte
;
759 while (best_below
< char_index
)
761 p
+= BYTES_BY_CHAR_HEAD (*p
);
764 i_byte
= p
- SDATA (string
);
768 unsigned char *p
= SDATA (string
) + best_above_byte
;
770 while (best_above
> char_index
)
773 while (!CHAR_HEAD_P (*p
)) p
--;
776 i_byte
= p
- SDATA (string
);
779 string_char_byte_cache_bytepos
= i_byte
;
780 string_char_byte_cache_charpos
= char_index
;
781 string_char_byte_cache_string
= string
;
786 /* Return the character index corresponding to BYTE_INDEX in STRING. */
789 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
792 ptrdiff_t best_below
, best_below_byte
;
793 ptrdiff_t best_above
, best_above_byte
;
795 best_below
= best_below_byte
= 0;
796 best_above
= SCHARS (string
);
797 best_above_byte
= SBYTES (string
);
798 if (best_above
== best_above_byte
)
801 if (EQ (string
, string_char_byte_cache_string
))
803 if (string_char_byte_cache_bytepos
< byte_index
)
805 best_below
= string_char_byte_cache_charpos
;
806 best_below_byte
= string_char_byte_cache_bytepos
;
810 best_above
= string_char_byte_cache_charpos
;
811 best_above_byte
= string_char_byte_cache_bytepos
;
815 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
817 unsigned char *p
= SDATA (string
) + best_below_byte
;
818 unsigned char *pend
= SDATA (string
) + byte_index
;
822 p
+= BYTES_BY_CHAR_HEAD (*p
);
826 i_byte
= p
- SDATA (string
);
830 unsigned char *p
= SDATA (string
) + best_above_byte
;
831 unsigned char *pbeg
= SDATA (string
) + byte_index
;
836 while (!CHAR_HEAD_P (*p
)) p
--;
840 i_byte
= p
- SDATA (string
);
843 string_char_byte_cache_bytepos
= i_byte
;
844 string_char_byte_cache_charpos
= i
;
845 string_char_byte_cache_string
= string
;
850 /* Convert STRING to a multibyte string. */
853 string_make_multibyte (Lisp_Object string
)
860 if (STRING_MULTIBYTE (string
))
863 nbytes
= count_size_as_multibyte (SDATA (string
),
865 /* If all the chars are ASCII, they won't need any more bytes
866 once converted. In that case, we can return STRING itself. */
867 if (nbytes
== SBYTES (string
))
870 buf
= SAFE_ALLOCA (nbytes
);
871 copy_text (SDATA (string
), buf
, SBYTES (string
),
874 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
881 /* Convert STRING (if unibyte) to a multibyte string without changing
882 the number of characters. Characters 0200 trough 0237 are
883 converted to eight-bit characters. */
886 string_to_multibyte (Lisp_Object string
)
893 if (STRING_MULTIBYTE (string
))
896 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
897 /* If all the chars are ASCII, they won't need any more bytes once
899 if (nbytes
== SBYTES (string
))
900 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
902 buf
= SAFE_ALLOCA (nbytes
);
903 memcpy (buf
, SDATA (string
), SBYTES (string
));
904 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
906 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
913 /* Convert STRING to a single-byte string. */
916 string_make_unibyte (Lisp_Object string
)
923 if (! STRING_MULTIBYTE (string
))
926 nchars
= SCHARS (string
);
928 buf
= SAFE_ALLOCA (nchars
);
929 copy_text (SDATA (string
), buf
, SBYTES (string
),
932 ret
= make_unibyte_string ((char *) buf
, nchars
);
938 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
940 doc
: /* Return the multibyte equivalent of STRING.
941 If STRING is unibyte and contains non-ASCII characters, the function
942 `unibyte-char-to-multibyte' is used to convert each unibyte character
943 to a multibyte character. In this case, the returned string is a
944 newly created string with no text properties. If STRING is multibyte
945 or entirely ASCII, it is returned unchanged. In particular, when
946 STRING is unibyte and entirely ASCII, the returned string is unibyte.
947 \(When the characters are all ASCII, Emacs primitives will treat the
948 string the same way whether it is unibyte or multibyte.) */)
951 CHECK_STRING (string
);
953 return string_make_multibyte (string
);
956 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
958 doc
: /* Return the unibyte equivalent of STRING.
959 Multibyte character codes are converted to unibyte according to
960 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
961 If the lookup in the translation table fails, this function takes just
962 the low 8 bits of each character. */)
965 CHECK_STRING (string
);
967 return string_make_unibyte (string
);
970 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
972 doc
: /* Return a unibyte string with the same individual bytes as STRING.
973 If STRING is unibyte, the result is STRING itself.
974 Otherwise it is a newly created string, with no text properties.
975 If STRING is multibyte and contains a character of charset
976 `eight-bit', it is converted to the corresponding single byte. */)
979 CHECK_STRING (string
);
981 if (STRING_MULTIBYTE (string
))
983 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
984 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
986 string
= make_unibyte_string ((char *) str
, bytes
);
992 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
994 doc
: /* Return a multibyte string with the same individual bytes as STRING.
995 If STRING is multibyte, the result is STRING itself.
996 Otherwise it is a newly created string, with no text properties.
998 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
999 part of a correct utf-8 sequence), it is converted to the corresponding
1000 multibyte character of charset `eight-bit'.
1001 See also `string-to-multibyte'.
1003 Beware, this often doesn't really do what you think it does.
1004 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1005 If you're not sure, whether to use `string-as-multibyte' or
1006 `string-to-multibyte', use `string-to-multibyte'. */)
1007 (Lisp_Object string
)
1009 CHECK_STRING (string
);
1011 if (! STRING_MULTIBYTE (string
))
1013 Lisp_Object new_string
;
1014 ptrdiff_t nchars
, nbytes
;
1016 parse_str_as_multibyte (SDATA (string
),
1019 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1020 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1021 if (nbytes
!= SBYTES (string
))
1022 str_as_multibyte (SDATA (new_string
), nbytes
,
1023 SBYTES (string
), NULL
);
1024 string
= new_string
;
1025 set_string_intervals (string
, NULL
);
1030 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1032 doc
: /* Return a multibyte string with the same individual chars as STRING.
1033 If STRING is multibyte, the result is STRING itself.
1034 Otherwise it is a newly created string, with no text properties.
1036 If STRING is unibyte and contains an 8-bit byte, it is converted to
1037 the corresponding multibyte character of charset `eight-bit'.
1039 This differs from `string-as-multibyte' by converting each byte of a correct
1040 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1041 correct sequence. */)
1042 (Lisp_Object string
)
1044 CHECK_STRING (string
);
1046 return string_to_multibyte (string
);
1049 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1051 doc
: /* Return a unibyte string with the same individual chars as STRING.
1052 If STRING is unibyte, the result is STRING itself.
1053 Otherwise it is a newly created string, with no text properties,
1054 where each `eight-bit' character is converted to the corresponding byte.
1055 If STRING contains a non-ASCII, non-`eight-bit' character,
1056 an error is signaled. */)
1057 (Lisp_Object string
)
1059 CHECK_STRING (string
);
1061 if (STRING_MULTIBYTE (string
))
1063 ptrdiff_t chars
= SCHARS (string
);
1064 unsigned char *str
= xmalloc (chars
);
1065 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1067 if (converted
< chars
)
1068 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1069 string
= make_unibyte_string ((char *) str
, chars
);
1076 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1077 doc
: /* Return a copy of ALIST.
1078 This is an alist which represents the same mapping from objects to objects,
1079 but does not share the alist structure with ALIST.
1080 The objects mapped (cars and cdrs of elements of the alist)
1081 are shared, however.
1082 Elements of ALIST that are not conses are also shared. */)
1085 register Lisp_Object tem
;
1090 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1091 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1093 register Lisp_Object car
;
1097 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1102 /* Check that ARRAY can have a valid subarray [FROM..TO),
1103 given that its size is SIZE.
1104 If FROM is nil, use 0; if TO is nil, use SIZE.
1105 Count negative values backwards from the end.
1106 Set *IFROM and *ITO to the two indexes used. */
1109 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1110 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1114 if (INTEGERP (from
))
1120 else if (NILP (from
))
1123 wrong_type_argument (Qintegerp
, from
);
1134 wrong_type_argument (Qintegerp
, to
);
1136 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1137 args_out_of_range_3 (array
, from
, to
);
1143 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1144 doc
: /* Return a new string whose contents are a substring of STRING.
1145 The returned string consists of the characters between index FROM
1146 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1147 zero-indexed: 0 means the first character of STRING. Negative values
1148 are counted from the end of STRING. If TO is nil, the substring runs
1149 to the end of STRING.
1151 The STRING argument may also be a vector. In that case, the return
1152 value is a new vector that contains the elements between index FROM
1153 \(inclusive) and index TO (exclusive) of that vector argument.
1155 With one argument, just copy STRING (with properties, if any). */)
1156 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1159 ptrdiff_t size
, ifrom
, ito
;
1161 size
= CHECK_VECTOR_OR_STRING (string
);
1162 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1164 if (STRINGP (string
))
1167 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1169 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1170 res
= make_specified_string (SSDATA (string
) + from_byte
,
1171 ito
- ifrom
, to_byte
- from_byte
,
1172 STRING_MULTIBYTE (string
));
1173 copy_text_properties (make_number (ifrom
), make_number (ito
),
1174 string
, make_number (0), res
, Qnil
);
1177 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1183 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1184 doc
: /* Return a substring of STRING, without text properties.
1185 It starts at index FROM and ends before TO.
1186 TO may be nil or omitted; then the substring runs to the end of STRING.
1187 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1188 If FROM or TO is negative, it counts from the end.
1190 With one argument, just copy STRING without its properties. */)
1191 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1193 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1195 CHECK_STRING (string
);
1197 size
= SCHARS (string
);
1198 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1200 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1202 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1203 return make_specified_string (SSDATA (string
) + from_byte
,
1204 to_char
- from_char
, to_byte
- from_byte
,
1205 STRING_MULTIBYTE (string
));
1208 /* Extract a substring of STRING, giving start and end positions
1209 both in characters and in bytes. */
1212 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1213 ptrdiff_t to
, ptrdiff_t to_byte
)
1216 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1218 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1219 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1221 if (STRINGP (string
))
1223 res
= make_specified_string (SSDATA (string
) + from_byte
,
1224 to
- from
, to_byte
- from_byte
,
1225 STRING_MULTIBYTE (string
));
1226 copy_text_properties (make_number (from
), make_number (to
),
1227 string
, make_number (0), res
, Qnil
);
1230 res
= Fvector (to
- from
, aref_addr (string
, from
));
1235 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1236 doc
: /* Take cdr N times on LIST, return the result. */)
1237 (Lisp_Object n
, Lisp_Object list
)
1242 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1245 CHECK_LIST_CONS (list
, list
);
1251 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1252 doc
: /* Return the Nth element of LIST.
1253 N counts from zero. If LIST is not that long, nil is returned. */)
1254 (Lisp_Object n
, Lisp_Object list
)
1256 return Fcar (Fnthcdr (n
, list
));
1259 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1260 doc
: /* Return element of SEQUENCE at index N. */)
1261 (register Lisp_Object sequence
, Lisp_Object n
)
1264 if (CONSP (sequence
) || NILP (sequence
))
1265 return Fcar (Fnthcdr (n
, sequence
));
1267 /* Faref signals a "not array" error, so check here. */
1268 CHECK_ARRAY (sequence
, Qsequencep
);
1269 return Faref (sequence
, n
);
1272 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1273 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1274 The value is actually the tail of LIST whose car is ELT. */)
1275 (register Lisp_Object elt
, Lisp_Object list
)
1277 register Lisp_Object tail
;
1278 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1280 register Lisp_Object tem
;
1281 CHECK_LIST_CONS (tail
, list
);
1283 if (! NILP (Fequal (elt
, tem
)))
1290 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1291 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1292 The value is actually the tail of LIST whose car is ELT. */)
1293 (register Lisp_Object elt
, Lisp_Object list
)
1297 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1301 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1305 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1316 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1317 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1318 The value is actually the tail of LIST whose car is ELT. */)
1319 (register Lisp_Object elt
, Lisp_Object list
)
1321 register Lisp_Object tail
;
1324 return Fmemq (elt
, list
);
1326 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1328 register Lisp_Object tem
;
1329 CHECK_LIST_CONS (tail
, list
);
1331 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1338 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1339 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1340 The value is actually the first element of LIST whose car is KEY.
1341 Elements of LIST that are not conses are ignored. */)
1342 (Lisp_Object key
, Lisp_Object list
)
1347 || (CONSP (XCAR (list
))
1348 && EQ (XCAR (XCAR (list
)), key
)))
1353 || (CONSP (XCAR (list
))
1354 && EQ (XCAR (XCAR (list
)), key
)))
1359 || (CONSP (XCAR (list
))
1360 && EQ (XCAR (XCAR (list
)), key
)))
1370 /* Like Fassq but never report an error and do not allow quits.
1371 Use only on lists known never to be circular. */
1374 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1377 && (!CONSP (XCAR (list
))
1378 || !EQ (XCAR (XCAR (list
)), key
)))
1381 return CAR_SAFE (list
);
1384 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1385 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1386 The value is actually the first element of LIST whose car equals KEY. */)
1387 (Lisp_Object key
, Lisp_Object list
)
1394 || (CONSP (XCAR (list
))
1395 && (car
= XCAR (XCAR (list
)),
1396 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1401 || (CONSP (XCAR (list
))
1402 && (car
= XCAR (XCAR (list
)),
1403 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1408 || (CONSP (XCAR (list
))
1409 && (car
= XCAR (XCAR (list
)),
1410 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1420 /* Like Fassoc but never report an error and do not allow quits.
1421 Use only on lists known never to be circular. */
1424 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1427 && (!CONSP (XCAR (list
))
1428 || (!EQ (XCAR (XCAR (list
)), key
)
1429 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1432 return CONSP (list
) ? XCAR (list
) : Qnil
;
1435 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1436 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1437 The value is actually the first element of LIST whose cdr is KEY. */)
1438 (register Lisp_Object key
, Lisp_Object list
)
1443 || (CONSP (XCAR (list
))
1444 && EQ (XCDR (XCAR (list
)), key
)))
1449 || (CONSP (XCAR (list
))
1450 && EQ (XCDR (XCAR (list
)), key
)))
1455 || (CONSP (XCAR (list
))
1456 && EQ (XCDR (XCAR (list
)), key
)))
1466 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1467 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1468 The value is actually the first element of LIST whose cdr equals KEY. */)
1469 (Lisp_Object key
, Lisp_Object list
)
1476 || (CONSP (XCAR (list
))
1477 && (cdr
= XCDR (XCAR (list
)),
1478 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1483 || (CONSP (XCAR (list
))
1484 && (cdr
= XCDR (XCAR (list
)),
1485 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1490 || (CONSP (XCAR (list
))
1491 && (cdr
= XCDR (XCAR (list
)),
1492 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1502 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1503 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1504 More precisely, this function skips any members `eq' to ELT at the
1505 front of LIST, then removes members `eq' to ELT from the remaining
1506 sublist by modifying its list structure, then returns the resulting
1509 Write `(setq foo (delq element foo))' to be sure of correctly changing
1510 the value of a list `foo'. */)
1511 (register Lisp_Object elt
, Lisp_Object list
)
1513 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1516 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1518 Lisp_Object tem
= XCAR (tail
);
1524 Fsetcdr (prev
, XCDR (tail
));
1532 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1533 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1534 SEQ must be a sequence (i.e. a list, a vector, or a string).
1535 The return value is a sequence of the same type.
1537 If SEQ is a list, this behaves like `delq', except that it compares
1538 with `equal' instead of `eq'. In particular, it may remove elements
1539 by altering the list structure.
1541 If SEQ is not a list, deletion is never performed destructively;
1542 instead this function creates and returns a new vector or string.
1544 Write `(setq foo (delete element foo))' to be sure of correctly
1545 changing the value of a sequence `foo'. */)
1546 (Lisp_Object elt
, Lisp_Object seq
)
1552 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1553 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1556 if (n
!= ASIZE (seq
))
1558 struct Lisp_Vector
*p
= allocate_vector (n
);
1560 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1561 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1562 p
->contents
[n
++] = AREF (seq
, i
);
1564 XSETVECTOR (seq
, p
);
1567 else if (STRINGP (seq
))
1569 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1572 for (i
= nchars
= nbytes
= ibyte
= 0;
1574 ++i
, ibyte
+= cbytes
)
1576 if (STRING_MULTIBYTE (seq
))
1578 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1579 cbytes
= CHAR_BYTES (c
);
1587 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1594 if (nchars
!= SCHARS (seq
))
1598 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1599 if (!STRING_MULTIBYTE (seq
))
1600 STRING_SET_UNIBYTE (tem
);
1602 for (i
= nchars
= nbytes
= ibyte
= 0;
1604 ++i
, ibyte
+= cbytes
)
1606 if (STRING_MULTIBYTE (seq
))
1608 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1609 cbytes
= CHAR_BYTES (c
);
1617 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1619 unsigned char *from
= SDATA (seq
) + ibyte
;
1620 unsigned char *to
= SDATA (tem
) + nbytes
;
1626 for (n
= cbytes
; n
--; )
1636 Lisp_Object tail
, prev
;
1638 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1640 CHECK_LIST_CONS (tail
, seq
);
1642 if (!NILP (Fequal (elt
, XCAR (tail
))))
1647 Fsetcdr (prev
, XCDR (tail
));
1658 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1659 doc
: /* Reverse order of items in a list, vector or string SEQ.
1660 If SEQ is a list, it should be nil-terminated.
1661 This function may destructively modify SEQ to produce the value. */)
1666 else if (STRINGP (seq
))
1667 return Freverse (seq
);
1668 else if (CONSP (seq
))
1670 Lisp_Object prev
, tail
, next
;
1672 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1675 CHECK_LIST_CONS (tail
, tail
);
1677 Fsetcdr (tail
, prev
);
1682 else if (VECTORP (seq
))
1684 ptrdiff_t i
, size
= ASIZE (seq
);
1686 for (i
= 0; i
< size
/ 2; i
++)
1688 Lisp_Object tem
= AREF (seq
, i
);
1689 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1690 ASET (seq
, size
- i
- 1, tem
);
1693 else if (BOOL_VECTOR_P (seq
))
1695 ptrdiff_t i
, size
= bool_vector_size (seq
);
1697 for (i
= 0; i
< size
/ 2; i
++)
1699 bool tem
= bool_vector_bitref (seq
, i
);
1700 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1701 bool_vector_set (seq
, size
- i
- 1, tem
);
1705 wrong_type_argument (Qarrayp
, seq
);
1709 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1710 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1711 See also the function `nreverse', which is used more often. */)
1718 else if (CONSP (seq
))
1720 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1723 new = Fcons (XCAR (seq
), new);
1725 CHECK_LIST_END (seq
, seq
);
1727 else if (VECTORP (seq
))
1729 ptrdiff_t i
, size
= ASIZE (seq
);
1731 new = make_uninit_vector (size
);
1732 for (i
= 0; i
< size
; i
++)
1733 ASET (new, i
, AREF (seq
, size
- i
- 1));
1735 else if (BOOL_VECTOR_P (seq
))
1738 EMACS_INT nbits
= bool_vector_size (seq
);
1740 new = make_uninit_bool_vector (nbits
);
1741 for (i
= 0; i
< nbits
; i
++)
1742 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1744 else if (STRINGP (seq
))
1746 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1752 new = make_uninit_string (size
);
1753 for (i
= 0; i
< size
; i
++)
1754 SSET (new, i
, SREF (seq
, size
- i
- 1));
1758 unsigned char *p
, *q
;
1760 new = make_uninit_multibyte_string (size
, bytes
);
1761 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1762 while (q
> SDATA (new))
1766 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1768 CHAR_STRING (ch
, q
);
1773 wrong_type_argument (Qsequencep
, seq
);
1777 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1778 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1779 Returns the sorted list. LIST is modified by side effects.
1780 PREDICATE is called with two elements of LIST, and should return non-nil
1781 if the first element should sort before the second. */)
1782 (Lisp_Object list
, Lisp_Object predicate
)
1784 Lisp_Object front
, back
;
1785 register Lisp_Object len
, tem
;
1786 struct gcpro gcpro1
, gcpro2
;
1790 len
= Flength (list
);
1791 length
= XINT (len
);
1795 XSETINT (len
, (length
/ 2) - 1);
1796 tem
= Fnthcdr (len
, list
);
1798 Fsetcdr (tem
, Qnil
);
1800 GCPRO2 (front
, back
);
1801 front
= Fsort (front
, predicate
);
1802 back
= Fsort (back
, predicate
);
1804 return merge (front
, back
, predicate
);
1808 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1811 register Lisp_Object tail
;
1813 register Lisp_Object l1
, l2
;
1814 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1821 /* It is sufficient to protect org_l1 and org_l2.
1822 When l1 and l2 are updated, we copy the new values
1823 back into the org_ vars. */
1824 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1844 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1860 Fsetcdr (tail
, tem
);
1866 /* This does not check for quits. That is safe since it must terminate. */
1868 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1869 doc
: /* Extract a value from a property list.
1870 PLIST is a property list, which is a list of the form
1871 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1872 corresponding to the given PROP, or nil if PROP is not one of the
1873 properties on the list. This function never signals an error. */)
1874 (Lisp_Object plist
, Lisp_Object prop
)
1876 Lisp_Object tail
, halftail
;
1878 /* halftail is used to detect circular lists. */
1879 tail
= halftail
= plist
;
1880 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1882 if (EQ (prop
, XCAR (tail
)))
1883 return XCAR (XCDR (tail
));
1885 tail
= XCDR (XCDR (tail
));
1886 halftail
= XCDR (halftail
);
1887 if (EQ (tail
, halftail
))
1894 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1895 doc
: /* Return the value of SYMBOL's PROPNAME property.
1896 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1897 (Lisp_Object symbol
, Lisp_Object propname
)
1899 CHECK_SYMBOL (symbol
);
1900 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1903 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1904 doc
: /* Change value in PLIST of PROP to VAL.
1905 PLIST is a property list, which is a list of the form
1906 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1907 If PROP is already a property on the list, its value is set to VAL,
1908 otherwise the new PROP VAL pair is added. The new plist is returned;
1909 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1910 The PLIST is modified by side effects. */)
1911 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1913 register Lisp_Object tail
, prev
;
1914 Lisp_Object newcell
;
1916 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1917 tail
= XCDR (XCDR (tail
)))
1919 if (EQ (prop
, XCAR (tail
)))
1921 Fsetcar (XCDR (tail
), val
);
1928 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1932 Fsetcdr (XCDR (prev
), newcell
);
1936 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1937 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1938 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1939 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1941 CHECK_SYMBOL (symbol
);
1943 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1947 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1948 doc
: /* Extract a value from a property list, comparing with `equal'.
1949 PLIST is a property list, which is a list of the form
1950 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1951 corresponding to the given PROP, or nil if PROP is not
1952 one of the properties on the list. */)
1953 (Lisp_Object plist
, Lisp_Object prop
)
1958 CONSP (tail
) && CONSP (XCDR (tail
));
1959 tail
= XCDR (XCDR (tail
)))
1961 if (! NILP (Fequal (prop
, XCAR (tail
))))
1962 return XCAR (XCDR (tail
));
1967 CHECK_LIST_END (tail
, prop
);
1972 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1973 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1974 PLIST is a property list, which is a list of the form
1975 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1976 If PROP is already a property on the list, its value is set to VAL,
1977 otherwise the new PROP VAL pair is added. The new plist is returned;
1978 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1979 The PLIST is modified by side effects. */)
1980 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1982 register Lisp_Object tail
, prev
;
1983 Lisp_Object newcell
;
1985 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1986 tail
= XCDR (XCDR (tail
)))
1988 if (! NILP (Fequal (prop
, XCAR (tail
))))
1990 Fsetcar (XCDR (tail
), val
);
1997 newcell
= list2 (prop
, val
);
2001 Fsetcdr (XCDR (prev
), newcell
);
2005 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2006 doc
: /* Return t if the two args are the same Lisp object.
2007 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2008 (Lisp_Object obj1
, Lisp_Object obj2
)
2011 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2013 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2016 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2017 doc
: /* Return t if two Lisp objects have similar structure and contents.
2018 They must have the same data type.
2019 Conses are compared by comparing the cars and the cdrs.
2020 Vectors and strings are compared element by element.
2021 Numbers are compared by value, but integers cannot equal floats.
2022 (Use `=' if you want integers and floats to be able to be equal.)
2023 Symbols must match exactly. */)
2024 (register Lisp_Object o1
, Lisp_Object o2
)
2026 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2029 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2030 doc
: /* Return t if two Lisp objects have similar structure and contents.
2031 This is like `equal' except that it compares the text properties
2032 of strings. (`equal' ignores text properties.) */)
2033 (register Lisp_Object o1
, Lisp_Object o2
)
2035 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2038 /* DEPTH is current depth of recursion. Signal an error if it
2040 PROPS means compare string text properties too. */
2043 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2049 error ("Stack overflow in equal");
2052 Lisp_Object args
[2];
2055 ht
= Fmake_hash_table (2, args
);
2059 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2061 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2063 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2065 { /* `o1' was seen already. */
2066 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2067 if (!NILP (Fmemq (o2
, o2s
)))
2070 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2073 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2083 if (XTYPE (o1
) != XTYPE (o2
))
2092 d1
= extract_float (o1
);
2093 d2
= extract_float (o2
);
2094 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2095 though they are not =. */
2096 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2100 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2104 /* FIXME: This inf-loops in a circular list! */
2108 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2112 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2113 depth
+ 1, props
, ht
)
2114 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2115 depth
+ 1, props
, ht
))
2117 o1
= XOVERLAY (o1
)->plist
;
2118 o2
= XOVERLAY (o2
)->plist
;
2123 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2124 && (XMARKER (o1
)->buffer
== 0
2125 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2129 case Lisp_Vectorlike
:
2132 ptrdiff_t size
= ASIZE (o1
);
2133 /* Pseudovectors have the type encoded in the size field, so this test
2134 actually checks that the objects have the same type as well as the
2136 if (ASIZE (o2
) != size
)
2138 /* Boolvectors are compared much like strings. */
2139 if (BOOL_VECTOR_P (o1
))
2141 EMACS_INT size
= bool_vector_size (o1
);
2142 if (size
!= bool_vector_size (o2
))
2144 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2145 bool_vector_bytes (size
)))
2149 if (WINDOW_CONFIGURATIONP (o1
))
2150 return compare_window_configurations (o1
, o2
, 0);
2152 /* Aside from them, only true vectors, char-tables, compiled
2153 functions, and fonts (font-spec, font-entity, font-object)
2154 are sensible to compare, so eliminate the others now. */
2155 if (size
& PSEUDOVECTOR_FLAG
)
2157 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2160 size
&= PSEUDOVECTOR_SIZE_MASK
;
2162 for (i
= 0; i
< size
; i
++)
2167 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2175 if (SCHARS (o1
) != SCHARS (o2
))
2177 if (SBYTES (o1
) != SBYTES (o2
))
2179 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2181 if (props
&& !compare_string_intervals (o1
, o2
))
2193 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2194 doc
: /* Store each element of ARRAY with ITEM.
2195 ARRAY is a vector, string, char-table, or bool-vector. */)
2196 (Lisp_Object array
, Lisp_Object item
)
2198 register ptrdiff_t size
, idx
;
2200 if (VECTORP (array
))
2201 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2202 ASET (array
, idx
, item
);
2203 else if (CHAR_TABLE_P (array
))
2207 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2208 set_char_table_contents (array
, i
, item
);
2209 set_char_table_defalt (array
, item
);
2211 else if (STRINGP (array
))
2213 register unsigned char *p
= SDATA (array
);
2215 CHECK_CHARACTER (item
);
2216 charval
= XFASTINT (item
);
2217 size
= SCHARS (array
);
2218 if (STRING_MULTIBYTE (array
))
2220 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2221 int len
= CHAR_STRING (charval
, str
);
2222 ptrdiff_t size_byte
= SBYTES (array
);
2224 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2225 || SCHARS (array
) * len
!= size_byte
)
2226 error ("Attempt to change byte length of a string");
2227 for (idx
= 0; idx
< size_byte
; idx
++)
2228 *p
++ = str
[idx
% len
];
2231 for (idx
= 0; idx
< size
; idx
++)
2234 else if (BOOL_VECTOR_P (array
))
2235 return bool_vector_fill (array
, item
);
2237 wrong_type_argument (Qarrayp
, array
);
2241 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2243 doc
: /* Clear the contents of STRING.
2244 This makes STRING unibyte and may change its length. */)
2245 (Lisp_Object string
)
2248 CHECK_STRING (string
);
2249 len
= SBYTES (string
);
2250 memset (SDATA (string
), 0, len
);
2251 STRING_SET_CHARS (string
, len
);
2252 STRING_SET_UNIBYTE (string
);
2258 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2260 Lisp_Object args
[2];
2263 return Fnconc (2, args
);
2266 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2267 doc
: /* Concatenate any number of lists by altering them.
2268 Only the last argument is not altered, and need not be a list.
2269 usage: (nconc &rest LISTS) */)
2270 (ptrdiff_t nargs
, Lisp_Object
*args
)
2273 register Lisp_Object tail
, tem
, val
;
2277 for (argnum
= 0; argnum
< nargs
; argnum
++)
2280 if (NILP (tem
)) continue;
2285 if (argnum
+ 1 == nargs
) break;
2287 CHECK_LIST_CONS (tem
, tem
);
2296 tem
= args
[argnum
+ 1];
2297 Fsetcdr (tail
, tem
);
2299 args
[argnum
+ 1] = tail
;
2305 /* This is the guts of all mapping functions.
2306 Apply FN to each element of SEQ, one by one,
2307 storing the results into elements of VALS, a C vector of Lisp_Objects.
2308 LENI is the length of VALS, which should also be the length of SEQ. */
2311 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2313 register Lisp_Object tail
;
2315 register EMACS_INT i
;
2316 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2320 /* Don't let vals contain any garbage when GC happens. */
2321 for (i
= 0; i
< leni
; i
++)
2324 GCPRO3 (dummy
, fn
, seq
);
2326 gcpro1
.nvars
= leni
;
2330 /* We need not explicitly protect `tail' because it is used only on lists, and
2331 1) lists are not relocated and 2) the list is marked via `seq' so will not
2334 if (VECTORP (seq
) || COMPILEDP (seq
))
2336 for (i
= 0; i
< leni
; i
++)
2338 dummy
= call1 (fn
, AREF (seq
, i
));
2343 else if (BOOL_VECTOR_P (seq
))
2345 for (i
= 0; i
< leni
; i
++)
2347 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2352 else if (STRINGP (seq
))
2356 for (i
= 0, i_byte
= 0; i
< leni
;)
2359 ptrdiff_t i_before
= i
;
2361 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2362 XSETFASTINT (dummy
, c
);
2363 dummy
= call1 (fn
, dummy
);
2365 vals
[i_before
] = dummy
;
2368 else /* Must be a list, since Flength did not get an error */
2371 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2373 dummy
= call1 (fn
, XCAR (tail
));
2383 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2384 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2385 In between each pair of results, stick in SEPARATOR. Thus, " " as
2386 SEPARATOR results in spaces between the values returned by FUNCTION.
2387 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2388 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2391 register EMACS_INT leni
;
2394 register Lisp_Object
*args
;
2395 struct gcpro gcpro1
;
2399 len
= Flength (sequence
);
2400 if (CHAR_TABLE_P (sequence
))
2401 wrong_type_argument (Qlistp
, sequence
);
2403 nargs
= leni
+ leni
- 1;
2404 if (nargs
< 0) return empty_unibyte_string
;
2406 SAFE_ALLOCA_LISP (args
, nargs
);
2409 mapcar1 (leni
, args
, function
, sequence
);
2412 for (i
= leni
- 1; i
> 0; i
--)
2413 args
[i
+ i
] = args
[i
];
2415 for (i
= 1; i
< nargs
; i
+= 2)
2416 args
[i
] = separator
;
2418 ret
= Fconcat (nargs
, args
);
2424 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2425 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2426 The result is a list just as long as SEQUENCE.
2427 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2428 (Lisp_Object function
, Lisp_Object sequence
)
2430 register Lisp_Object len
;
2431 register EMACS_INT leni
;
2432 register Lisp_Object
*args
;
2436 len
= Flength (sequence
);
2437 if (CHAR_TABLE_P (sequence
))
2438 wrong_type_argument (Qlistp
, sequence
);
2439 leni
= XFASTINT (len
);
2441 SAFE_ALLOCA_LISP (args
, leni
);
2443 mapcar1 (leni
, args
, function
, sequence
);
2445 ret
= Flist (leni
, args
);
2451 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2452 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2453 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2454 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2455 (Lisp_Object function
, Lisp_Object sequence
)
2457 register EMACS_INT leni
;
2459 leni
= XFASTINT (Flength (sequence
));
2460 if (CHAR_TABLE_P (sequence
))
2461 wrong_type_argument (Qlistp
, sequence
);
2462 mapcar1 (leni
, 0, function
, sequence
);
2467 /* This is how C code calls `yes-or-no-p' and allows the user
2470 Anything that calls this function must protect from GC! */
2473 do_yes_or_no_p (Lisp_Object prompt
)
2475 return call1 (intern ("yes-or-no-p"), prompt
);
2478 /* Anything that calls this function must protect from GC! */
2480 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2481 doc
: /* Ask user a yes-or-no question.
2482 Return t if answer is yes, and nil if the answer is no.
2483 PROMPT is the string to display to ask the question. It should end in
2484 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2486 The user must confirm the answer with RET, and can edit it until it
2489 If dialog boxes are supported, a dialog box will be used
2490 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2491 (Lisp_Object prompt
)
2493 register Lisp_Object ans
;
2494 Lisp_Object args
[2];
2495 struct gcpro gcpro1
;
2497 CHECK_STRING (prompt
);
2499 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2502 Lisp_Object pane
, menu
, obj
;
2503 redisplay_preserve_echo_area (4);
2504 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2505 Fcons (build_string ("No"), Qnil
));
2507 menu
= Fcons (prompt
, pane
);
2508 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2514 args
[1] = build_string ("(yes or no) ");
2515 prompt
= Fconcat (2, args
);
2521 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2522 Qyes_or_no_p_history
, Qnil
,
2524 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2529 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2537 message1 ("Please answer yes or no.");
2538 Fsleep_for (make_number (2), Qnil
);
2542 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2543 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2545 Each of the three load averages is multiplied by 100, then converted
2548 When USE-FLOATS is non-nil, floats will be used instead of integers.
2549 These floats are not multiplied by 100.
2551 If the 5-minute or 15-minute load averages are not available, return a
2552 shortened list, containing only those averages which are available.
2554 An error is thrown if the load average can't be obtained. In some
2555 cases making it work would require Emacs being installed setuid or
2556 setgid so that it can read kernel information, and that usually isn't
2558 (Lisp_Object use_floats
)
2561 int loads
= getloadavg (load_ave
, 3);
2562 Lisp_Object ret
= Qnil
;
2565 error ("load-average not implemented for this operating system");
2569 Lisp_Object load
= (NILP (use_floats
)
2570 ? make_number (100.0 * load_ave
[loads
])
2571 : make_float (load_ave
[loads
]));
2572 ret
= Fcons (load
, ret
);
2578 static Lisp_Object Qsubfeatures
;
2580 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2581 doc
: /* Return t if FEATURE is present in this Emacs.
2583 Use this to conditionalize execution of lisp code based on the
2584 presence or absence of Emacs or environment extensions.
2585 Use `provide' to declare that a feature is available. This function
2586 looks at the value of the variable `features'. The optional argument
2587 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2588 (Lisp_Object feature
, Lisp_Object subfeature
)
2590 register Lisp_Object tem
;
2591 CHECK_SYMBOL (feature
);
2592 tem
= Fmemq (feature
, Vfeatures
);
2593 if (!NILP (tem
) && !NILP (subfeature
))
2594 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2595 return (NILP (tem
)) ? Qnil
: Qt
;
2598 static Lisp_Object Qfuncall
;
2600 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2601 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2602 The optional argument SUBFEATURES should be a list of symbols listing
2603 particular subfeatures supported in this version of FEATURE. */)
2604 (Lisp_Object feature
, Lisp_Object subfeatures
)
2606 register Lisp_Object tem
;
2607 CHECK_SYMBOL (feature
);
2608 CHECK_LIST (subfeatures
);
2609 if (!NILP (Vautoload_queue
))
2610 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2612 tem
= Fmemq (feature
, Vfeatures
);
2614 Vfeatures
= Fcons (feature
, Vfeatures
);
2615 if (!NILP (subfeatures
))
2616 Fput (feature
, Qsubfeatures
, subfeatures
);
2617 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2619 /* Run any load-hooks for this file. */
2620 tem
= Fassq (feature
, Vafter_load_alist
);
2622 Fmapc (Qfuncall
, XCDR (tem
));
2627 /* `require' and its subroutines. */
2629 /* List of features currently being require'd, innermost first. */
2631 static Lisp_Object require_nesting_list
;
2634 require_unwind (Lisp_Object old_value
)
2636 require_nesting_list
= old_value
;
2639 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2640 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2641 If FEATURE is not a member of the list `features', then the feature
2642 is not loaded; so load the file FILENAME.
2643 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2644 and `load' will try to load this name appended with the suffix `.elc' or
2645 `.el', in that order. The name without appended suffix will not be used.
2646 See `get-load-suffixes' for the complete list of suffixes.
2647 If the optional third argument NOERROR is non-nil,
2648 then return nil if the file is not found instead of signaling an error.
2649 Normally the return value is FEATURE.
2650 The normal messages at start and end of loading FILENAME are suppressed. */)
2651 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2654 struct gcpro gcpro1
, gcpro2
;
2655 bool from_file
= load_in_progress
;
2657 CHECK_SYMBOL (feature
);
2659 /* Record the presence of `require' in this file
2660 even if the feature specified is already loaded.
2661 But not more than once in any file,
2662 and not when we aren't loading or reading from a file. */
2664 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2665 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2670 tem
= Fcons (Qrequire
, feature
);
2671 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2672 LOADHIST_ATTACH (tem
);
2674 tem
= Fmemq (feature
, Vfeatures
);
2678 ptrdiff_t count
= SPECPDL_INDEX ();
2681 /* This is to make sure that loadup.el gives a clear picture
2682 of what files are preloaded and when. */
2683 if (! NILP (Vpurify_flag
))
2684 error ("(require %s) while preparing to dump",
2685 SDATA (SYMBOL_NAME (feature
)));
2687 /* A certain amount of recursive `require' is legitimate,
2688 but if we require the same feature recursively 3 times,
2690 tem
= require_nesting_list
;
2691 while (! NILP (tem
))
2693 if (! NILP (Fequal (feature
, XCAR (tem
))))
2698 error ("Recursive `require' for feature `%s'",
2699 SDATA (SYMBOL_NAME (feature
)));
2701 /* Update the list for any nested `require's that occur. */
2702 record_unwind_protect (require_unwind
, require_nesting_list
);
2703 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2705 /* Value saved here is to be restored into Vautoload_queue */
2706 record_unwind_protect (un_autoload
, Vautoload_queue
);
2707 Vautoload_queue
= Qt
;
2709 /* Load the file. */
2710 GCPRO2 (feature
, filename
);
2711 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2712 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2715 /* If load failed entirely, return nil. */
2717 return unbind_to (count
, Qnil
);
2719 tem
= Fmemq (feature
, Vfeatures
);
2721 error ("Required feature `%s' was not provided",
2722 SDATA (SYMBOL_NAME (feature
)));
2724 /* Once loading finishes, don't undo it. */
2725 Vautoload_queue
= Qt
;
2726 feature
= unbind_to (count
, feature
);
2732 /* Primitives for work of the "widget" library.
2733 In an ideal world, this section would not have been necessary.
2734 However, lisp function calls being as slow as they are, it turns
2735 out that some functions in the widget library (wid-edit.el) are the
2736 bottleneck of Widget operation. Here is their translation to C,
2737 for the sole reason of efficiency. */
2739 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2740 doc
: /* Return non-nil if PLIST has the property PROP.
2741 PLIST is a property list, which is a list of the form
2742 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2743 Unlike `plist-get', this allows you to distinguish between a missing
2744 property and a property with the value nil.
2745 The value is actually the tail of PLIST whose car is PROP. */)
2746 (Lisp_Object plist
, Lisp_Object prop
)
2748 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2751 plist
= XCDR (plist
);
2752 plist
= CDR (plist
);
2757 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2758 doc
: /* In WIDGET, set PROPERTY to VALUE.
2759 The value can later be retrieved with `widget-get'. */)
2760 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2762 CHECK_CONS (widget
);
2763 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2767 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2768 doc
: /* In WIDGET, get the value of PROPERTY.
2769 The value could either be specified when the widget was created, or
2770 later with `widget-put'. */)
2771 (Lisp_Object widget
, Lisp_Object property
)
2779 CHECK_CONS (widget
);
2780 tmp
= Fplist_member (XCDR (widget
), property
);
2786 tmp
= XCAR (widget
);
2789 widget
= Fget (tmp
, Qwidget_type
);
2793 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2794 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2795 ARGS are passed as extra arguments to the function.
2796 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2797 (ptrdiff_t nargs
, Lisp_Object
*args
)
2799 /* This function can GC. */
2800 Lisp_Object newargs
[3];
2801 struct gcpro gcpro1
, gcpro2
;
2804 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2805 newargs
[1] = args
[0];
2806 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2807 GCPRO2 (newargs
[0], newargs
[2]);
2808 result
= Fapply (3, newargs
);
2813 #ifdef HAVE_LANGINFO_CODESET
2814 #include <langinfo.h>
2817 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2818 doc
: /* Access locale data ITEM for the current C locale, if available.
2819 ITEM should be one of the following:
2821 `codeset', returning the character set as a string (locale item CODESET);
2823 `days', returning a 7-element vector of day names (locale items DAY_n);
2825 `months', returning a 12-element vector of month names (locale items MON_n);
2827 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2828 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2830 If the system can't provide such information through a call to
2831 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2833 See also Info node `(libc)Locales'.
2835 The data read from the system are decoded using `locale-coding-system'. */)
2839 #ifdef HAVE_LANGINFO_CODESET
2841 if (EQ (item
, Qcodeset
))
2843 str
= nl_langinfo (CODESET
);
2844 return build_string (str
);
2847 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2849 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2850 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2852 struct gcpro gcpro1
;
2854 synchronize_system_time_locale ();
2855 for (i
= 0; i
< 7; i
++)
2857 str
= nl_langinfo (days
[i
]);
2858 val
= build_unibyte_string (str
);
2859 /* Fixme: Is this coding system necessarily right, even if
2860 it is consistent with CODESET? If not, what to do? */
2861 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2869 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2871 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2872 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2873 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2875 struct gcpro gcpro1
;
2877 synchronize_system_time_locale ();
2878 for (i
= 0; i
< 12; i
++)
2880 str
= nl_langinfo (months
[i
]);
2881 val
= build_unibyte_string (str
);
2882 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2889 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2890 but is in the locale files. This could be used by ps-print. */
2892 else if (EQ (item
, Qpaper
))
2893 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2894 #endif /* PAPER_WIDTH */
2895 #endif /* HAVE_LANGINFO_CODESET*/
2899 /* base64 encode/decode functions (RFC 2045).
2900 Based on code from GNU recode. */
2902 #define MIME_LINE_LENGTH 76
2904 #define IS_ASCII(Character) \
2906 #define IS_BASE64(Character) \
2907 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2908 #define IS_BASE64_IGNORABLE(Character) \
2909 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2910 || (Character) == '\f' || (Character) == '\r')
2912 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2913 character or return retval if there are no characters left to
2915 #define READ_QUADRUPLET_BYTE(retval) \
2920 if (nchars_return) \
2921 *nchars_return = nchars; \
2926 while (IS_BASE64_IGNORABLE (c))
2928 /* Table of characters coding the 64 values. */
2929 static const char base64_value_to_char
[64] =
2931 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2932 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2933 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2934 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2935 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2936 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2937 '8', '9', '+', '/' /* 60-63 */
2940 /* Table of base64 values for first 128 characters. */
2941 static const short base64_char_to_value
[128] =
2943 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2944 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2945 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2946 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2947 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2948 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2949 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2950 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2951 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2952 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2953 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2954 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2955 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2958 /* The following diagram shows the logical steps by which three octets
2959 get transformed into four base64 characters.
2961 .--------. .--------. .--------.
2962 |aaaaaabb| |bbbbcccc| |ccdddddd|
2963 `--------' `--------' `--------'
2965 .--------+--------+--------+--------.
2966 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2967 `--------+--------+--------+--------'
2969 .--------+--------+--------+--------.
2970 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2971 `--------+--------+--------+--------'
2973 The octets are divided into 6 bit chunks, which are then encoded into
2974 base64 characters. */
2977 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2978 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2981 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2983 doc
: /* Base64-encode the region between BEG and END.
2984 Return the length of the encoded text.
2985 Optional third argument NO-LINE-BREAK means do not break long lines
2986 into shorter lines. */)
2987 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2990 ptrdiff_t allength
, length
;
2991 ptrdiff_t ibeg
, iend
, encoded_length
;
2992 ptrdiff_t old_pos
= PT
;
2995 validate_region (&beg
, &end
);
2997 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2998 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2999 move_gap_both (XFASTINT (beg
), ibeg
);
3001 /* We need to allocate enough room for encoding the text.
3002 We need 33 1/3% more space, plus a newline every 76
3003 characters, and then we round up. */
3004 length
= iend
- ibeg
;
3005 allength
= length
+ length
/3 + 1;
3006 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3008 encoded
= SAFE_ALLOCA (allength
);
3009 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3010 encoded
, length
, NILP (no_line_break
),
3011 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3012 if (encoded_length
> allength
)
3015 if (encoded_length
< 0)
3017 /* The encoding wasn't possible. */
3019 error ("Multibyte character in data for base64 encoding");
3022 /* Now we have encoded the region, so we insert the new contents
3023 and delete the old. (Insert first in order to preserve markers.) */
3024 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3025 insert (encoded
, encoded_length
);
3027 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3029 /* If point was outside of the region, restore it exactly; else just
3030 move to the beginning of the region. */
3031 if (old_pos
>= XFASTINT (end
))
3032 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3033 else if (old_pos
> XFASTINT (beg
))
3034 old_pos
= XFASTINT (beg
);
3037 /* We return the length of the encoded text. */
3038 return make_number (encoded_length
);
3041 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3043 doc
: /* Base64-encode STRING and return the result.
3044 Optional second argument NO-LINE-BREAK means do not break long lines
3045 into shorter lines. */)
3046 (Lisp_Object string
, Lisp_Object no_line_break
)
3048 ptrdiff_t allength
, length
, encoded_length
;
3050 Lisp_Object encoded_string
;
3053 CHECK_STRING (string
);
3055 /* We need to allocate enough room for encoding the text.
3056 We need 33 1/3% more space, plus a newline every 76
3057 characters, and then we round up. */
3058 length
= SBYTES (string
);
3059 allength
= length
+ length
/3 + 1;
3060 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3062 /* We need to allocate enough room for decoding the text. */
3063 encoded
= SAFE_ALLOCA (allength
);
3065 encoded_length
= base64_encode_1 (SSDATA (string
),
3066 encoded
, length
, NILP (no_line_break
),
3067 STRING_MULTIBYTE (string
));
3068 if (encoded_length
> allength
)
3071 if (encoded_length
< 0)
3073 /* The encoding wasn't possible. */
3075 error ("Multibyte character in data for base64 encoding");
3078 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3081 return encoded_string
;
3085 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3086 bool line_break
, bool multibyte
)
3099 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3100 if (CHAR_BYTE8_P (c
))
3101 c
= CHAR_TO_BYTE8 (c
);
3109 /* Wrap line every 76 characters. */
3113 if (counter
< MIME_LINE_LENGTH
/ 4)
3122 /* Process first byte of a triplet. */
3124 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3125 value
= (0x03 & c
) << 4;
3127 /* Process second byte of a triplet. */
3131 *e
++ = base64_value_to_char
[value
];
3139 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3140 if (CHAR_BYTE8_P (c
))
3141 c
= CHAR_TO_BYTE8 (c
);
3149 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3150 value
= (0x0f & c
) << 2;
3152 /* Process third byte of a triplet. */
3156 *e
++ = base64_value_to_char
[value
];
3163 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3164 if (CHAR_BYTE8_P (c
))
3165 c
= CHAR_TO_BYTE8 (c
);
3173 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3174 *e
++ = base64_value_to_char
[0x3f & c
];
3181 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3183 doc
: /* Base64-decode the region between BEG and END.
3184 Return the length of the decoded text.
3185 If the region can't be decoded, signal an error and don't modify the buffer. */)
3186 (Lisp_Object beg
, Lisp_Object end
)
3188 ptrdiff_t ibeg
, iend
, length
, allength
;
3190 ptrdiff_t old_pos
= PT
;
3191 ptrdiff_t decoded_length
;
3192 ptrdiff_t inserted_chars
;
3193 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3196 validate_region (&beg
, &end
);
3198 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3199 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3201 length
= iend
- ibeg
;
3203 /* We need to allocate enough room for decoding the text. If we are
3204 working on a multibyte buffer, each decoded code may occupy at
3206 allength
= multibyte
? length
* 2 : length
;
3207 decoded
= SAFE_ALLOCA (allength
);
3209 move_gap_both (XFASTINT (beg
), ibeg
);
3210 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3212 multibyte
, &inserted_chars
);
3213 if (decoded_length
> allength
)
3216 if (decoded_length
< 0)
3218 /* The decoding wasn't possible. */
3220 error ("Invalid base64 data");
3223 /* Now we have decoded the region, so we insert the new contents
3224 and delete the old. (Insert first in order to preserve markers.) */
3225 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3226 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3229 /* Delete the original text. */
3230 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3231 iend
+ decoded_length
, 1);
3233 /* If point was outside of the region, restore it exactly; else just
3234 move to the beginning of the region. */
3235 if (old_pos
>= XFASTINT (end
))
3236 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3237 else if (old_pos
> XFASTINT (beg
))
3238 old_pos
= XFASTINT (beg
);
3239 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3241 return make_number (inserted_chars
);
3244 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3246 doc
: /* Base64-decode STRING and return the result. */)
3247 (Lisp_Object string
)
3250 ptrdiff_t length
, decoded_length
;
3251 Lisp_Object decoded_string
;
3254 CHECK_STRING (string
);
3256 length
= SBYTES (string
);
3257 /* We need to allocate enough room for decoding the text. */
3258 decoded
= SAFE_ALLOCA (length
);
3260 /* The decoded result should be unibyte. */
3261 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3263 if (decoded_length
> length
)
3265 else if (decoded_length
>= 0)
3266 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3268 decoded_string
= Qnil
;
3271 if (!STRINGP (decoded_string
))
3272 error ("Invalid base64 data");
3274 return decoded_string
;
3277 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3278 MULTIBYTE, the decoded result should be in multibyte
3279 form. If NCHARS_RETURN is not NULL, store the number of produced
3280 characters in *NCHARS_RETURN. */
3283 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3284 bool multibyte
, ptrdiff_t *nchars_return
)
3286 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3289 unsigned long value
;
3290 ptrdiff_t nchars
= 0;
3294 /* Process first byte of a quadruplet. */
3296 READ_QUADRUPLET_BYTE (e
-to
);
3300 value
= base64_char_to_value
[c
] << 18;
3302 /* Process second byte of a quadruplet. */
3304 READ_QUADRUPLET_BYTE (-1);
3308 value
|= base64_char_to_value
[c
] << 12;
3310 c
= (unsigned char) (value
>> 16);
3311 if (multibyte
&& c
>= 128)
3312 e
+= BYTE8_STRING (c
, e
);
3317 /* Process third byte of a quadruplet. */
3319 READ_QUADRUPLET_BYTE (-1);
3323 READ_QUADRUPLET_BYTE (-1);
3332 value
|= base64_char_to_value
[c
] << 6;
3334 c
= (unsigned char) (0xff & value
>> 8);
3335 if (multibyte
&& c
>= 128)
3336 e
+= BYTE8_STRING (c
, e
);
3341 /* Process fourth byte of a quadruplet. */
3343 READ_QUADRUPLET_BYTE (-1);
3350 value
|= base64_char_to_value
[c
];
3352 c
= (unsigned char) (0xff & value
);
3353 if (multibyte
&& c
>= 128)
3354 e
+= BYTE8_STRING (c
, e
);
3363 /***********************************************************************
3365 ***** Hash Tables *****
3367 ***********************************************************************/
3369 /* Implemented by gerd@gnu.org. This hash table implementation was
3370 inspired by CMUCL hash tables. */
3374 1. For small tables, association lists are probably faster than
3375 hash tables because they have lower overhead.
3377 For uses of hash tables where the O(1) behavior of table
3378 operations is not a requirement, it might therefore be a good idea
3379 not to hash. Instead, we could just do a linear search in the
3380 key_and_value vector of the hash table. This could be done
3381 if a `:linear-search t' argument is given to make-hash-table. */
3384 /* The list of all weak hash tables. Don't staticpro this one. */
3386 static struct Lisp_Hash_Table
*weak_hash_tables
;
3388 /* Various symbols. */
3390 static Lisp_Object Qhash_table_p
;
3391 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3392 Lisp_Object Qeq
, Qequal
;
3393 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3394 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3397 /***********************************************************************
3399 ***********************************************************************/
3402 CHECK_HASH_TABLE (Lisp_Object x
)
3404 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3408 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3410 h
->key_and_value
= key_and_value
;
3413 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3418 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3420 gc_aset (h
->next
, idx
, val
);
3423 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3428 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3430 gc_aset (h
->hash
, idx
, val
);
3433 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3438 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3440 gc_aset (h
->index
, idx
, val
);
3443 /* If OBJ is a Lisp hash table, return a pointer to its struct
3444 Lisp_Hash_Table. Otherwise, signal an error. */
3446 static struct Lisp_Hash_Table
*
3447 check_hash_table (Lisp_Object obj
)
3449 CHECK_HASH_TABLE (obj
);
3450 return XHASH_TABLE (obj
);
3454 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3455 number. A number is "almost" a prime number if it is not divisible
3456 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3459 next_almost_prime (EMACS_INT n
)
3461 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3462 for (n
|= 1; ; n
+= 2)
3463 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3468 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3469 which USED[I] is non-zero. If found at index I in ARGS, set
3470 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3471 0. This function is used to extract a keyword/argument pair from
3472 a DEFUN parameter list. */
3475 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3479 for (i
= 1; i
< nargs
; i
++)
3480 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3491 /* Return a Lisp vector which has the same contents as VEC but has
3492 at least INCR_MIN more entries, where INCR_MIN is positive.
3493 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3494 than NITEMS_MAX. Entries in the resulting
3495 vector that are not copied from VEC are set to nil. */
3498 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3500 struct Lisp_Vector
*v
;
3501 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3502 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3503 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3504 ? nitems_max
: C_language_max
);
3505 eassert (VECTORP (vec
));
3506 eassert (0 < incr_min
&& -1 <= nitems_max
);
3507 old_size
= ASIZE (vec
);
3508 incr_max
= n_max
- old_size
;
3509 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3510 if (incr_max
< incr
)
3511 memory_full (SIZE_MAX
);
3512 new_size
= old_size
+ incr
;
3513 v
= allocate_vector (new_size
);
3514 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3515 for (i
= old_size
; i
< new_size
; ++i
)
3516 v
->contents
[i
] = Qnil
;
3517 XSETVECTOR (vec
, v
);
3522 /***********************************************************************
3524 ***********************************************************************/
3526 static struct hash_table_test hashtest_eq
;
3527 struct hash_table_test hashtest_eql
, hashtest_equal
;
3529 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3530 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3531 KEY2 are the same. */
3534 cmpfn_eql (struct hash_table_test
*ht
,
3538 return (FLOATP (key1
)
3540 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3544 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3545 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3546 KEY2 are the same. */
3549 cmpfn_equal (struct hash_table_test
*ht
,
3553 return !NILP (Fequal (key1
, key2
));
3557 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3558 HASH2 in hash table H using H->user_cmp_function. Value is true
3559 if KEY1 and KEY2 are the same. */
3562 cmpfn_user_defined (struct hash_table_test
*ht
,
3566 Lisp_Object args
[3];
3568 args
[0] = ht
->user_cmp_function
;
3571 return !NILP (Ffuncall (3, args
));
3575 /* Value is a hash code for KEY for use in hash table H which uses
3576 `eq' to compare keys. The hash code returned is guaranteed to fit
3577 in a Lisp integer. */
3580 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3582 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3586 /* Value is a hash code for KEY for use in hash table H which uses
3587 `eql' to compare keys. The hash code returned is guaranteed to fit
3588 in a Lisp integer. */
3591 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3595 hash
= sxhash (key
, 0);
3597 hash
= XHASH (key
) ^ XTYPE (key
);
3601 /* Value is a hash code for KEY for use in hash table H which uses
3602 `equal' to compare keys. The hash code returned is guaranteed to fit
3603 in a Lisp integer. */
3606 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3608 EMACS_UINT hash
= sxhash (key
, 0);
3612 /* Value is a hash code for KEY for use in hash table H which uses as
3613 user-defined function to compare keys. The hash code returned is
3614 guaranteed to fit in a Lisp integer. */
3617 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3619 Lisp_Object args
[2], hash
;
3621 args
[0] = ht
->user_hash_function
;
3623 hash
= Ffuncall (2, args
);
3624 return hashfn_eq (ht
, hash
);
3627 /* An upper bound on the size of a hash table index. It must fit in
3628 ptrdiff_t and be a valid Emacs fixnum. */
3629 #define INDEX_SIZE_BOUND \
3630 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3632 /* Create and initialize a new hash table.
3634 TEST specifies the test the hash table will use to compare keys.
3635 It must be either one of the predefined tests `eq', `eql' or
3636 `equal' or a symbol denoting a user-defined test named TEST with
3637 test and hash functions USER_TEST and USER_HASH.
3639 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3641 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3642 new size when it becomes full is computed by adding REHASH_SIZE to
3643 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3644 table's new size is computed by multiplying its old size with
3647 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3648 be resized when the ratio of (number of entries in the table) /
3649 (table size) is >= REHASH_THRESHOLD.
3651 WEAK specifies the weakness of the table. If non-nil, it must be
3652 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3655 make_hash_table (struct hash_table_test test
,
3656 Lisp_Object size
, Lisp_Object rehash_size
,
3657 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3659 struct Lisp_Hash_Table
*h
;
3661 EMACS_INT index_size
, sz
;
3665 /* Preconditions. */
3666 eassert (SYMBOLP (test
.name
));
3667 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3668 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3669 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3670 eassert (FLOATP (rehash_threshold
)
3671 && 0 < XFLOAT_DATA (rehash_threshold
)
3672 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3674 if (XFASTINT (size
) == 0)
3675 size
= make_number (1);
3677 sz
= XFASTINT (size
);
3678 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3679 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3680 ? next_almost_prime (index_float
)
3681 : INDEX_SIZE_BOUND
+ 1);
3682 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3683 error ("Hash table too large");
3685 /* Allocate a table and initialize it. */
3686 h
= allocate_hash_table ();
3688 /* Initialize hash table slots. */
3691 h
->rehash_threshold
= rehash_threshold
;
3692 h
->rehash_size
= rehash_size
;
3694 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3695 h
->hash
= Fmake_vector (size
, Qnil
);
3696 h
->next
= Fmake_vector (size
, Qnil
);
3697 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3699 /* Set up the free list. */
3700 for (i
= 0; i
< sz
- 1; ++i
)
3701 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3702 h
->next_free
= make_number (0);
3704 XSET_HASH_TABLE (table
, h
);
3705 eassert (HASH_TABLE_P (table
));
3706 eassert (XHASH_TABLE (table
) == h
);
3708 /* Maybe add this hash table to the list of all weak hash tables. */
3710 h
->next_weak
= NULL
;
3713 h
->next_weak
= weak_hash_tables
;
3714 weak_hash_tables
= h
;
3721 /* Return a copy of hash table H1. Keys and values are not copied,
3722 only the table itself is. */
3725 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3728 struct Lisp_Hash_Table
*h2
;
3730 h2
= allocate_hash_table ();
3732 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3733 h2
->hash
= Fcopy_sequence (h1
->hash
);
3734 h2
->next
= Fcopy_sequence (h1
->next
);
3735 h2
->index
= Fcopy_sequence (h1
->index
);
3736 XSET_HASH_TABLE (table
, h2
);
3738 /* Maybe add this hash table to the list of all weak hash tables. */
3739 if (!NILP (h2
->weak
))
3741 h2
->next_weak
= weak_hash_tables
;
3742 weak_hash_tables
= h2
;
3749 /* Resize hash table H if it's too full. If H cannot be resized
3750 because it's already too large, throw an error. */
3753 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3755 if (NILP (h
->next_free
))
3757 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3758 EMACS_INT new_size
, index_size
, nsize
;
3762 if (INTEGERP (h
->rehash_size
))
3763 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3766 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3767 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3769 new_size
= float_new_size
;
3770 if (new_size
<= old_size
)
3771 new_size
= old_size
+ 1;
3774 new_size
= INDEX_SIZE_BOUND
+ 1;
3776 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3777 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3778 ? next_almost_prime (index_float
)
3779 : INDEX_SIZE_BOUND
+ 1);
3780 nsize
= max (index_size
, 2 * new_size
);
3781 if (INDEX_SIZE_BOUND
< nsize
)
3782 error ("Hash table too large to resize");
3784 #ifdef ENABLE_CHECKING
3785 if (HASH_TABLE_P (Vpurify_flag
)
3786 && XHASH_TABLE (Vpurify_flag
) == h
)
3788 Lisp_Object args
[2];
3789 args
[0] = build_string ("Growing hash table to: %d");
3790 args
[1] = make_number (new_size
);
3795 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3796 2 * (new_size
- old_size
), -1));
3797 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3798 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3799 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3801 /* Update the free list. Do it so that new entries are added at
3802 the end of the free list. This makes some operations like
3804 for (i
= old_size
; i
< new_size
- 1; ++i
)
3805 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3807 if (!NILP (h
->next_free
))
3809 Lisp_Object last
, next
;
3811 last
= h
->next_free
;
3812 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3816 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3819 XSETFASTINT (h
->next_free
, old_size
);
3822 for (i
= 0; i
< old_size
; ++i
)
3823 if (!NILP (HASH_HASH (h
, i
)))
3825 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3826 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3827 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3828 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3834 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3835 the hash code of KEY. Value is the index of the entry in H
3836 matching KEY, or -1 if not found. */
3839 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3841 EMACS_UINT hash_code
;
3842 ptrdiff_t start_of_bucket
;
3845 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3846 eassert ((hash_code
& ~INTMASK
) == 0);
3850 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3851 idx
= HASH_INDEX (h
, start_of_bucket
);
3853 /* We need not gcpro idx since it's either an integer or nil. */
3856 ptrdiff_t i
= XFASTINT (idx
);
3857 if (EQ (key
, HASH_KEY (h
, i
))
3859 && hash_code
== XUINT (HASH_HASH (h
, i
))
3860 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3862 idx
= HASH_NEXT (h
, i
);
3865 return NILP (idx
) ? -1 : XFASTINT (idx
);
3869 /* Put an entry into hash table H that associates KEY with VALUE.
3870 HASH is a previously computed hash code of KEY.
3871 Value is the index of the entry in H matching KEY. */
3874 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3877 ptrdiff_t start_of_bucket
, i
;
3879 eassert ((hash
& ~INTMASK
) == 0);
3881 /* Increment count after resizing because resizing may fail. */
3882 maybe_resize_hash_table (h
);
3885 /* Store key/value in the key_and_value vector. */
3886 i
= XFASTINT (h
->next_free
);
3887 h
->next_free
= HASH_NEXT (h
, i
);
3888 set_hash_key_slot (h
, i
, key
);
3889 set_hash_value_slot (h
, i
, value
);
3891 /* Remember its hash code. */
3892 set_hash_hash_slot (h
, i
, make_number (hash
));
3894 /* Add new entry to its collision chain. */
3895 start_of_bucket
= hash
% ASIZE (h
->index
);
3896 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3897 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3902 /* Remove the entry matching KEY from hash table H, if there is one. */
3905 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3907 EMACS_UINT hash_code
;
3908 ptrdiff_t start_of_bucket
;
3909 Lisp_Object idx
, prev
;
3911 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3912 eassert ((hash_code
& ~INTMASK
) == 0);
3913 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3914 idx
= HASH_INDEX (h
, start_of_bucket
);
3917 /* We need not gcpro idx, prev since they're either integers or nil. */
3920 ptrdiff_t i
= XFASTINT (idx
);
3922 if (EQ (key
, HASH_KEY (h
, i
))
3924 && hash_code
== XUINT (HASH_HASH (h
, i
))
3925 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3927 /* Take entry out of collision chain. */
3929 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3931 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3933 /* Clear slots in key_and_value and add the slots to
3935 set_hash_key_slot (h
, i
, Qnil
);
3936 set_hash_value_slot (h
, i
, Qnil
);
3937 set_hash_hash_slot (h
, i
, Qnil
);
3938 set_hash_next_slot (h
, i
, h
->next_free
);
3939 h
->next_free
= make_number (i
);
3941 eassert (h
->count
>= 0);
3947 idx
= HASH_NEXT (h
, i
);
3953 /* Clear hash table H. */
3956 hash_clear (struct Lisp_Hash_Table
*h
)
3960 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3962 for (i
= 0; i
< size
; ++i
)
3964 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3965 set_hash_key_slot (h
, i
, Qnil
);
3966 set_hash_value_slot (h
, i
, Qnil
);
3967 set_hash_hash_slot (h
, i
, Qnil
);
3970 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3971 ASET (h
->index
, i
, Qnil
);
3973 h
->next_free
= make_number (0);
3980 /************************************************************************
3982 ************************************************************************/
3984 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3985 entries from the table that don't survive the current GC.
3986 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3987 true if anything was marked. */
3990 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3992 ptrdiff_t bucket
, n
;
3995 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3998 for (bucket
= 0; bucket
< n
; ++bucket
)
4000 Lisp_Object idx
, next
, prev
;
4002 /* Follow collision chain, removing entries that
4003 don't survive this garbage collection. */
4005 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4007 ptrdiff_t i
= XFASTINT (idx
);
4008 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4009 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4012 if (EQ (h
->weak
, Qkey
))
4013 remove_p
= !key_known_to_survive_p
;
4014 else if (EQ (h
->weak
, Qvalue
))
4015 remove_p
= !value_known_to_survive_p
;
4016 else if (EQ (h
->weak
, Qkey_or_value
))
4017 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4018 else if (EQ (h
->weak
, Qkey_and_value
))
4019 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4023 next
= HASH_NEXT (h
, i
);
4025 if (remove_entries_p
)
4029 /* Take out of collision chain. */
4031 set_hash_index_slot (h
, bucket
, next
);
4033 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4035 /* Add to free list. */
4036 set_hash_next_slot (h
, i
, h
->next_free
);
4039 /* Clear key, value, and hash. */
4040 set_hash_key_slot (h
, i
, Qnil
);
4041 set_hash_value_slot (h
, i
, Qnil
);
4042 set_hash_hash_slot (h
, i
, Qnil
);
4055 /* Make sure key and value survive. */
4056 if (!key_known_to_survive_p
)
4058 mark_object (HASH_KEY (h
, i
));
4062 if (!value_known_to_survive_p
)
4064 mark_object (HASH_VALUE (h
, i
));
4075 /* Remove elements from weak hash tables that don't survive the
4076 current garbage collection. Remove weak tables that don't survive
4077 from Vweak_hash_tables. Called from gc_sweep. */
4079 NO_INLINE
/* For better stack traces */
4081 sweep_weak_hash_tables (void)
4083 struct Lisp_Hash_Table
*h
, *used
, *next
;
4086 /* Mark all keys and values that are in use. Keep on marking until
4087 there is no more change. This is necessary for cases like
4088 value-weak table A containing an entry X -> Y, where Y is used in a
4089 key-weak table B, Z -> Y. If B comes after A in the list of weak
4090 tables, X -> Y might be removed from A, although when looking at B
4091 one finds that it shouldn't. */
4095 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4097 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4098 marked
|= sweep_weak_table (h
, 0);
4103 /* Remove tables and entries that aren't used. */
4104 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4106 next
= h
->next_weak
;
4108 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4110 /* TABLE is marked as used. Sweep its contents. */
4112 sweep_weak_table (h
, 1);
4114 /* Add table to the list of used weak hash tables. */
4115 h
->next_weak
= used
;
4120 weak_hash_tables
= used
;
4125 /***********************************************************************
4126 Hash Code Computation
4127 ***********************************************************************/
4129 /* Maximum depth up to which to dive into Lisp structures. */
4131 #define SXHASH_MAX_DEPTH 3
4133 /* Maximum length up to which to take list and vector elements into
4136 #define SXHASH_MAX_LEN 7
4138 /* Return a hash for string PTR which has length LEN. The hash value
4139 can be any EMACS_UINT value. */
4142 hash_string (char const *ptr
, ptrdiff_t len
)
4144 char const *p
= ptr
;
4145 char const *end
= p
+ len
;
4147 EMACS_UINT hash
= 0;
4152 hash
= sxhash_combine (hash
, c
);
4158 /* Return a hash for string PTR which has length LEN. The hash
4159 code returned is guaranteed to fit in a Lisp integer. */
4162 sxhash_string (char const *ptr
, ptrdiff_t len
)
4164 EMACS_UINT hash
= hash_string (ptr
, len
);
4165 return SXHASH_REDUCE (hash
);
4168 /* Return a hash for the floating point value VAL. */
4171 sxhash_float (double val
)
4173 EMACS_UINT hash
= 0;
4175 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4176 + (sizeof val
% sizeof hash
!= 0))
4180 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4184 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4185 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4186 hash
= sxhash_combine (hash
, u
.word
[i
]);
4187 return SXHASH_REDUCE (hash
);
4190 /* Return a hash for list LIST. DEPTH is the current depth in the
4191 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4194 sxhash_list (Lisp_Object list
, int depth
)
4196 EMACS_UINT hash
= 0;
4199 if (depth
< SXHASH_MAX_DEPTH
)
4201 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4202 list
= XCDR (list
), ++i
)
4204 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4205 hash
= sxhash_combine (hash
, hash2
);
4210 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4211 hash
= sxhash_combine (hash
, hash2
);
4214 return SXHASH_REDUCE (hash
);
4218 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4219 the Lisp structure. */
4222 sxhash_vector (Lisp_Object vec
, int depth
)
4224 EMACS_UINT hash
= ASIZE (vec
);
4227 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4228 for (i
= 0; i
< n
; ++i
)
4230 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4231 hash
= sxhash_combine (hash
, hash2
);
4234 return SXHASH_REDUCE (hash
);
4237 /* Return a hash for bool-vector VECTOR. */
4240 sxhash_bool_vector (Lisp_Object vec
)
4242 EMACS_INT size
= bool_vector_size (vec
);
4243 EMACS_UINT hash
= size
;
4246 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4247 for (i
= 0; i
< n
; ++i
)
4248 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4250 return SXHASH_REDUCE (hash
);
4254 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4255 structure. Value is an unsigned integer clipped to INTMASK. */
4258 sxhash (Lisp_Object obj
, int depth
)
4262 if (depth
> SXHASH_MAX_DEPTH
)
4265 switch (XTYPE (obj
))
4276 obj
= SYMBOL_NAME (obj
);
4280 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4283 /* This can be everything from a vector to an overlay. */
4284 case Lisp_Vectorlike
:
4286 /* According to the CL HyperSpec, two arrays are equal only if
4287 they are `eq', except for strings and bit-vectors. In
4288 Emacs, this works differently. We have to compare element
4290 hash
= sxhash_vector (obj
, depth
);
4291 else if (BOOL_VECTOR_P (obj
))
4292 hash
= sxhash_bool_vector (obj
);
4294 /* Others are `equal' if they are `eq', so let's take their
4300 hash
= sxhash_list (obj
, depth
);
4304 hash
= sxhash_float (XFLOAT_DATA (obj
));
4316 /***********************************************************************
4318 ***********************************************************************/
4321 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4322 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4325 EMACS_UINT hash
= sxhash (obj
, 0);
4326 return make_number (hash
);
4330 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4331 doc
: /* Create and return a new hash table.
4333 Arguments are specified as keyword/argument pairs. The following
4334 arguments are defined:
4336 :test TEST -- TEST must be a symbol that specifies how to compare
4337 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4338 `equal'. User-supplied test and hash functions can be specified via
4339 `define-hash-table-test'.
4341 :size SIZE -- A hint as to how many elements will be put in the table.
4344 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4345 fills up. If REHASH-SIZE is an integer, increase the size by that
4346 amount. If it is a float, it must be > 1.0, and the new size is the
4347 old size multiplied by that factor. Default is 1.5.
4349 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4350 Resize the hash table when the ratio (number of entries / table size)
4351 is greater than or equal to THRESHOLD. Default is 0.8.
4353 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4354 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4355 returned is a weak table. Key/value pairs are removed from a weak
4356 hash table when there are no non-weak references pointing to their
4357 key, value, one of key or value, or both key and value, depending on
4358 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4361 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4362 (ptrdiff_t nargs
, Lisp_Object
*args
)
4364 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4365 struct hash_table_test testdesc
;
4369 /* The vector `used' is used to keep track of arguments that
4370 have been consumed. */
4371 used
= alloca (nargs
* sizeof *used
);
4372 memset (used
, 0, nargs
* sizeof *used
);
4374 /* See if there's a `:test TEST' among the arguments. */
4375 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4376 test
= i
? args
[i
] : Qeql
;
4378 testdesc
= hashtest_eq
;
4379 else if (EQ (test
, Qeql
))
4380 testdesc
= hashtest_eql
;
4381 else if (EQ (test
, Qequal
))
4382 testdesc
= hashtest_equal
;
4385 /* See if it is a user-defined test. */
4388 prop
= Fget (test
, Qhash_table_test
);
4389 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4390 signal_error ("Invalid hash table test", test
);
4391 testdesc
.name
= test
;
4392 testdesc
.user_cmp_function
= XCAR (prop
);
4393 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4394 testdesc
.hashfn
= hashfn_user_defined
;
4395 testdesc
.cmpfn
= cmpfn_user_defined
;
4398 /* See if there's a `:size SIZE' argument. */
4399 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4400 size
= i
? args
[i
] : Qnil
;
4402 size
= make_number (DEFAULT_HASH_SIZE
);
4403 else if (!INTEGERP (size
) || XINT (size
) < 0)
4404 signal_error ("Invalid hash table size", size
);
4406 /* Look for `:rehash-size SIZE'. */
4407 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4408 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4409 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4410 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4411 signal_error ("Invalid hash table rehash size", rehash_size
);
4413 /* Look for `:rehash-threshold THRESHOLD'. */
4414 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4415 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4416 if (! (FLOATP (rehash_threshold
)
4417 && 0 < XFLOAT_DATA (rehash_threshold
)
4418 && XFLOAT_DATA (rehash_threshold
) <= 1))
4419 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4421 /* Look for `:weakness WEAK'. */
4422 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4423 weak
= i
? args
[i
] : Qnil
;
4425 weak
= Qkey_and_value
;
4428 && !EQ (weak
, Qvalue
)
4429 && !EQ (weak
, Qkey_or_value
)
4430 && !EQ (weak
, Qkey_and_value
))
4431 signal_error ("Invalid hash table weakness", weak
);
4433 /* Now, all args should have been used up, or there's a problem. */
4434 for (i
= 0; i
< nargs
; ++i
)
4436 signal_error ("Invalid argument list", args
[i
]);
4438 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4442 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4443 doc
: /* Return a copy of hash table TABLE. */)
4446 return copy_hash_table (check_hash_table (table
));
4450 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4451 doc
: /* Return the number of elements in TABLE. */)
4454 return make_number (check_hash_table (table
)->count
);
4458 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4459 Shash_table_rehash_size
, 1, 1, 0,
4460 doc
: /* Return the current rehash size of TABLE. */)
4463 return check_hash_table (table
)->rehash_size
;
4467 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4468 Shash_table_rehash_threshold
, 1, 1, 0,
4469 doc
: /* Return the current rehash threshold of TABLE. */)
4472 return check_hash_table (table
)->rehash_threshold
;
4476 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4477 doc
: /* Return the size of TABLE.
4478 The size can be used as an argument to `make-hash-table' to create
4479 a hash table than can hold as many elements as TABLE holds
4480 without need for resizing. */)
4483 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4484 return make_number (HASH_TABLE_SIZE (h
));
4488 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4489 doc
: /* Return the test TABLE uses. */)
4492 return check_hash_table (table
)->test
.name
;
4496 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4498 doc
: /* Return the weakness of TABLE. */)
4501 return check_hash_table (table
)->weak
;
4505 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4506 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4509 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4513 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4514 doc
: /* Clear hash table TABLE and return it. */)
4517 hash_clear (check_hash_table (table
));
4518 /* Be compatible with XEmacs. */
4523 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4524 doc
: /* Look up KEY in TABLE and return its associated value.
4525 If KEY is not found, return DFLT which defaults to nil. */)
4526 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4528 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4529 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4530 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4534 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4535 doc
: /* Associate KEY with VALUE in hash table TABLE.
4536 If KEY is already present in table, replace its current value with
4537 VALUE. In any case, return VALUE. */)
4538 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4540 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4544 i
= hash_lookup (h
, key
, &hash
);
4546 set_hash_value_slot (h
, i
, value
);
4548 hash_put (h
, key
, value
, hash
);
4554 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4555 doc
: /* Remove KEY from TABLE. */)
4556 (Lisp_Object key
, Lisp_Object table
)
4558 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4559 hash_remove_from_table (h
, key
);
4564 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4565 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4566 FUNCTION is called with two arguments, KEY and VALUE.
4567 `maphash' always returns nil. */)
4568 (Lisp_Object function
, Lisp_Object table
)
4570 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4571 Lisp_Object args
[3];
4574 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4575 if (!NILP (HASH_HASH (h
, i
)))
4578 args
[1] = HASH_KEY (h
, i
);
4579 args
[2] = HASH_VALUE (h
, i
);
4587 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4588 Sdefine_hash_table_test
, 3, 3, 0,
4589 doc
: /* Define a new hash table test with name NAME, a symbol.
4591 In hash tables created with NAME specified as test, use TEST to
4592 compare keys, and HASH for computing hash codes of keys.
4594 TEST must be a function taking two arguments and returning non-nil if
4595 both arguments are the same. HASH must be a function taking one
4596 argument and returning an object that is the hash code of the argument.
4597 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4598 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4599 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4601 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4606 /************************************************************************
4607 MD5, SHA-1, and SHA-2
4608 ************************************************************************/
4615 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4618 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4619 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4623 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4624 register EMACS_INT b
, e
;
4625 register struct buffer
*bp
;
4628 void *(*hash_func
) (const char *, size_t, void *);
4631 CHECK_SYMBOL (algorithm
);
4633 if (STRINGP (object
))
4635 if (NILP (coding_system
))
4637 /* Decide the coding-system to encode the data with. */
4639 if (STRING_MULTIBYTE (object
))
4640 /* use default, we can't guess correct value */
4641 coding_system
= preferred_coding_system ();
4643 coding_system
= Qraw_text
;
4646 if (NILP (Fcoding_system_p (coding_system
)))
4648 /* Invalid coding system. */
4650 if (!NILP (noerror
))
4651 coding_system
= Qraw_text
;
4653 xsignal1 (Qcoding_system_error
, coding_system
);
4656 if (STRING_MULTIBYTE (object
))
4657 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4659 size
= SCHARS (object
);
4660 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4662 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4663 end_byte
= (end_char
== size
4665 : string_char_to_byte (object
, end_char
));
4669 struct buffer
*prev
= current_buffer
;
4671 record_unwind_current_buffer ();
4673 CHECK_BUFFER (object
);
4675 bp
= XBUFFER (object
);
4676 set_buffer_internal (bp
);
4682 CHECK_NUMBER_COERCE_MARKER (start
);
4690 CHECK_NUMBER_COERCE_MARKER (end
);
4695 temp
= b
, b
= e
, e
= temp
;
4697 if (!(BEGV
<= b
&& e
<= ZV
))
4698 args_out_of_range (start
, end
);
4700 if (NILP (coding_system
))
4702 /* Decide the coding-system to encode the data with.
4703 See fileio.c:Fwrite-region */
4705 if (!NILP (Vcoding_system_for_write
))
4706 coding_system
= Vcoding_system_for_write
;
4709 bool force_raw_text
= 0;
4711 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4712 if (NILP (coding_system
)
4713 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4715 coding_system
= Qnil
;
4716 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4720 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4722 /* Check file-coding-system-alist. */
4723 Lisp_Object args
[4], val
;
4725 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4726 args
[3] = Fbuffer_file_name (object
);
4727 val
= Ffind_operation_coding_system (4, args
);
4728 if (CONSP (val
) && !NILP (XCDR (val
)))
4729 coding_system
= XCDR (val
);
4732 if (NILP (coding_system
)
4733 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4735 /* If we still have not decided a coding system, use the
4736 default value of buffer-file-coding-system. */
4737 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4741 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4742 /* Confirm that VAL can surely encode the current region. */
4743 coding_system
= call4 (Vselect_safe_coding_system_function
,
4744 make_number (b
), make_number (e
),
4745 coding_system
, Qnil
);
4748 coding_system
= Qraw_text
;
4751 if (NILP (Fcoding_system_p (coding_system
)))
4753 /* Invalid coding system. */
4755 if (!NILP (noerror
))
4756 coding_system
= Qraw_text
;
4758 xsignal1 (Qcoding_system_error
, coding_system
);
4762 object
= make_buffer_string (b
, e
, 0);
4763 set_buffer_internal (prev
);
4764 /* Discard the unwind protect for recovering the current
4768 if (STRING_MULTIBYTE (object
))
4769 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4771 end_byte
= SBYTES (object
);
4774 if (EQ (algorithm
, Qmd5
))
4776 digest_size
= MD5_DIGEST_SIZE
;
4777 hash_func
= md5_buffer
;
4779 else if (EQ (algorithm
, Qsha1
))
4781 digest_size
= SHA1_DIGEST_SIZE
;
4782 hash_func
= sha1_buffer
;
4784 else if (EQ (algorithm
, Qsha224
))
4786 digest_size
= SHA224_DIGEST_SIZE
;
4787 hash_func
= sha224_buffer
;
4789 else if (EQ (algorithm
, Qsha256
))
4791 digest_size
= SHA256_DIGEST_SIZE
;
4792 hash_func
= sha256_buffer
;
4794 else if (EQ (algorithm
, Qsha384
))
4796 digest_size
= SHA384_DIGEST_SIZE
;
4797 hash_func
= sha384_buffer
;
4799 else if (EQ (algorithm
, Qsha512
))
4801 digest_size
= SHA512_DIGEST_SIZE
;
4802 hash_func
= sha512_buffer
;
4805 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4807 /* allocate 2 x digest_size so that it can be re-used to hold the
4809 digest
= make_uninit_string (digest_size
* 2);
4811 hash_func (SSDATA (object
) + start_byte
,
4812 end_byte
- start_byte
,
4817 unsigned char *p
= SDATA (digest
);
4818 for (i
= digest_size
- 1; i
>= 0; i
--)
4820 static char const hexdigit
[16] = "0123456789abcdef";
4822 p
[2 * i
] = hexdigit
[p_i
>> 4];
4823 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4828 return make_unibyte_string (SSDATA (digest
), digest_size
);
4831 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4832 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4834 A message digest is a cryptographic checksum of a document, and the
4835 algorithm to calculate it is defined in RFC 1321.
4837 The two optional arguments START and END are character positions
4838 specifying for which part of OBJECT the message digest should be
4839 computed. If nil or omitted, the digest is computed for the whole
4842 The MD5 message digest is computed from the result of encoding the
4843 text in a coding system, not directly from the internal Emacs form of
4844 the text. The optional fourth argument CODING-SYSTEM specifies which
4845 coding system to encode the text with. It should be the same coding
4846 system that you used or will use when actually writing the text into a
4849 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4850 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4851 system would be chosen by default for writing this text into a file.
4853 If OBJECT is a string, the most preferred coding system (see the
4854 command `prefer-coding-system') is used.
4856 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4857 guesswork fails. Normally, an error is signaled in such case. */)
4858 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4860 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4863 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4864 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4865 ALGORITHM is a symbol specifying the hash to use:
4866 md5, sha1, sha224, sha256, sha384 or sha512.
4868 The two optional arguments START and END are positions specifying for
4869 which part of OBJECT to compute the hash. If nil or omitted, uses the
4872 If BINARY is non-nil, returns a string in binary form. */)
4873 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4875 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4881 DEFSYM (Qmd5
, "md5");
4882 DEFSYM (Qsha1
, "sha1");
4883 DEFSYM (Qsha224
, "sha224");
4884 DEFSYM (Qsha256
, "sha256");
4885 DEFSYM (Qsha384
, "sha384");
4886 DEFSYM (Qsha512
, "sha512");
4888 /* Hash table stuff. */
4889 DEFSYM (Qhash_table_p
, "hash-table-p");
4891 DEFSYM (Qeql
, "eql");
4892 DEFSYM (Qequal
, "equal");
4893 DEFSYM (QCtest
, ":test");
4894 DEFSYM (QCsize
, ":size");
4895 DEFSYM (QCrehash_size
, ":rehash-size");
4896 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4897 DEFSYM (QCweakness
, ":weakness");
4898 DEFSYM (Qkey
, "key");
4899 DEFSYM (Qvalue
, "value");
4900 DEFSYM (Qhash_table_test
, "hash-table-test");
4901 DEFSYM (Qkey_or_value
, "key-or-value");
4902 DEFSYM (Qkey_and_value
, "key-and-value");
4905 defsubr (&Smake_hash_table
);
4906 defsubr (&Scopy_hash_table
);
4907 defsubr (&Shash_table_count
);
4908 defsubr (&Shash_table_rehash_size
);
4909 defsubr (&Shash_table_rehash_threshold
);
4910 defsubr (&Shash_table_size
);
4911 defsubr (&Shash_table_test
);
4912 defsubr (&Shash_table_weakness
);
4913 defsubr (&Shash_table_p
);
4914 defsubr (&Sclrhash
);
4915 defsubr (&Sgethash
);
4916 defsubr (&Sputhash
);
4917 defsubr (&Sremhash
);
4918 defsubr (&Smaphash
);
4919 defsubr (&Sdefine_hash_table_test
);
4921 DEFSYM (Qstring_lessp
, "string-lessp");
4922 DEFSYM (Qprovide
, "provide");
4923 DEFSYM (Qrequire
, "require");
4924 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4925 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4926 DEFSYM (Qwidget_type
, "widget-type");
4928 staticpro (&string_char_byte_cache_string
);
4929 string_char_byte_cache_string
= Qnil
;
4931 require_nesting_list
= Qnil
;
4932 staticpro (&require_nesting_list
);
4934 Fset (Qyes_or_no_p_history
, Qnil
);
4936 DEFVAR_LISP ("features", Vfeatures
,
4937 doc
: /* A list of symbols which are the features of the executing Emacs.
4938 Used by `featurep' and `require', and altered by `provide'. */);
4939 Vfeatures
= list1 (intern_c_string ("emacs"));
4940 DEFSYM (Qsubfeatures
, "subfeatures");
4941 DEFSYM (Qfuncall
, "funcall");
4943 #ifdef HAVE_LANGINFO_CODESET
4944 DEFSYM (Qcodeset
, "codeset");
4945 DEFSYM (Qdays
, "days");
4946 DEFSYM (Qmonths
, "months");
4947 DEFSYM (Qpaper
, "paper");
4948 #endif /* HAVE_LANGINFO_CODESET */
4950 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4951 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4952 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4953 invoked by mouse clicks and mouse menu items.
4955 On some platforms, file selection dialogs are also enabled if this is
4959 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4960 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4961 This applies to commands from menus and tool bar buttons even when
4962 they are initiated from the keyboard. If `use-dialog-box' is nil,
4963 that disables the use of a file dialog, regardless of the value of
4965 use_file_dialog
= 1;
4967 defsubr (&Sidentity
);
4970 defsubr (&Ssafe_length
);
4971 defsubr (&Sstring_bytes
);
4972 defsubr (&Sstring_equal
);
4973 defsubr (&Scompare_strings
);
4974 defsubr (&Sstring_lessp
);
4977 defsubr (&Svconcat
);
4978 defsubr (&Scopy_sequence
);
4979 defsubr (&Sstring_make_multibyte
);
4980 defsubr (&Sstring_make_unibyte
);
4981 defsubr (&Sstring_as_multibyte
);
4982 defsubr (&Sstring_as_unibyte
);
4983 defsubr (&Sstring_to_multibyte
);
4984 defsubr (&Sstring_to_unibyte
);
4985 defsubr (&Scopy_alist
);
4986 defsubr (&Ssubstring
);
4987 defsubr (&Ssubstring_no_properties
);
5000 defsubr (&Snreverse
);
5001 defsubr (&Sreverse
);
5003 defsubr (&Splist_get
);
5005 defsubr (&Splist_put
);
5007 defsubr (&Slax_plist_get
);
5008 defsubr (&Slax_plist_put
);
5011 defsubr (&Sequal_including_properties
);
5012 defsubr (&Sfillarray
);
5013 defsubr (&Sclear_string
);
5017 defsubr (&Smapconcat
);
5018 defsubr (&Syes_or_no_p
);
5019 defsubr (&Sload_average
);
5020 defsubr (&Sfeaturep
);
5021 defsubr (&Srequire
);
5022 defsubr (&Sprovide
);
5023 defsubr (&Splist_member
);
5024 defsubr (&Swidget_put
);
5025 defsubr (&Swidget_get
);
5026 defsubr (&Swidget_apply
);
5027 defsubr (&Sbase64_encode_region
);
5028 defsubr (&Sbase64_decode_region
);
5029 defsubr (&Sbase64_encode_string
);
5030 defsubr (&Sbase64_decode_string
);
5032 defsubr (&Ssecure_hash
);
5033 defsubr (&Slocale_info
);
5035 hashtest_eq
.name
= Qeq
;
5036 hashtest_eq
.user_hash_function
= Qnil
;
5037 hashtest_eq
.user_cmp_function
= Qnil
;
5038 hashtest_eq
.cmpfn
= 0;
5039 hashtest_eq
.hashfn
= hashfn_eq
;
5041 hashtest_eql
.name
= Qeql
;
5042 hashtest_eql
.user_hash_function
= Qnil
;
5043 hashtest_eql
.user_cmp_function
= Qnil
;
5044 hashtest_eql
.cmpfn
= cmpfn_eql
;
5045 hashtest_eql
.hashfn
= hashfn_eql
;
5047 hashtest_equal
.name
= Qequal
;
5048 hashtest_equal
.user_hash_function
= Qnil
;
5049 hashtest_equal
.user_cmp_function
= Qnil
;
5050 hashtest_equal
.cmpfn
= cmpfn_equal
;
5051 hashtest_equal
.hashfn
= hashfn_equal
;