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.
236 The strings are compared by the numeric values of their characters.
237 For instance, STR1 is "less than" STR2 if its first differing
238 character has a smaller numeric value. If IGNORE-CASE is non-nil,
239 characters are converted to lower-case before comparing them. Unibyte
240 strings are converted to multibyte for comparison.
242 The value is t if the strings (or specified portions) match.
243 If string STR1 is less, the value is a negative number N;
244 - 1 - N is the number of characters that match at the beginning.
245 If string STR1 is greater, the value is a positive number N;
246 N - 1 is the number of characters that match at the beginning. */)
247 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
249 register ptrdiff_t end1_char
, end2_char
;
250 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
255 start1
= make_number (0);
257 start2
= make_number (0);
258 CHECK_NATNUM (start1
);
259 CHECK_NATNUM (start2
);
265 end1_char
= SCHARS (str1
);
266 if (! NILP (end1
) && end1_char
> XINT (end1
))
267 end1_char
= XINT (end1
);
268 if (end1_char
< XINT (start1
))
269 args_out_of_range (str1
, start1
);
271 end2_char
= SCHARS (str2
);
272 if (! NILP (end2
) && end2_char
> XINT (end2
))
273 end2_char
= XINT (end2
);
274 if (end2_char
< XINT (start2
))
275 args_out_of_range (str2
, start2
);
280 i1_byte
= string_char_to_byte (str1
, i1
);
281 i2_byte
= string_char_to_byte (str2
, i2
);
283 while (i1
< end1_char
&& i2
< end2_char
)
285 /* When we find a mismatch, we must compare the
286 characters, not just the bytes. */
289 if (STRING_MULTIBYTE (str1
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
293 c1
= SREF (str1
, i1
++);
294 MAKE_CHAR_MULTIBYTE (c1
);
297 if (STRING_MULTIBYTE (str2
))
298 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
301 c2
= SREF (str2
, i2
++);
302 MAKE_CHAR_MULTIBYTE (c2
);
308 if (! NILP (ignore_case
))
312 tem
= Fupcase (make_number (c1
));
314 tem
= Fupcase (make_number (c2
));
321 /* Note that I1 has already been incremented
322 past the character that we are comparing;
323 hence we don't add or subtract 1 here. */
325 return make_number (- i1
+ XINT (start1
));
327 return make_number (i1
- XINT (start1
));
331 return make_number (i1
- XINT (start1
) + 1);
333 return make_number (- i1
+ XINT (start1
) - 1);
338 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
339 doc
: /* Return t if first arg string is less than second in lexicographic order.
341 Symbols are also allowed; their print names are used instead. */)
342 (register Lisp_Object s1
, Lisp_Object s2
)
344 register ptrdiff_t end
;
345 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
348 s1
= SYMBOL_NAME (s1
);
350 s2
= SYMBOL_NAME (s2
);
354 i1
= i1_byte
= i2
= i2_byte
= 0;
357 if (end
> SCHARS (s2
))
362 /* When we find a mismatch, we must compare the
363 characters, not just the bytes. */
366 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
367 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
370 return c1
< c2
? Qt
: Qnil
;
372 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
375 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
376 enum Lisp_Type target_type
, bool last_special
);
380 concat2 (Lisp_Object s1
, Lisp_Object s2
)
385 return concat (2, args
, Lisp_String
, 0);
390 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
396 return concat (3, args
, Lisp_String
, 0);
399 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
400 doc
: /* Concatenate all the arguments and make the result a list.
401 The result is a list whose elements are the elements of all the arguments.
402 Each argument may be a list, vector or string.
403 The last argument is not copied, just used as the tail of the new list.
404 usage: (append &rest SEQUENCES) */)
405 (ptrdiff_t nargs
, Lisp_Object
*args
)
407 return concat (nargs
, args
, Lisp_Cons
, 1);
410 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
411 doc
: /* Concatenate all the arguments and make the result a string.
412 The result is a string whose elements are the elements of all the arguments.
413 Each argument may be a string or a list or vector of characters (integers).
414 usage: (concat &rest SEQUENCES) */)
415 (ptrdiff_t nargs
, Lisp_Object
*args
)
417 return concat (nargs
, args
, Lisp_String
, 0);
420 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
421 doc
: /* Concatenate all the arguments and make the result a vector.
422 The result is a vector whose elements are the elements of all the arguments.
423 Each argument may be a list, vector or string.
424 usage: (vconcat &rest SEQUENCES) */)
425 (ptrdiff_t nargs
, Lisp_Object
*args
)
427 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
431 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
432 doc
: /* Return a copy of a list, vector, string or char-table.
433 The elements of a list or vector are not copied; they are shared
434 with the original. */)
437 if (NILP (arg
)) return arg
;
439 if (CHAR_TABLE_P (arg
))
441 return copy_char_table (arg
);
444 if (BOOL_VECTOR_P (arg
))
446 EMACS_INT nbits
= bool_vector_size (arg
);
447 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
448 Lisp_Object val
= make_uninit_bool_vector (nbits
);
449 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
453 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
454 wrong_type_argument (Qsequencep
, arg
);
456 return concat (1, &arg
, XTYPE (arg
), 0);
459 /* This structure holds information of an argument of `concat' that is
460 a string and has text properties to be copied. */
463 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
464 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
465 ptrdiff_t to
; /* refer to VAL (the target string) */
469 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
470 enum Lisp_Type target_type
, bool last_special
)
476 ptrdiff_t toindex_byte
= 0;
477 EMACS_INT result_len
;
478 EMACS_INT result_len_byte
;
480 Lisp_Object last_tail
;
483 /* When we make a multibyte string, we can't copy text properties
484 while concatenating each string because the length of resulting
485 string can't be decided until we finish the whole concatenation.
486 So, we record strings that have text properties to be copied
487 here, and copy the text properties after the concatenation. */
488 struct textprop_rec
*textprops
= NULL
;
489 /* Number of elements in textprops. */
490 ptrdiff_t num_textprops
= 0;
495 /* In append, the last arg isn't treated like the others */
496 if (last_special
&& nargs
> 0)
499 last_tail
= args
[nargs
];
504 /* Check each argument. */
505 for (argnum
= 0; argnum
< nargs
; argnum
++)
508 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
509 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
510 wrong_type_argument (Qsequencep
, this);
513 /* Compute total length in chars of arguments in RESULT_LEN.
514 If desired output is a string, also compute length in bytes
515 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
516 whether the result should be a multibyte string. */
520 for (argnum
= 0; argnum
< nargs
; argnum
++)
524 len
= XFASTINT (Flength (this));
525 if (target_type
== Lisp_String
)
527 /* We must count the number of bytes needed in the string
528 as well as the number of characters. */
532 ptrdiff_t this_len_byte
;
534 if (VECTORP (this) || COMPILEDP (this))
535 for (i
= 0; i
< len
; i
++)
538 CHECK_CHARACTER (ch
);
540 this_len_byte
= CHAR_BYTES (c
);
541 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
543 result_len_byte
+= this_len_byte
;
544 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
547 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
548 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
549 else if (CONSP (this))
550 for (; CONSP (this); this = XCDR (this))
553 CHECK_CHARACTER (ch
);
555 this_len_byte
= CHAR_BYTES (c
);
556 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
558 result_len_byte
+= this_len_byte
;
559 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
562 else if (STRINGP (this))
564 if (STRING_MULTIBYTE (this))
567 this_len_byte
= SBYTES (this);
570 this_len_byte
= count_size_as_multibyte (SDATA (this),
572 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
574 result_len_byte
+= this_len_byte
;
579 if (MOST_POSITIVE_FIXNUM
< result_len
)
580 memory_full (SIZE_MAX
);
583 if (! some_multibyte
)
584 result_len_byte
= result_len
;
586 /* Create the output object. */
587 if (target_type
== Lisp_Cons
)
588 val
= Fmake_list (make_number (result_len
), Qnil
);
589 else if (target_type
== Lisp_Vectorlike
)
590 val
= Fmake_vector (make_number (result_len
), Qnil
);
591 else if (some_multibyte
)
592 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
594 val
= make_uninit_string (result_len
);
596 /* In `append', if all but last arg are nil, return last arg. */
597 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
600 /* Copy the contents of the args into the result. */
602 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
604 toindex
= 0, toindex_byte
= 0;
608 SAFE_NALLOCA (textprops
, 1, nargs
);
610 for (argnum
= 0; argnum
< nargs
; argnum
++)
613 ptrdiff_t thisleni
= 0;
614 register ptrdiff_t thisindex
= 0;
615 register ptrdiff_t thisindex_byte
= 0;
619 thislen
= Flength (this), thisleni
= XINT (thislen
);
621 /* Between strings of the same kind, copy fast. */
622 if (STRINGP (this) && STRINGP (val
)
623 && STRING_MULTIBYTE (this) == some_multibyte
)
625 ptrdiff_t thislen_byte
= SBYTES (this);
627 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
628 if (string_intervals (this))
630 textprops
[num_textprops
].argnum
= argnum
;
631 textprops
[num_textprops
].from
= 0;
632 textprops
[num_textprops
++].to
= toindex
;
634 toindex_byte
+= thislen_byte
;
637 /* Copy a single-byte string to a multibyte string. */
638 else if (STRINGP (this) && STRINGP (val
))
640 if (string_intervals (this))
642 textprops
[num_textprops
].argnum
= argnum
;
643 textprops
[num_textprops
].from
= 0;
644 textprops
[num_textprops
++].to
= toindex
;
646 toindex_byte
+= copy_text (SDATA (this),
647 SDATA (val
) + toindex_byte
,
648 SCHARS (this), 0, 1);
652 /* Copy element by element. */
655 register Lisp_Object elt
;
657 /* Fetch next element of `this' arg into `elt', or break if
658 `this' is exhausted. */
659 if (NILP (this)) break;
661 elt
= XCAR (this), this = XCDR (this);
662 else if (thisindex
>= thisleni
)
664 else if (STRINGP (this))
667 if (STRING_MULTIBYTE (this))
668 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
673 c
= SREF (this, thisindex
); thisindex
++;
674 if (some_multibyte
&& !ASCII_CHAR_P (c
))
675 c
= BYTE8_TO_CHAR (c
);
677 XSETFASTINT (elt
, c
);
679 else if (BOOL_VECTOR_P (this))
681 elt
= bool_vector_ref (this, thisindex
);
686 elt
= AREF (this, thisindex
);
690 /* Store this element into the result. */
697 else if (VECTORP (val
))
699 ASET (val
, toindex
, elt
);
705 CHECK_CHARACTER (elt
);
708 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
710 SSET (val
, toindex_byte
++, c
);
716 XSETCDR (prev
, last_tail
);
718 if (num_textprops
> 0)
721 ptrdiff_t last_to_end
= -1;
723 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
725 this = args
[textprops
[argnum
].argnum
];
726 props
= text_property_list (this,
728 make_number (SCHARS (this)),
730 /* If successive arguments have properties, be sure that the
731 value of `composition' property be the copy. */
732 if (last_to_end
== textprops
[argnum
].to
)
733 make_composition_value_copy (props
);
734 add_text_properties_from_list (val
, props
,
735 make_number (textprops
[argnum
].to
));
736 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
744 static Lisp_Object string_char_byte_cache_string
;
745 static ptrdiff_t string_char_byte_cache_charpos
;
746 static ptrdiff_t string_char_byte_cache_bytepos
;
749 clear_string_char_byte_cache (void)
751 string_char_byte_cache_string
= Qnil
;
754 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
757 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
760 ptrdiff_t best_below
, best_below_byte
;
761 ptrdiff_t best_above
, best_above_byte
;
763 best_below
= best_below_byte
= 0;
764 best_above
= SCHARS (string
);
765 best_above_byte
= SBYTES (string
);
766 if (best_above
== best_above_byte
)
769 if (EQ (string
, string_char_byte_cache_string
))
771 if (string_char_byte_cache_charpos
< char_index
)
773 best_below
= string_char_byte_cache_charpos
;
774 best_below_byte
= string_char_byte_cache_bytepos
;
778 best_above
= string_char_byte_cache_charpos
;
779 best_above_byte
= string_char_byte_cache_bytepos
;
783 if (char_index
- best_below
< best_above
- char_index
)
785 unsigned char *p
= SDATA (string
) + best_below_byte
;
787 while (best_below
< char_index
)
789 p
+= BYTES_BY_CHAR_HEAD (*p
);
792 i_byte
= p
- SDATA (string
);
796 unsigned char *p
= SDATA (string
) + best_above_byte
;
798 while (best_above
> char_index
)
801 while (!CHAR_HEAD_P (*p
)) p
--;
804 i_byte
= p
- SDATA (string
);
807 string_char_byte_cache_bytepos
= i_byte
;
808 string_char_byte_cache_charpos
= char_index
;
809 string_char_byte_cache_string
= string
;
814 /* Return the character index corresponding to BYTE_INDEX in STRING. */
817 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
820 ptrdiff_t best_below
, best_below_byte
;
821 ptrdiff_t best_above
, best_above_byte
;
823 best_below
= best_below_byte
= 0;
824 best_above
= SCHARS (string
);
825 best_above_byte
= SBYTES (string
);
826 if (best_above
== best_above_byte
)
829 if (EQ (string
, string_char_byte_cache_string
))
831 if (string_char_byte_cache_bytepos
< byte_index
)
833 best_below
= string_char_byte_cache_charpos
;
834 best_below_byte
= string_char_byte_cache_bytepos
;
838 best_above
= string_char_byte_cache_charpos
;
839 best_above_byte
= string_char_byte_cache_bytepos
;
843 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
845 unsigned char *p
= SDATA (string
) + best_below_byte
;
846 unsigned char *pend
= SDATA (string
) + byte_index
;
850 p
+= BYTES_BY_CHAR_HEAD (*p
);
854 i_byte
= p
- SDATA (string
);
858 unsigned char *p
= SDATA (string
) + best_above_byte
;
859 unsigned char *pbeg
= SDATA (string
) + byte_index
;
864 while (!CHAR_HEAD_P (*p
)) p
--;
868 i_byte
= p
- SDATA (string
);
871 string_char_byte_cache_bytepos
= i_byte
;
872 string_char_byte_cache_charpos
= i
;
873 string_char_byte_cache_string
= string
;
878 /* Convert STRING to a multibyte string. */
881 string_make_multibyte (Lisp_Object string
)
888 if (STRING_MULTIBYTE (string
))
891 nbytes
= count_size_as_multibyte (SDATA (string
),
893 /* If all the chars are ASCII, they won't need any more bytes
894 once converted. In that case, we can return STRING itself. */
895 if (nbytes
== SBYTES (string
))
898 buf
= SAFE_ALLOCA (nbytes
);
899 copy_text (SDATA (string
), buf
, SBYTES (string
),
902 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
909 /* Convert STRING (if unibyte) to a multibyte string without changing
910 the number of characters. Characters 0200 trough 0237 are
911 converted to eight-bit characters. */
914 string_to_multibyte (Lisp_Object string
)
921 if (STRING_MULTIBYTE (string
))
924 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
925 /* If all the chars are ASCII, they won't need any more bytes once
927 if (nbytes
== SBYTES (string
))
928 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
930 buf
= SAFE_ALLOCA (nbytes
);
931 memcpy (buf
, SDATA (string
), SBYTES (string
));
932 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
934 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
941 /* Convert STRING to a single-byte string. */
944 string_make_unibyte (Lisp_Object string
)
951 if (! STRING_MULTIBYTE (string
))
954 nchars
= SCHARS (string
);
956 buf
= SAFE_ALLOCA (nchars
);
957 copy_text (SDATA (string
), buf
, SBYTES (string
),
960 ret
= make_unibyte_string ((char *) buf
, nchars
);
966 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
968 doc
: /* Return the multibyte equivalent of STRING.
969 If STRING is unibyte and contains non-ASCII characters, the function
970 `unibyte-char-to-multibyte' is used to convert each unibyte character
971 to a multibyte character. In this case, the returned string is a
972 newly created string with no text properties. If STRING is multibyte
973 or entirely ASCII, it is returned unchanged. In particular, when
974 STRING is unibyte and entirely ASCII, the returned string is unibyte.
975 \(When the characters are all ASCII, Emacs primitives will treat the
976 string the same way whether it is unibyte or multibyte.) */)
979 CHECK_STRING (string
);
981 return string_make_multibyte (string
);
984 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
986 doc
: /* Return the unibyte equivalent of STRING.
987 Multibyte character codes are converted to unibyte according to
988 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
989 If the lookup in the translation table fails, this function takes just
990 the low 8 bits of each character. */)
993 CHECK_STRING (string
);
995 return string_make_unibyte (string
);
998 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1000 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1001 If STRING is unibyte, the result is STRING itself.
1002 Otherwise it is a newly created string, with no text properties.
1003 If STRING is multibyte and contains a character of charset
1004 `eight-bit', it is converted to the corresponding single byte. */)
1005 (Lisp_Object string
)
1007 CHECK_STRING (string
);
1009 if (STRING_MULTIBYTE (string
))
1011 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1012 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1014 string
= make_unibyte_string ((char *) str
, bytes
);
1020 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1022 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1023 If STRING is multibyte, the result is STRING itself.
1024 Otherwise it is a newly created string, with no text properties.
1026 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1027 part of a correct utf-8 sequence), it is converted to the corresponding
1028 multibyte character of charset `eight-bit'.
1029 See also `string-to-multibyte'.
1031 Beware, this often doesn't really do what you think it does.
1032 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1033 If you're not sure, whether to use `string-as-multibyte' or
1034 `string-to-multibyte', use `string-to-multibyte'. */)
1035 (Lisp_Object string
)
1037 CHECK_STRING (string
);
1039 if (! STRING_MULTIBYTE (string
))
1041 Lisp_Object new_string
;
1042 ptrdiff_t nchars
, nbytes
;
1044 parse_str_as_multibyte (SDATA (string
),
1047 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1048 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1049 if (nbytes
!= SBYTES (string
))
1050 str_as_multibyte (SDATA (new_string
), nbytes
,
1051 SBYTES (string
), NULL
);
1052 string
= new_string
;
1053 set_string_intervals (string
, NULL
);
1058 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1060 doc
: /* Return a multibyte string with the same individual chars as STRING.
1061 If STRING is multibyte, the result is STRING itself.
1062 Otherwise it is a newly created string, with no text properties.
1064 If STRING is unibyte and contains an 8-bit byte, it is converted to
1065 the corresponding multibyte character of charset `eight-bit'.
1067 This differs from `string-as-multibyte' by converting each byte of a correct
1068 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1069 correct sequence. */)
1070 (Lisp_Object string
)
1072 CHECK_STRING (string
);
1074 return string_to_multibyte (string
);
1077 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1079 doc
: /* Return a unibyte string with the same individual chars as STRING.
1080 If STRING is unibyte, the result is STRING itself.
1081 Otherwise it is a newly created string, with no text properties,
1082 where each `eight-bit' character is converted to the corresponding byte.
1083 If STRING contains a non-ASCII, non-`eight-bit' character,
1084 an error is signaled. */)
1085 (Lisp_Object string
)
1087 CHECK_STRING (string
);
1089 if (STRING_MULTIBYTE (string
))
1091 ptrdiff_t chars
= SCHARS (string
);
1092 unsigned char *str
= xmalloc (chars
);
1093 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1095 if (converted
< chars
)
1096 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1097 string
= make_unibyte_string ((char *) str
, chars
);
1104 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1105 doc
: /* Return a copy of ALIST.
1106 This is an alist which represents the same mapping from objects to objects,
1107 but does not share the alist structure with ALIST.
1108 The objects mapped (cars and cdrs of elements of the alist)
1109 are shared, however.
1110 Elements of ALIST that are not conses are also shared. */)
1113 register Lisp_Object tem
;
1118 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1119 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1121 register Lisp_Object car
;
1125 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1130 /* Check that ARRAY can have a valid subarray [FROM..TO),
1131 given that its size is SIZE.
1132 If FROM is nil, use 0; if TO is nil, use SIZE.
1133 Count negative values backwards from the end.
1134 Set *IFROM and *ITO to the two indexes used. */
1137 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1138 ptrdiff_t size
, EMACS_INT
*ifrom
, EMACS_INT
*ito
)
1142 if (INTEGERP (from
))
1148 else if (NILP (from
))
1151 wrong_type_argument (Qintegerp
, from
);
1162 wrong_type_argument (Qintegerp
, to
);
1164 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1165 args_out_of_range_3 (array
, from
, to
);
1171 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1172 doc
: /* Return a new string whose contents are a substring of STRING.
1173 The returned string consists of the characters between index FROM
1174 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1175 zero-indexed: 0 means the first character of STRING. Negative values
1176 are counted from the end of STRING. If TO is nil, the substring runs
1177 to the end of STRING.
1179 The STRING argument may also be a vector. In that case, the return
1180 value is a new vector that contains the elements between index FROM
1181 \(inclusive) and index TO (exclusive) of that vector argument.
1183 With one argument, just copy STRING (with properties, if any). */)
1184 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1188 EMACS_INT ifrom
, ito
;
1190 if (STRINGP (string
))
1191 size
= SCHARS (string
);
1192 else if (VECTORP (string
))
1193 size
= ASIZE (string
);
1195 wrong_type_argument (Qarrayp
, string
);
1197 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1199 if (STRINGP (string
))
1202 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1204 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1205 res
= make_specified_string (SSDATA (string
) + from_byte
,
1206 ito
- ifrom
, to_byte
- from_byte
,
1207 STRING_MULTIBYTE (string
));
1208 copy_text_properties (make_number (ifrom
), make_number (ito
),
1209 string
, make_number (0), res
, Qnil
);
1212 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1218 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1219 doc
: /* Return a substring of STRING, without text properties.
1220 It starts at index FROM and ends before TO.
1221 TO may be nil or omitted; then the substring runs to the end of STRING.
1222 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1223 If FROM or TO is negative, it counts from the end.
1225 With one argument, just copy STRING without its properties. */)
1226 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1229 EMACS_INT from_char
, to_char
;
1230 ptrdiff_t from_byte
, to_byte
;
1232 CHECK_STRING (string
);
1234 size
= SCHARS (string
);
1235 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1237 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1239 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1240 return make_specified_string (SSDATA (string
) + from_byte
,
1241 to_char
- from_char
, to_byte
- from_byte
,
1242 STRING_MULTIBYTE (string
));
1245 /* Extract a substring of STRING, giving start and end positions
1246 both in characters and in bytes. */
1249 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1250 ptrdiff_t to
, ptrdiff_t to_byte
)
1255 CHECK_VECTOR_OR_STRING (string
);
1257 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1259 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1260 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1262 if (STRINGP (string
))
1264 res
= make_specified_string (SSDATA (string
) + from_byte
,
1265 to
- from
, to_byte
- from_byte
,
1266 STRING_MULTIBYTE (string
));
1267 copy_text_properties (make_number (from
), make_number (to
),
1268 string
, make_number (0), res
, Qnil
);
1271 res
= Fvector (to
- from
, aref_addr (string
, from
));
1276 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1277 doc
: /* Take cdr N times on LIST, return the result. */)
1278 (Lisp_Object n
, Lisp_Object list
)
1283 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1286 CHECK_LIST_CONS (list
, list
);
1292 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1293 doc
: /* Return the Nth element of LIST.
1294 N counts from zero. If LIST is not that long, nil is returned. */)
1295 (Lisp_Object n
, Lisp_Object list
)
1297 return Fcar (Fnthcdr (n
, list
));
1300 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1301 doc
: /* Return element of SEQUENCE at index N. */)
1302 (register Lisp_Object sequence
, Lisp_Object n
)
1305 if (CONSP (sequence
) || NILP (sequence
))
1306 return Fcar (Fnthcdr (n
, sequence
));
1308 /* Faref signals a "not array" error, so check here. */
1309 CHECK_ARRAY (sequence
, Qsequencep
);
1310 return Faref (sequence
, n
);
1313 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1314 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1315 The value is actually the tail of LIST whose car is ELT. */)
1316 (register Lisp_Object elt
, Lisp_Object list
)
1318 register Lisp_Object tail
;
1319 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1321 register Lisp_Object tem
;
1322 CHECK_LIST_CONS (tail
, list
);
1324 if (! NILP (Fequal (elt
, tem
)))
1331 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1332 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1333 The value is actually the tail of LIST whose car is ELT. */)
1334 (register Lisp_Object elt
, Lisp_Object list
)
1338 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1342 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1346 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1358 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1359 The value is actually the tail of LIST whose car is ELT. */)
1360 (register Lisp_Object elt
, Lisp_Object list
)
1362 register Lisp_Object tail
;
1365 return Fmemq (elt
, list
);
1367 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1369 register Lisp_Object tem
;
1370 CHECK_LIST_CONS (tail
, list
);
1372 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1379 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1380 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1381 The value is actually the first element of LIST whose car is KEY.
1382 Elements of LIST that are not conses are ignored. */)
1383 (Lisp_Object key
, Lisp_Object list
)
1388 || (CONSP (XCAR (list
))
1389 && EQ (XCAR (XCAR (list
)), key
)))
1394 || (CONSP (XCAR (list
))
1395 && EQ (XCAR (XCAR (list
)), key
)))
1400 || (CONSP (XCAR (list
))
1401 && EQ (XCAR (XCAR (list
)), key
)))
1411 /* Like Fassq but never report an error and do not allow quits.
1412 Use only on lists known never to be circular. */
1415 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1418 && (!CONSP (XCAR (list
))
1419 || !EQ (XCAR (XCAR (list
)), key
)))
1422 return CAR_SAFE (list
);
1425 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1426 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1427 The value is actually the first element of LIST whose car equals KEY. */)
1428 (Lisp_Object key
, Lisp_Object list
)
1435 || (CONSP (XCAR (list
))
1436 && (car
= XCAR (XCAR (list
)),
1437 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1442 || (CONSP (XCAR (list
))
1443 && (car
= XCAR (XCAR (list
)),
1444 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1449 || (CONSP (XCAR (list
))
1450 && (car
= XCAR (XCAR (list
)),
1451 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1461 /* Like Fassoc but never report an error and do not allow quits.
1462 Use only on lists known never to be circular. */
1465 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1468 && (!CONSP (XCAR (list
))
1469 || (!EQ (XCAR (XCAR (list
)), key
)
1470 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1473 return CONSP (list
) ? XCAR (list
) : Qnil
;
1476 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1477 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1478 The value is actually the first element of LIST whose cdr is KEY. */)
1479 (register Lisp_Object key
, Lisp_Object list
)
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCDR (XCAR (list
)), key
)))
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCDR (XCAR (list
)), key
)))
1496 || (CONSP (XCAR (list
))
1497 && EQ (XCDR (XCAR (list
)), key
)))
1507 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1508 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1509 The value is actually the first element of LIST whose cdr equals KEY. */)
1510 (Lisp_Object key
, Lisp_Object list
)
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1531 || (CONSP (XCAR (list
))
1532 && (cdr
= XCDR (XCAR (list
)),
1533 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1543 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1544 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1545 More precisely, this function skips any members `eq' to ELT at the
1546 front of LIST, then removes members `eq' to ELT from the remaining
1547 sublist by modifying its list structure, then returns the resulting
1550 Write `(setq foo (delq element foo))' to be sure of correctly changing
1551 the value of a list `foo'. */)
1552 (register Lisp_Object elt
, Lisp_Object list
)
1554 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1557 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1559 Lisp_Object tem
= XCAR (tail
);
1565 Fsetcdr (prev
, XCDR (tail
));
1573 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1574 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1575 SEQ must be a sequence (i.e. a list, a vector, or a string).
1576 The return value is a sequence of the same type.
1578 If SEQ is a list, this behaves like `delq', except that it compares
1579 with `equal' instead of `eq'. In particular, it may remove elements
1580 by altering the list structure.
1582 If SEQ is not a list, deletion is never performed destructively;
1583 instead this function creates and returns a new vector or string.
1585 Write `(setq foo (delete element foo))' to be sure of correctly
1586 changing the value of a sequence `foo'. */)
1587 (Lisp_Object elt
, Lisp_Object seq
)
1593 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1594 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1597 if (n
!= ASIZE (seq
))
1599 struct Lisp_Vector
*p
= allocate_vector (n
);
1601 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1602 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1603 p
->contents
[n
++] = AREF (seq
, i
);
1605 XSETVECTOR (seq
, p
);
1608 else if (STRINGP (seq
))
1610 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1613 for (i
= nchars
= nbytes
= ibyte
= 0;
1615 ++i
, ibyte
+= cbytes
)
1617 if (STRING_MULTIBYTE (seq
))
1619 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1620 cbytes
= CHAR_BYTES (c
);
1628 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1635 if (nchars
!= SCHARS (seq
))
1639 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1640 if (!STRING_MULTIBYTE (seq
))
1641 STRING_SET_UNIBYTE (tem
);
1643 for (i
= nchars
= nbytes
= ibyte
= 0;
1645 ++i
, ibyte
+= cbytes
)
1647 if (STRING_MULTIBYTE (seq
))
1649 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1650 cbytes
= CHAR_BYTES (c
);
1658 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1660 unsigned char *from
= SDATA (seq
) + ibyte
;
1661 unsigned char *to
= SDATA (tem
) + nbytes
;
1667 for (n
= cbytes
; n
--; )
1677 Lisp_Object tail
, prev
;
1679 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1681 CHECK_LIST_CONS (tail
, seq
);
1683 if (!NILP (Fequal (elt
, XCAR (tail
))))
1688 Fsetcdr (prev
, XCDR (tail
));
1699 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1700 doc
: /* Reverse order of items in a list, vector or string SEQ.
1701 If SEQ is a list, it should be nil-terminated.
1702 This function may destructively modify SEQ to produce the value. */)
1707 else if (STRINGP (seq
))
1708 return Freverse (seq
);
1709 else if (CONSP (seq
))
1711 Lisp_Object prev
, tail
, next
;
1713 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1716 CHECK_LIST_CONS (tail
, tail
);
1718 Fsetcdr (tail
, prev
);
1723 else if (VECTORP (seq
))
1725 ptrdiff_t i
, size
= ASIZE (seq
);
1727 for (i
= 0; i
< size
/ 2; i
++)
1729 Lisp_Object tem
= AREF (seq
, i
);
1730 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1731 ASET (seq
, size
- i
- 1, tem
);
1734 else if (BOOL_VECTOR_P (seq
))
1736 ptrdiff_t i
, size
= bool_vector_size (seq
);
1738 for (i
= 0; i
< size
/ 2; i
++)
1740 bool tem
= bool_vector_bitref (seq
, i
);
1741 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1742 bool_vector_set (seq
, size
- i
- 1, tem
);
1746 wrong_type_argument (Qarrayp
, seq
);
1750 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1751 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1752 See also the function `nreverse', which is used more often. */)
1759 else if (CONSP (seq
))
1761 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1764 new = Fcons (XCAR (seq
), new);
1766 CHECK_LIST_END (seq
, seq
);
1768 else if (VECTORP (seq
))
1770 ptrdiff_t i
, size
= ASIZE (seq
);
1772 new = make_uninit_vector (size
);
1773 for (i
= 0; i
< size
; i
++)
1774 ASET (new, i
, AREF (seq
, size
- i
- 1));
1776 else if (BOOL_VECTOR_P (seq
))
1779 EMACS_INT nbits
= bool_vector_size (seq
);
1781 new = make_uninit_bool_vector (nbits
);
1782 for (i
= 0; i
< nbits
; i
++)
1783 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1785 else if (STRINGP (seq
))
1787 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1793 new = make_uninit_string (size
);
1794 for (i
= 0; i
< size
; i
++)
1795 SSET (new, i
, SREF (seq
, size
- i
- 1));
1799 unsigned char *p
, *q
;
1801 new = make_uninit_multibyte_string (size
, bytes
);
1802 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1803 while (q
> SDATA (new))
1807 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1809 CHAR_STRING (ch
, q
);
1814 wrong_type_argument (Qsequencep
, seq
);
1818 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1819 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1820 Returns the sorted list. LIST is modified by side effects.
1821 PREDICATE is called with two elements of LIST, and should return non-nil
1822 if the first element should sort before the second. */)
1823 (Lisp_Object list
, Lisp_Object predicate
)
1825 Lisp_Object front
, back
;
1826 register Lisp_Object len
, tem
;
1827 struct gcpro gcpro1
, gcpro2
;
1831 len
= Flength (list
);
1832 length
= XINT (len
);
1836 XSETINT (len
, (length
/ 2) - 1);
1837 tem
= Fnthcdr (len
, list
);
1839 Fsetcdr (tem
, Qnil
);
1841 GCPRO2 (front
, back
);
1842 front
= Fsort (front
, predicate
);
1843 back
= Fsort (back
, predicate
);
1845 return merge (front
, back
, predicate
);
1849 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1852 register Lisp_Object tail
;
1854 register Lisp_Object l1
, l2
;
1855 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1862 /* It is sufficient to protect org_l1 and org_l2.
1863 When l1 and l2 are updated, we copy the new values
1864 back into the org_ vars. */
1865 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1885 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1901 Fsetcdr (tail
, tem
);
1907 /* This does not check for quits. That is safe since it must terminate. */
1909 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1910 doc
: /* Extract a value from a property list.
1911 PLIST is a property list, which is a list of the form
1912 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1913 corresponding to the given PROP, or nil if PROP is not one of the
1914 properties on the list. This function never signals an error. */)
1915 (Lisp_Object plist
, Lisp_Object prop
)
1917 Lisp_Object tail
, halftail
;
1919 /* halftail is used to detect circular lists. */
1920 tail
= halftail
= plist
;
1921 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1923 if (EQ (prop
, XCAR (tail
)))
1924 return XCAR (XCDR (tail
));
1926 tail
= XCDR (XCDR (tail
));
1927 halftail
= XCDR (halftail
);
1928 if (EQ (tail
, halftail
))
1935 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1936 doc
: /* Return the value of SYMBOL's PROPNAME property.
1937 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1938 (Lisp_Object symbol
, Lisp_Object propname
)
1940 CHECK_SYMBOL (symbol
);
1941 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1944 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1945 doc
: /* Change value in PLIST of PROP to VAL.
1946 PLIST is a property list, which is a list of the form
1947 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1948 If PROP is already a property on the list, its value is set to VAL,
1949 otherwise the new PROP VAL pair is added. The new plist is returned;
1950 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1951 The PLIST is modified by side effects. */)
1952 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1954 register Lisp_Object tail
, prev
;
1955 Lisp_Object newcell
;
1957 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1958 tail
= XCDR (XCDR (tail
)))
1960 if (EQ (prop
, XCAR (tail
)))
1962 Fsetcar (XCDR (tail
), val
);
1969 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1973 Fsetcdr (XCDR (prev
), newcell
);
1977 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1978 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1979 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1980 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1982 CHECK_SYMBOL (symbol
);
1984 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1988 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1989 doc
: /* Extract a value from a property list, comparing with `equal'.
1990 PLIST is a property list, which is a list of the form
1991 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1992 corresponding to the given PROP, or nil if PROP is not
1993 one of the properties on the list. */)
1994 (Lisp_Object plist
, Lisp_Object prop
)
1999 CONSP (tail
) && CONSP (XCDR (tail
));
2000 tail
= XCDR (XCDR (tail
)))
2002 if (! NILP (Fequal (prop
, XCAR (tail
))))
2003 return XCAR (XCDR (tail
));
2008 CHECK_LIST_END (tail
, prop
);
2013 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2014 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2015 PLIST is a property list, which is a list of the form
2016 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2017 If PROP is already a property on the list, its value is set to VAL,
2018 otherwise the new PROP VAL pair is added. The new plist is returned;
2019 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2020 The PLIST is modified by side effects. */)
2021 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2023 register Lisp_Object tail
, prev
;
2024 Lisp_Object newcell
;
2026 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2027 tail
= XCDR (XCDR (tail
)))
2029 if (! NILP (Fequal (prop
, XCAR (tail
))))
2031 Fsetcar (XCDR (tail
), val
);
2038 newcell
= list2 (prop
, val
);
2042 Fsetcdr (XCDR (prev
), newcell
);
2046 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2047 doc
: /* Return t if the two args are the same Lisp object.
2048 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2049 (Lisp_Object obj1
, Lisp_Object obj2
)
2052 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2054 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2057 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2058 doc
: /* Return t if two Lisp objects have similar structure and contents.
2059 They must have the same data type.
2060 Conses are compared by comparing the cars and the cdrs.
2061 Vectors and strings are compared element by element.
2062 Numbers are compared by value, but integers cannot equal floats.
2063 (Use `=' if you want integers and floats to be able to be equal.)
2064 Symbols must match exactly. */)
2065 (register Lisp_Object o1
, Lisp_Object o2
)
2067 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2070 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2071 doc
: /* Return t if two Lisp objects have similar structure and contents.
2072 This is like `equal' except that it compares the text properties
2073 of strings. (`equal' ignores text properties.) */)
2074 (register Lisp_Object o1
, Lisp_Object o2
)
2076 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2079 /* DEPTH is current depth of recursion. Signal an error if it
2081 PROPS means compare string text properties too. */
2084 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2090 error ("Stack overflow in equal");
2093 Lisp_Object args
[2];
2096 ht
= Fmake_hash_table (2, args
);
2100 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2102 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2104 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2106 { /* `o1' was seen already. */
2107 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2108 if (!NILP (Fmemq (o2
, o2s
)))
2111 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2114 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2124 if (XTYPE (o1
) != XTYPE (o2
))
2133 d1
= extract_float (o1
);
2134 d2
= extract_float (o2
);
2135 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2136 though they are not =. */
2137 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2141 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2145 /* FIXME: This inf-loops in a circular list! */
2149 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2153 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2154 depth
+ 1, props
, ht
)
2155 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2156 depth
+ 1, props
, ht
))
2158 o1
= XOVERLAY (o1
)->plist
;
2159 o2
= XOVERLAY (o2
)->plist
;
2164 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2165 && (XMARKER (o1
)->buffer
== 0
2166 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2170 case Lisp_Vectorlike
:
2173 ptrdiff_t size
= ASIZE (o1
);
2174 /* Pseudovectors have the type encoded in the size field, so this test
2175 actually checks that the objects have the same type as well as the
2177 if (ASIZE (o2
) != size
)
2179 /* Boolvectors are compared much like strings. */
2180 if (BOOL_VECTOR_P (o1
))
2182 EMACS_INT size
= bool_vector_size (o1
);
2183 if (size
!= bool_vector_size (o2
))
2185 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2186 bool_vector_bytes (size
)))
2190 if (WINDOW_CONFIGURATIONP (o1
))
2191 return compare_window_configurations (o1
, o2
, 0);
2193 /* Aside from them, only true vectors, char-tables, compiled
2194 functions, and fonts (font-spec, font-entity, font-object)
2195 are sensible to compare, so eliminate the others now. */
2196 if (size
& PSEUDOVECTOR_FLAG
)
2198 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2201 size
&= PSEUDOVECTOR_SIZE_MASK
;
2203 for (i
= 0; i
< size
; i
++)
2208 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2216 if (SCHARS (o1
) != SCHARS (o2
))
2218 if (SBYTES (o1
) != SBYTES (o2
))
2220 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2222 if (props
&& !compare_string_intervals (o1
, o2
))
2234 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2235 doc
: /* Store each element of ARRAY with ITEM.
2236 ARRAY is a vector, string, char-table, or bool-vector. */)
2237 (Lisp_Object array
, Lisp_Object item
)
2239 register ptrdiff_t size
, idx
;
2241 if (VECTORP (array
))
2242 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2243 ASET (array
, idx
, item
);
2244 else if (CHAR_TABLE_P (array
))
2248 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2249 set_char_table_contents (array
, i
, item
);
2250 set_char_table_defalt (array
, item
);
2252 else if (STRINGP (array
))
2254 register unsigned char *p
= SDATA (array
);
2256 CHECK_CHARACTER (item
);
2257 charval
= XFASTINT (item
);
2258 size
= SCHARS (array
);
2259 if (STRING_MULTIBYTE (array
))
2261 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2262 int len
= CHAR_STRING (charval
, str
);
2263 ptrdiff_t size_byte
= SBYTES (array
);
2265 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2266 || SCHARS (array
) * len
!= size_byte
)
2267 error ("Attempt to change byte length of a string");
2268 for (idx
= 0; idx
< size_byte
; idx
++)
2269 *p
++ = str
[idx
% len
];
2272 for (idx
= 0; idx
< size
; idx
++)
2275 else if (BOOL_VECTOR_P (array
))
2276 return bool_vector_fill (array
, item
);
2278 wrong_type_argument (Qarrayp
, array
);
2282 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2284 doc
: /* Clear the contents of STRING.
2285 This makes STRING unibyte and may change its length. */)
2286 (Lisp_Object string
)
2289 CHECK_STRING (string
);
2290 len
= SBYTES (string
);
2291 memset (SDATA (string
), 0, len
);
2292 STRING_SET_CHARS (string
, len
);
2293 STRING_SET_UNIBYTE (string
);
2299 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2301 Lisp_Object args
[2];
2304 return Fnconc (2, args
);
2307 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2308 doc
: /* Concatenate any number of lists by altering them.
2309 Only the last argument is not altered, and need not be a list.
2310 usage: (nconc &rest LISTS) */)
2311 (ptrdiff_t nargs
, Lisp_Object
*args
)
2314 register Lisp_Object tail
, tem
, val
;
2318 for (argnum
= 0; argnum
< nargs
; argnum
++)
2321 if (NILP (tem
)) continue;
2326 if (argnum
+ 1 == nargs
) break;
2328 CHECK_LIST_CONS (tem
, tem
);
2337 tem
= args
[argnum
+ 1];
2338 Fsetcdr (tail
, tem
);
2340 args
[argnum
+ 1] = tail
;
2346 /* This is the guts of all mapping functions.
2347 Apply FN to each element of SEQ, one by one,
2348 storing the results into elements of VALS, a C vector of Lisp_Objects.
2349 LENI is the length of VALS, which should also be the length of SEQ. */
2352 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2354 register Lisp_Object tail
;
2356 register EMACS_INT i
;
2357 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2361 /* Don't let vals contain any garbage when GC happens. */
2362 for (i
= 0; i
< leni
; i
++)
2365 GCPRO3 (dummy
, fn
, seq
);
2367 gcpro1
.nvars
= leni
;
2371 /* We need not explicitly protect `tail' because it is used only on lists, and
2372 1) lists are not relocated and 2) the list is marked via `seq' so will not
2375 if (VECTORP (seq
) || COMPILEDP (seq
))
2377 for (i
= 0; i
< leni
; i
++)
2379 dummy
= call1 (fn
, AREF (seq
, i
));
2384 else if (BOOL_VECTOR_P (seq
))
2386 for (i
= 0; i
< leni
; i
++)
2388 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2393 else if (STRINGP (seq
))
2397 for (i
= 0, i_byte
= 0; i
< leni
;)
2400 ptrdiff_t i_before
= i
;
2402 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2403 XSETFASTINT (dummy
, c
);
2404 dummy
= call1 (fn
, dummy
);
2406 vals
[i_before
] = dummy
;
2409 else /* Must be a list, since Flength did not get an error */
2412 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2414 dummy
= call1 (fn
, XCAR (tail
));
2424 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2425 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2426 In between each pair of results, stick in SEPARATOR. Thus, " " as
2427 SEPARATOR results in spaces between the values returned by FUNCTION.
2428 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2429 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2432 register EMACS_INT leni
;
2435 register Lisp_Object
*args
;
2436 struct gcpro gcpro1
;
2440 len
= Flength (sequence
);
2441 if (CHAR_TABLE_P (sequence
))
2442 wrong_type_argument (Qlistp
, sequence
);
2444 nargs
= leni
+ leni
- 1;
2445 if (nargs
< 0) return empty_unibyte_string
;
2447 SAFE_ALLOCA_LISP (args
, nargs
);
2450 mapcar1 (leni
, args
, function
, sequence
);
2453 for (i
= leni
- 1; i
> 0; i
--)
2454 args
[i
+ i
] = args
[i
];
2456 for (i
= 1; i
< nargs
; i
+= 2)
2457 args
[i
] = separator
;
2459 ret
= Fconcat (nargs
, args
);
2465 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2466 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2467 The result is a list just as long as SEQUENCE.
2468 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2469 (Lisp_Object function
, Lisp_Object sequence
)
2471 register Lisp_Object len
;
2472 register EMACS_INT leni
;
2473 register Lisp_Object
*args
;
2477 len
= Flength (sequence
);
2478 if (CHAR_TABLE_P (sequence
))
2479 wrong_type_argument (Qlistp
, sequence
);
2480 leni
= XFASTINT (len
);
2482 SAFE_ALLOCA_LISP (args
, leni
);
2484 mapcar1 (leni
, args
, function
, sequence
);
2486 ret
= Flist (leni
, args
);
2492 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2493 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2494 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2495 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2496 (Lisp_Object function
, Lisp_Object sequence
)
2498 register EMACS_INT leni
;
2500 leni
= XFASTINT (Flength (sequence
));
2501 if (CHAR_TABLE_P (sequence
))
2502 wrong_type_argument (Qlistp
, sequence
);
2503 mapcar1 (leni
, 0, function
, sequence
);
2508 /* This is how C code calls `yes-or-no-p' and allows the user
2511 Anything that calls this function must protect from GC! */
2514 do_yes_or_no_p (Lisp_Object prompt
)
2516 return call1 (intern ("yes-or-no-p"), prompt
);
2519 /* Anything that calls this function must protect from GC! */
2521 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2522 doc
: /* Ask user a yes-or-no question.
2523 Return t if answer is yes, and nil if the answer is no.
2524 PROMPT is the string to display to ask the question. It should end in
2525 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2527 The user must confirm the answer with RET, and can edit it until it
2530 If dialog boxes are supported, a dialog box will be used
2531 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2532 (Lisp_Object prompt
)
2534 register Lisp_Object ans
;
2535 Lisp_Object args
[2];
2536 struct gcpro gcpro1
;
2538 CHECK_STRING (prompt
);
2540 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2543 Lisp_Object pane
, menu
, obj
;
2544 redisplay_preserve_echo_area (4);
2545 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2546 Fcons (build_string ("No"), Qnil
));
2548 menu
= Fcons (prompt
, pane
);
2549 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2555 args
[1] = build_string ("(yes or no) ");
2556 prompt
= Fconcat (2, args
);
2562 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2563 Qyes_or_no_p_history
, Qnil
,
2565 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2570 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2578 message1 ("Please answer yes or no.");
2579 Fsleep_for (make_number (2), Qnil
);
2583 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2584 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2586 Each of the three load averages is multiplied by 100, then converted
2589 When USE-FLOATS is non-nil, floats will be used instead of integers.
2590 These floats are not multiplied by 100.
2592 If the 5-minute or 15-minute load averages are not available, return a
2593 shortened list, containing only those averages which are available.
2595 An error is thrown if the load average can't be obtained. In some
2596 cases making it work would require Emacs being installed setuid or
2597 setgid so that it can read kernel information, and that usually isn't
2599 (Lisp_Object use_floats
)
2602 int loads
= getloadavg (load_ave
, 3);
2603 Lisp_Object ret
= Qnil
;
2606 error ("load-average not implemented for this operating system");
2610 Lisp_Object load
= (NILP (use_floats
)
2611 ? make_number (100.0 * load_ave
[loads
])
2612 : make_float (load_ave
[loads
]));
2613 ret
= Fcons (load
, ret
);
2619 static Lisp_Object Qsubfeatures
;
2621 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2622 doc
: /* Return t if FEATURE is present in this Emacs.
2624 Use this to conditionalize execution of lisp code based on the
2625 presence or absence of Emacs or environment extensions.
2626 Use `provide' to declare that a feature is available. This function
2627 looks at the value of the variable `features'. The optional argument
2628 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2629 (Lisp_Object feature
, Lisp_Object subfeature
)
2631 register Lisp_Object tem
;
2632 CHECK_SYMBOL (feature
);
2633 tem
= Fmemq (feature
, Vfeatures
);
2634 if (!NILP (tem
) && !NILP (subfeature
))
2635 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2636 return (NILP (tem
)) ? Qnil
: Qt
;
2639 static Lisp_Object Qfuncall
;
2641 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2642 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2643 The optional argument SUBFEATURES should be a list of symbols listing
2644 particular subfeatures supported in this version of FEATURE. */)
2645 (Lisp_Object feature
, Lisp_Object subfeatures
)
2647 register Lisp_Object tem
;
2648 CHECK_SYMBOL (feature
);
2649 CHECK_LIST (subfeatures
);
2650 if (!NILP (Vautoload_queue
))
2651 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2653 tem
= Fmemq (feature
, Vfeatures
);
2655 Vfeatures
= Fcons (feature
, Vfeatures
);
2656 if (!NILP (subfeatures
))
2657 Fput (feature
, Qsubfeatures
, subfeatures
);
2658 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2660 /* Run any load-hooks for this file. */
2661 tem
= Fassq (feature
, Vafter_load_alist
);
2663 Fmapc (Qfuncall
, XCDR (tem
));
2668 /* `require' and its subroutines. */
2670 /* List of features currently being require'd, innermost first. */
2672 static Lisp_Object require_nesting_list
;
2675 require_unwind (Lisp_Object old_value
)
2677 require_nesting_list
= old_value
;
2680 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2681 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2682 If FEATURE is not a member of the list `features', then the feature
2683 is not loaded; so load the file FILENAME.
2684 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2685 and `load' will try to load this name appended with the suffix `.elc' or
2686 `.el', in that order. The name without appended suffix will not be used.
2687 See `get-load-suffixes' for the complete list of suffixes.
2688 If the optional third argument NOERROR is non-nil,
2689 then return nil if the file is not found instead of signaling an error.
2690 Normally the return value is FEATURE.
2691 The normal messages at start and end of loading FILENAME are suppressed. */)
2692 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2695 struct gcpro gcpro1
, gcpro2
;
2696 bool from_file
= load_in_progress
;
2698 CHECK_SYMBOL (feature
);
2700 /* Record the presence of `require' in this file
2701 even if the feature specified is already loaded.
2702 But not more than once in any file,
2703 and not when we aren't loading or reading from a file. */
2705 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2706 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2711 tem
= Fcons (Qrequire
, feature
);
2712 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2713 LOADHIST_ATTACH (tem
);
2715 tem
= Fmemq (feature
, Vfeatures
);
2719 ptrdiff_t count
= SPECPDL_INDEX ();
2722 /* This is to make sure that loadup.el gives a clear picture
2723 of what files are preloaded and when. */
2724 if (! NILP (Vpurify_flag
))
2725 error ("(require %s) while preparing to dump",
2726 SDATA (SYMBOL_NAME (feature
)));
2728 /* A certain amount of recursive `require' is legitimate,
2729 but if we require the same feature recursively 3 times,
2731 tem
= require_nesting_list
;
2732 while (! NILP (tem
))
2734 if (! NILP (Fequal (feature
, XCAR (tem
))))
2739 error ("Recursive `require' for feature `%s'",
2740 SDATA (SYMBOL_NAME (feature
)));
2742 /* Update the list for any nested `require's that occur. */
2743 record_unwind_protect (require_unwind
, require_nesting_list
);
2744 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2746 /* Value saved here is to be restored into Vautoload_queue */
2747 record_unwind_protect (un_autoload
, Vautoload_queue
);
2748 Vautoload_queue
= Qt
;
2750 /* Load the file. */
2751 GCPRO2 (feature
, filename
);
2752 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2753 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2756 /* If load failed entirely, return nil. */
2758 return unbind_to (count
, Qnil
);
2760 tem
= Fmemq (feature
, Vfeatures
);
2762 error ("Required feature `%s' was not provided",
2763 SDATA (SYMBOL_NAME (feature
)));
2765 /* Once loading finishes, don't undo it. */
2766 Vautoload_queue
= Qt
;
2767 feature
= unbind_to (count
, feature
);
2773 /* Primitives for work of the "widget" library.
2774 In an ideal world, this section would not have been necessary.
2775 However, lisp function calls being as slow as they are, it turns
2776 out that some functions in the widget library (wid-edit.el) are the
2777 bottleneck of Widget operation. Here is their translation to C,
2778 for the sole reason of efficiency. */
2780 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2781 doc
: /* Return non-nil if PLIST has the property PROP.
2782 PLIST is a property list, which is a list of the form
2783 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2784 Unlike `plist-get', this allows you to distinguish between a missing
2785 property and a property with the value nil.
2786 The value is actually the tail of PLIST whose car is PROP. */)
2787 (Lisp_Object plist
, Lisp_Object prop
)
2789 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2792 plist
= XCDR (plist
);
2793 plist
= CDR (plist
);
2798 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2799 doc
: /* In WIDGET, set PROPERTY to VALUE.
2800 The value can later be retrieved with `widget-get'. */)
2801 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2803 CHECK_CONS (widget
);
2804 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2808 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2809 doc
: /* In WIDGET, get the value of PROPERTY.
2810 The value could either be specified when the widget was created, or
2811 later with `widget-put'. */)
2812 (Lisp_Object widget
, Lisp_Object property
)
2820 CHECK_CONS (widget
);
2821 tmp
= Fplist_member (XCDR (widget
), property
);
2827 tmp
= XCAR (widget
);
2830 widget
= Fget (tmp
, Qwidget_type
);
2834 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2835 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2836 ARGS are passed as extra arguments to the function.
2837 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2838 (ptrdiff_t nargs
, Lisp_Object
*args
)
2840 /* This function can GC. */
2841 Lisp_Object newargs
[3];
2842 struct gcpro gcpro1
, gcpro2
;
2845 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2846 newargs
[1] = args
[0];
2847 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2848 GCPRO2 (newargs
[0], newargs
[2]);
2849 result
= Fapply (3, newargs
);
2854 #ifdef HAVE_LANGINFO_CODESET
2855 #include <langinfo.h>
2858 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2859 doc
: /* Access locale data ITEM for the current C locale, if available.
2860 ITEM should be one of the following:
2862 `codeset', returning the character set as a string (locale item CODESET);
2864 `days', returning a 7-element vector of day names (locale items DAY_n);
2866 `months', returning a 12-element vector of month names (locale items MON_n);
2868 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2869 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2871 If the system can't provide such information through a call to
2872 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2874 See also Info node `(libc)Locales'.
2876 The data read from the system are decoded using `locale-coding-system'. */)
2880 #ifdef HAVE_LANGINFO_CODESET
2882 if (EQ (item
, Qcodeset
))
2884 str
= nl_langinfo (CODESET
);
2885 return build_string (str
);
2888 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2890 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2891 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2893 struct gcpro gcpro1
;
2895 synchronize_system_time_locale ();
2896 for (i
= 0; i
< 7; i
++)
2898 str
= nl_langinfo (days
[i
]);
2899 val
= build_unibyte_string (str
);
2900 /* Fixme: Is this coding system necessarily right, even if
2901 it is consistent with CODESET? If not, what to do? */
2902 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2910 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2912 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2913 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2914 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2916 struct gcpro gcpro1
;
2918 synchronize_system_time_locale ();
2919 for (i
= 0; i
< 12; i
++)
2921 str
= nl_langinfo (months
[i
]);
2922 val
= build_unibyte_string (str
);
2923 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2930 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2931 but is in the locale files. This could be used by ps-print. */
2933 else if (EQ (item
, Qpaper
))
2934 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2935 #endif /* PAPER_WIDTH */
2936 #endif /* HAVE_LANGINFO_CODESET*/
2940 /* base64 encode/decode functions (RFC 2045).
2941 Based on code from GNU recode. */
2943 #define MIME_LINE_LENGTH 76
2945 #define IS_ASCII(Character) \
2947 #define IS_BASE64(Character) \
2948 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2949 #define IS_BASE64_IGNORABLE(Character) \
2950 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2951 || (Character) == '\f' || (Character) == '\r')
2953 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2954 character or return retval if there are no characters left to
2956 #define READ_QUADRUPLET_BYTE(retval) \
2961 if (nchars_return) \
2962 *nchars_return = nchars; \
2967 while (IS_BASE64_IGNORABLE (c))
2969 /* Table of characters coding the 64 values. */
2970 static const char base64_value_to_char
[64] =
2972 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2973 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2974 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2975 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2976 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2977 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2978 '8', '9', '+', '/' /* 60-63 */
2981 /* Table of base64 values for first 128 characters. */
2982 static const short base64_char_to_value
[128] =
2984 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2985 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2986 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2987 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2988 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2989 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2990 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2991 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2992 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2993 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2994 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2995 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2996 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2999 /* The following diagram shows the logical steps by which three octets
3000 get transformed into four base64 characters.
3002 .--------. .--------. .--------.
3003 |aaaaaabb| |bbbbcccc| |ccdddddd|
3004 `--------' `--------' `--------'
3006 .--------+--------+--------+--------.
3007 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3008 `--------+--------+--------+--------'
3010 .--------+--------+--------+--------.
3011 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3012 `--------+--------+--------+--------'
3014 The octets are divided into 6 bit chunks, which are then encoded into
3015 base64 characters. */
3018 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3019 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3022 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3024 doc
: /* Base64-encode the region between BEG and END.
3025 Return the length of the encoded text.
3026 Optional third argument NO-LINE-BREAK means do not break long lines
3027 into shorter lines. */)
3028 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3031 ptrdiff_t allength
, length
;
3032 ptrdiff_t ibeg
, iend
, encoded_length
;
3033 ptrdiff_t old_pos
= PT
;
3036 validate_region (&beg
, &end
);
3038 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3039 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3040 move_gap_both (XFASTINT (beg
), ibeg
);
3042 /* We need to allocate enough room for encoding the text.
3043 We need 33 1/3% more space, plus a newline every 76
3044 characters, and then we round up. */
3045 length
= iend
- ibeg
;
3046 allength
= length
+ length
/3 + 1;
3047 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3049 encoded
= SAFE_ALLOCA (allength
);
3050 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3051 encoded
, length
, NILP (no_line_break
),
3052 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3053 if (encoded_length
> allength
)
3056 if (encoded_length
< 0)
3058 /* The encoding wasn't possible. */
3060 error ("Multibyte character in data for base64 encoding");
3063 /* Now we have encoded the region, so we insert the new contents
3064 and delete the old. (Insert first in order to preserve markers.) */
3065 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3066 insert (encoded
, encoded_length
);
3068 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3070 /* If point was outside of the region, restore it exactly; else just
3071 move to the beginning of the region. */
3072 if (old_pos
>= XFASTINT (end
))
3073 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3074 else if (old_pos
> XFASTINT (beg
))
3075 old_pos
= XFASTINT (beg
);
3078 /* We return the length of the encoded text. */
3079 return make_number (encoded_length
);
3082 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3084 doc
: /* Base64-encode STRING and return the result.
3085 Optional second argument NO-LINE-BREAK means do not break long lines
3086 into shorter lines. */)
3087 (Lisp_Object string
, Lisp_Object no_line_break
)
3089 ptrdiff_t allength
, length
, encoded_length
;
3091 Lisp_Object encoded_string
;
3094 CHECK_STRING (string
);
3096 /* We need to allocate enough room for encoding the text.
3097 We need 33 1/3% more space, plus a newline every 76
3098 characters, and then we round up. */
3099 length
= SBYTES (string
);
3100 allength
= length
+ length
/3 + 1;
3101 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3103 /* We need to allocate enough room for decoding the text. */
3104 encoded
= SAFE_ALLOCA (allength
);
3106 encoded_length
= base64_encode_1 (SSDATA (string
),
3107 encoded
, length
, NILP (no_line_break
),
3108 STRING_MULTIBYTE (string
));
3109 if (encoded_length
> allength
)
3112 if (encoded_length
< 0)
3114 /* The encoding wasn't possible. */
3116 error ("Multibyte character in data for base64 encoding");
3119 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3122 return encoded_string
;
3126 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3127 bool line_break
, bool multibyte
)
3140 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3141 if (CHAR_BYTE8_P (c
))
3142 c
= CHAR_TO_BYTE8 (c
);
3150 /* Wrap line every 76 characters. */
3154 if (counter
< MIME_LINE_LENGTH
/ 4)
3163 /* Process first byte of a triplet. */
3165 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3166 value
= (0x03 & c
) << 4;
3168 /* Process second byte of a triplet. */
3172 *e
++ = base64_value_to_char
[value
];
3180 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3181 if (CHAR_BYTE8_P (c
))
3182 c
= CHAR_TO_BYTE8 (c
);
3190 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3191 value
= (0x0f & c
) << 2;
3193 /* Process third byte of a triplet. */
3197 *e
++ = base64_value_to_char
[value
];
3204 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3205 if (CHAR_BYTE8_P (c
))
3206 c
= CHAR_TO_BYTE8 (c
);
3214 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3215 *e
++ = base64_value_to_char
[0x3f & c
];
3222 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3224 doc
: /* Base64-decode the region between BEG and END.
3225 Return the length of the decoded text.
3226 If the region can't be decoded, signal an error and don't modify the buffer. */)
3227 (Lisp_Object beg
, Lisp_Object end
)
3229 ptrdiff_t ibeg
, iend
, length
, allength
;
3231 ptrdiff_t old_pos
= PT
;
3232 ptrdiff_t decoded_length
;
3233 ptrdiff_t inserted_chars
;
3234 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3237 validate_region (&beg
, &end
);
3239 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3240 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3242 length
= iend
- ibeg
;
3244 /* We need to allocate enough room for decoding the text. If we are
3245 working on a multibyte buffer, each decoded code may occupy at
3247 allength
= multibyte
? length
* 2 : length
;
3248 decoded
= SAFE_ALLOCA (allength
);
3250 move_gap_both (XFASTINT (beg
), ibeg
);
3251 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3253 multibyte
, &inserted_chars
);
3254 if (decoded_length
> allength
)
3257 if (decoded_length
< 0)
3259 /* The decoding wasn't possible. */
3261 error ("Invalid base64 data");
3264 /* Now we have decoded the region, so we insert the new contents
3265 and delete the old. (Insert first in order to preserve markers.) */
3266 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3267 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3270 /* Delete the original text. */
3271 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3272 iend
+ decoded_length
, 1);
3274 /* If point was outside of the region, restore it exactly; else just
3275 move to the beginning of the region. */
3276 if (old_pos
>= XFASTINT (end
))
3277 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3278 else if (old_pos
> XFASTINT (beg
))
3279 old_pos
= XFASTINT (beg
);
3280 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3282 return make_number (inserted_chars
);
3285 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3287 doc
: /* Base64-decode STRING and return the result. */)
3288 (Lisp_Object string
)
3291 ptrdiff_t length
, decoded_length
;
3292 Lisp_Object decoded_string
;
3295 CHECK_STRING (string
);
3297 length
= SBYTES (string
);
3298 /* We need to allocate enough room for decoding the text. */
3299 decoded
= SAFE_ALLOCA (length
);
3301 /* The decoded result should be unibyte. */
3302 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3304 if (decoded_length
> length
)
3306 else if (decoded_length
>= 0)
3307 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3309 decoded_string
= Qnil
;
3312 if (!STRINGP (decoded_string
))
3313 error ("Invalid base64 data");
3315 return decoded_string
;
3318 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3319 MULTIBYTE, the decoded result should be in multibyte
3320 form. If NCHARS_RETURN is not NULL, store the number of produced
3321 characters in *NCHARS_RETURN. */
3324 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3325 bool multibyte
, ptrdiff_t *nchars_return
)
3327 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3330 unsigned long value
;
3331 ptrdiff_t nchars
= 0;
3335 /* Process first byte of a quadruplet. */
3337 READ_QUADRUPLET_BYTE (e
-to
);
3341 value
= base64_char_to_value
[c
] << 18;
3343 /* Process second byte of a quadruplet. */
3345 READ_QUADRUPLET_BYTE (-1);
3349 value
|= base64_char_to_value
[c
] << 12;
3351 c
= (unsigned char) (value
>> 16);
3352 if (multibyte
&& c
>= 128)
3353 e
+= BYTE8_STRING (c
, e
);
3358 /* Process third byte of a quadruplet. */
3360 READ_QUADRUPLET_BYTE (-1);
3364 READ_QUADRUPLET_BYTE (-1);
3373 value
|= base64_char_to_value
[c
] << 6;
3375 c
= (unsigned char) (0xff & value
>> 8);
3376 if (multibyte
&& c
>= 128)
3377 e
+= BYTE8_STRING (c
, e
);
3382 /* Process fourth byte of a quadruplet. */
3384 READ_QUADRUPLET_BYTE (-1);
3391 value
|= base64_char_to_value
[c
];
3393 c
= (unsigned char) (0xff & value
);
3394 if (multibyte
&& c
>= 128)
3395 e
+= BYTE8_STRING (c
, e
);
3404 /***********************************************************************
3406 ***** Hash Tables *****
3408 ***********************************************************************/
3410 /* Implemented by gerd@gnu.org. This hash table implementation was
3411 inspired by CMUCL hash tables. */
3415 1. For small tables, association lists are probably faster than
3416 hash tables because they have lower overhead.
3418 For uses of hash tables where the O(1) behavior of table
3419 operations is not a requirement, it might therefore be a good idea
3420 not to hash. Instead, we could just do a linear search in the
3421 key_and_value vector of the hash table. This could be done
3422 if a `:linear-search t' argument is given to make-hash-table. */
3425 /* The list of all weak hash tables. Don't staticpro this one. */
3427 static struct Lisp_Hash_Table
*weak_hash_tables
;
3429 /* Various symbols. */
3431 static Lisp_Object Qhash_table_p
;
3432 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3433 Lisp_Object Qeq
, Qequal
;
3434 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3435 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3438 /***********************************************************************
3440 ***********************************************************************/
3443 CHECK_HASH_TABLE (Lisp_Object x
)
3445 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3449 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3451 h
->key_and_value
= key_and_value
;
3454 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3459 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3461 gc_aset (h
->next
, idx
, val
);
3464 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3469 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3471 gc_aset (h
->hash
, idx
, val
);
3474 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3479 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3481 gc_aset (h
->index
, idx
, val
);
3484 /* If OBJ is a Lisp hash table, return a pointer to its struct
3485 Lisp_Hash_Table. Otherwise, signal an error. */
3487 static struct Lisp_Hash_Table
*
3488 check_hash_table (Lisp_Object obj
)
3490 CHECK_HASH_TABLE (obj
);
3491 return XHASH_TABLE (obj
);
3495 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3496 number. A number is "almost" a prime number if it is not divisible
3497 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3500 next_almost_prime (EMACS_INT n
)
3502 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3503 for (n
|= 1; ; n
+= 2)
3504 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3509 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3510 which USED[I] is non-zero. If found at index I in ARGS, set
3511 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3512 0. This function is used to extract a keyword/argument pair from
3513 a DEFUN parameter list. */
3516 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3520 for (i
= 1; i
< nargs
; i
++)
3521 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3532 /* Return a Lisp vector which has the same contents as VEC but has
3533 at least INCR_MIN more entries, where INCR_MIN is positive.
3534 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3535 than NITEMS_MAX. Entries in the resulting
3536 vector that are not copied from VEC are set to nil. */
3539 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3541 struct Lisp_Vector
*v
;
3542 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3543 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3544 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3545 ? nitems_max
: C_language_max
);
3546 eassert (VECTORP (vec
));
3547 eassert (0 < incr_min
&& -1 <= nitems_max
);
3548 old_size
= ASIZE (vec
);
3549 incr_max
= n_max
- old_size
;
3550 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3551 if (incr_max
< incr
)
3552 memory_full (SIZE_MAX
);
3553 new_size
= old_size
+ incr
;
3554 v
= allocate_vector (new_size
);
3555 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3556 for (i
= old_size
; i
< new_size
; ++i
)
3557 v
->contents
[i
] = Qnil
;
3558 XSETVECTOR (vec
, v
);
3563 /***********************************************************************
3565 ***********************************************************************/
3567 static struct hash_table_test hashtest_eq
;
3568 struct hash_table_test hashtest_eql
, hashtest_equal
;
3570 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3571 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3572 KEY2 are the same. */
3575 cmpfn_eql (struct hash_table_test
*ht
,
3579 return (FLOATP (key1
)
3581 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3585 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3586 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3587 KEY2 are the same. */
3590 cmpfn_equal (struct hash_table_test
*ht
,
3594 return !NILP (Fequal (key1
, key2
));
3598 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3599 HASH2 in hash table H using H->user_cmp_function. Value is true
3600 if KEY1 and KEY2 are the same. */
3603 cmpfn_user_defined (struct hash_table_test
*ht
,
3607 Lisp_Object args
[3];
3609 args
[0] = ht
->user_cmp_function
;
3612 return !NILP (Ffuncall (3, args
));
3616 /* Value is a hash code for KEY for use in hash table H which uses
3617 `eq' to compare keys. The hash code returned is guaranteed to fit
3618 in a Lisp integer. */
3621 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3623 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3627 /* Value is a hash code for KEY for use in hash table H which uses
3628 `eql' to compare keys. The hash code returned is guaranteed to fit
3629 in a Lisp integer. */
3632 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3636 hash
= sxhash (key
, 0);
3638 hash
= XHASH (key
) ^ XTYPE (key
);
3642 /* Value is a hash code for KEY for use in hash table H which uses
3643 `equal' to compare keys. The hash code returned is guaranteed to fit
3644 in a Lisp integer. */
3647 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3649 EMACS_UINT hash
= sxhash (key
, 0);
3653 /* Value is a hash code for KEY for use in hash table H which uses as
3654 user-defined function to compare keys. The hash code returned is
3655 guaranteed to fit in a Lisp integer. */
3658 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3660 Lisp_Object args
[2], hash
;
3662 args
[0] = ht
->user_hash_function
;
3664 hash
= Ffuncall (2, args
);
3665 return hashfn_eq (ht
, hash
);
3668 /* An upper bound on the size of a hash table index. It must fit in
3669 ptrdiff_t and be a valid Emacs fixnum. */
3670 #define INDEX_SIZE_BOUND \
3671 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3673 /* Create and initialize a new hash table.
3675 TEST specifies the test the hash table will use to compare keys.
3676 It must be either one of the predefined tests `eq', `eql' or
3677 `equal' or a symbol denoting a user-defined test named TEST with
3678 test and hash functions USER_TEST and USER_HASH.
3680 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3682 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3683 new size when it becomes full is computed by adding REHASH_SIZE to
3684 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3685 table's new size is computed by multiplying its old size with
3688 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3689 be resized when the ratio of (number of entries in the table) /
3690 (table size) is >= REHASH_THRESHOLD.
3692 WEAK specifies the weakness of the table. If non-nil, it must be
3693 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3696 make_hash_table (struct hash_table_test test
,
3697 Lisp_Object size
, Lisp_Object rehash_size
,
3698 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3700 struct Lisp_Hash_Table
*h
;
3702 EMACS_INT index_size
, sz
;
3706 /* Preconditions. */
3707 eassert (SYMBOLP (test
.name
));
3708 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3709 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3710 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3711 eassert (FLOATP (rehash_threshold
)
3712 && 0 < XFLOAT_DATA (rehash_threshold
)
3713 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3715 if (XFASTINT (size
) == 0)
3716 size
= make_number (1);
3718 sz
= XFASTINT (size
);
3719 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3720 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3721 ? next_almost_prime (index_float
)
3722 : INDEX_SIZE_BOUND
+ 1);
3723 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3724 error ("Hash table too large");
3726 /* Allocate a table and initialize it. */
3727 h
= allocate_hash_table ();
3729 /* Initialize hash table slots. */
3732 h
->rehash_threshold
= rehash_threshold
;
3733 h
->rehash_size
= rehash_size
;
3735 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3736 h
->hash
= Fmake_vector (size
, Qnil
);
3737 h
->next
= Fmake_vector (size
, Qnil
);
3738 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3740 /* Set up the free list. */
3741 for (i
= 0; i
< sz
- 1; ++i
)
3742 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3743 h
->next_free
= make_number (0);
3745 XSET_HASH_TABLE (table
, h
);
3746 eassert (HASH_TABLE_P (table
));
3747 eassert (XHASH_TABLE (table
) == h
);
3749 /* Maybe add this hash table to the list of all weak hash tables. */
3751 h
->next_weak
= NULL
;
3754 h
->next_weak
= weak_hash_tables
;
3755 weak_hash_tables
= h
;
3762 /* Return a copy of hash table H1. Keys and values are not copied,
3763 only the table itself is. */
3766 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3769 struct Lisp_Hash_Table
*h2
;
3771 h2
= allocate_hash_table ();
3773 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3774 h2
->hash
= Fcopy_sequence (h1
->hash
);
3775 h2
->next
= Fcopy_sequence (h1
->next
);
3776 h2
->index
= Fcopy_sequence (h1
->index
);
3777 XSET_HASH_TABLE (table
, h2
);
3779 /* Maybe add this hash table to the list of all weak hash tables. */
3780 if (!NILP (h2
->weak
))
3782 h2
->next_weak
= weak_hash_tables
;
3783 weak_hash_tables
= h2
;
3790 /* Resize hash table H if it's too full. If H cannot be resized
3791 because it's already too large, throw an error. */
3794 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3796 if (NILP (h
->next_free
))
3798 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3799 EMACS_INT new_size
, index_size
, nsize
;
3803 if (INTEGERP (h
->rehash_size
))
3804 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3807 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3808 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3810 new_size
= float_new_size
;
3811 if (new_size
<= old_size
)
3812 new_size
= old_size
+ 1;
3815 new_size
= INDEX_SIZE_BOUND
+ 1;
3817 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3818 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3819 ? next_almost_prime (index_float
)
3820 : INDEX_SIZE_BOUND
+ 1);
3821 nsize
= max (index_size
, 2 * new_size
);
3822 if (INDEX_SIZE_BOUND
< nsize
)
3823 error ("Hash table too large to resize");
3825 #ifdef ENABLE_CHECKING
3826 if (HASH_TABLE_P (Vpurify_flag
)
3827 && XHASH_TABLE (Vpurify_flag
) == h
)
3829 Lisp_Object args
[2];
3830 args
[0] = build_string ("Growing hash table to: %d");
3831 args
[1] = make_number (new_size
);
3836 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3837 2 * (new_size
- old_size
), -1));
3838 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3839 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3840 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3842 /* Update the free list. Do it so that new entries are added at
3843 the end of the free list. This makes some operations like
3845 for (i
= old_size
; i
< new_size
- 1; ++i
)
3846 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3848 if (!NILP (h
->next_free
))
3850 Lisp_Object last
, next
;
3852 last
= h
->next_free
;
3853 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3857 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3860 XSETFASTINT (h
->next_free
, old_size
);
3863 for (i
= 0; i
< old_size
; ++i
)
3864 if (!NILP (HASH_HASH (h
, i
)))
3866 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3867 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3868 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3869 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3875 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3876 the hash code of KEY. Value is the index of the entry in H
3877 matching KEY, or -1 if not found. */
3880 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3882 EMACS_UINT hash_code
;
3883 ptrdiff_t start_of_bucket
;
3886 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3887 eassert ((hash_code
& ~INTMASK
) == 0);
3891 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3892 idx
= HASH_INDEX (h
, start_of_bucket
);
3894 /* We need not gcpro idx since it's either an integer or nil. */
3897 ptrdiff_t i
= XFASTINT (idx
);
3898 if (EQ (key
, HASH_KEY (h
, i
))
3900 && hash_code
== XUINT (HASH_HASH (h
, i
))
3901 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3903 idx
= HASH_NEXT (h
, i
);
3906 return NILP (idx
) ? -1 : XFASTINT (idx
);
3910 /* Put an entry into hash table H that associates KEY with VALUE.
3911 HASH is a previously computed hash code of KEY.
3912 Value is the index of the entry in H matching KEY. */
3915 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3918 ptrdiff_t start_of_bucket
, i
;
3920 eassert ((hash
& ~INTMASK
) == 0);
3922 /* Increment count after resizing because resizing may fail. */
3923 maybe_resize_hash_table (h
);
3926 /* Store key/value in the key_and_value vector. */
3927 i
= XFASTINT (h
->next_free
);
3928 h
->next_free
= HASH_NEXT (h
, i
);
3929 set_hash_key_slot (h
, i
, key
);
3930 set_hash_value_slot (h
, i
, value
);
3932 /* Remember its hash code. */
3933 set_hash_hash_slot (h
, i
, make_number (hash
));
3935 /* Add new entry to its collision chain. */
3936 start_of_bucket
= hash
% ASIZE (h
->index
);
3937 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3938 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3943 /* Remove the entry matching KEY from hash table H, if there is one. */
3946 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3948 EMACS_UINT hash_code
;
3949 ptrdiff_t start_of_bucket
;
3950 Lisp_Object idx
, prev
;
3952 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3953 eassert ((hash_code
& ~INTMASK
) == 0);
3954 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3955 idx
= HASH_INDEX (h
, start_of_bucket
);
3958 /* We need not gcpro idx, prev since they're either integers or nil. */
3961 ptrdiff_t i
= XFASTINT (idx
);
3963 if (EQ (key
, HASH_KEY (h
, i
))
3965 && hash_code
== XUINT (HASH_HASH (h
, i
))
3966 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3968 /* Take entry out of collision chain. */
3970 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3972 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3974 /* Clear slots in key_and_value and add the slots to
3976 set_hash_key_slot (h
, i
, Qnil
);
3977 set_hash_value_slot (h
, i
, Qnil
);
3978 set_hash_hash_slot (h
, i
, Qnil
);
3979 set_hash_next_slot (h
, i
, h
->next_free
);
3980 h
->next_free
= make_number (i
);
3982 eassert (h
->count
>= 0);
3988 idx
= HASH_NEXT (h
, i
);
3994 /* Clear hash table H. */
3997 hash_clear (struct Lisp_Hash_Table
*h
)
4001 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4003 for (i
= 0; i
< size
; ++i
)
4005 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4006 set_hash_key_slot (h
, i
, Qnil
);
4007 set_hash_value_slot (h
, i
, Qnil
);
4008 set_hash_hash_slot (h
, i
, Qnil
);
4011 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4012 ASET (h
->index
, i
, Qnil
);
4014 h
->next_free
= make_number (0);
4021 /************************************************************************
4023 ************************************************************************/
4025 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4026 entries from the table that don't survive the current GC.
4027 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4028 true if anything was marked. */
4031 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4033 ptrdiff_t bucket
, n
;
4036 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4039 for (bucket
= 0; bucket
< n
; ++bucket
)
4041 Lisp_Object idx
, next
, prev
;
4043 /* Follow collision chain, removing entries that
4044 don't survive this garbage collection. */
4046 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4048 ptrdiff_t i
= XFASTINT (idx
);
4049 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4050 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4053 if (EQ (h
->weak
, Qkey
))
4054 remove_p
= !key_known_to_survive_p
;
4055 else if (EQ (h
->weak
, Qvalue
))
4056 remove_p
= !value_known_to_survive_p
;
4057 else if (EQ (h
->weak
, Qkey_or_value
))
4058 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4059 else if (EQ (h
->weak
, Qkey_and_value
))
4060 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4064 next
= HASH_NEXT (h
, i
);
4066 if (remove_entries_p
)
4070 /* Take out of collision chain. */
4072 set_hash_index_slot (h
, bucket
, next
);
4074 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4076 /* Add to free list. */
4077 set_hash_next_slot (h
, i
, h
->next_free
);
4080 /* Clear key, value, and hash. */
4081 set_hash_key_slot (h
, i
, Qnil
);
4082 set_hash_value_slot (h
, i
, Qnil
);
4083 set_hash_hash_slot (h
, i
, Qnil
);
4096 /* Make sure key and value survive. */
4097 if (!key_known_to_survive_p
)
4099 mark_object (HASH_KEY (h
, i
));
4103 if (!value_known_to_survive_p
)
4105 mark_object (HASH_VALUE (h
, i
));
4116 /* Remove elements from weak hash tables that don't survive the
4117 current garbage collection. Remove weak tables that don't survive
4118 from Vweak_hash_tables. Called from gc_sweep. */
4120 NO_INLINE
/* For better stack traces */
4122 sweep_weak_hash_tables (void)
4124 struct Lisp_Hash_Table
*h
, *used
, *next
;
4127 /* Mark all keys and values that are in use. Keep on marking until
4128 there is no more change. This is necessary for cases like
4129 value-weak table A containing an entry X -> Y, where Y is used in a
4130 key-weak table B, Z -> Y. If B comes after A in the list of weak
4131 tables, X -> Y might be removed from A, although when looking at B
4132 one finds that it shouldn't. */
4136 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4138 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4139 marked
|= sweep_weak_table (h
, 0);
4144 /* Remove tables and entries that aren't used. */
4145 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4147 next
= h
->next_weak
;
4149 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4151 /* TABLE is marked as used. Sweep its contents. */
4153 sweep_weak_table (h
, 1);
4155 /* Add table to the list of used weak hash tables. */
4156 h
->next_weak
= used
;
4161 weak_hash_tables
= used
;
4166 /***********************************************************************
4167 Hash Code Computation
4168 ***********************************************************************/
4170 /* Maximum depth up to which to dive into Lisp structures. */
4172 #define SXHASH_MAX_DEPTH 3
4174 /* Maximum length up to which to take list and vector elements into
4177 #define SXHASH_MAX_LEN 7
4179 /* Return a hash for string PTR which has length LEN. The hash value
4180 can be any EMACS_UINT value. */
4183 hash_string (char const *ptr
, ptrdiff_t len
)
4185 char const *p
= ptr
;
4186 char const *end
= p
+ len
;
4188 EMACS_UINT hash
= 0;
4193 hash
= sxhash_combine (hash
, c
);
4199 /* Return a hash for string PTR which has length LEN. The hash
4200 code returned is guaranteed to fit in a Lisp integer. */
4203 sxhash_string (char const *ptr
, ptrdiff_t len
)
4205 EMACS_UINT hash
= hash_string (ptr
, len
);
4206 return SXHASH_REDUCE (hash
);
4209 /* Return a hash for the floating point value VAL. */
4212 sxhash_float (double val
)
4214 EMACS_UINT hash
= 0;
4216 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4217 + (sizeof val
% sizeof hash
!= 0))
4221 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4225 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4226 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4227 hash
= sxhash_combine (hash
, u
.word
[i
]);
4228 return SXHASH_REDUCE (hash
);
4231 /* Return a hash for list LIST. DEPTH is the current depth in the
4232 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4235 sxhash_list (Lisp_Object list
, int depth
)
4237 EMACS_UINT hash
= 0;
4240 if (depth
< SXHASH_MAX_DEPTH
)
4242 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4243 list
= XCDR (list
), ++i
)
4245 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4246 hash
= sxhash_combine (hash
, hash2
);
4251 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4252 hash
= sxhash_combine (hash
, hash2
);
4255 return SXHASH_REDUCE (hash
);
4259 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4260 the Lisp structure. */
4263 sxhash_vector (Lisp_Object vec
, int depth
)
4265 EMACS_UINT hash
= ASIZE (vec
);
4268 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4269 for (i
= 0; i
< n
; ++i
)
4271 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4272 hash
= sxhash_combine (hash
, hash2
);
4275 return SXHASH_REDUCE (hash
);
4278 /* Return a hash for bool-vector VECTOR. */
4281 sxhash_bool_vector (Lisp_Object vec
)
4283 EMACS_INT size
= bool_vector_size (vec
);
4284 EMACS_UINT hash
= size
;
4287 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4288 for (i
= 0; i
< n
; ++i
)
4289 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4291 return SXHASH_REDUCE (hash
);
4295 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4296 structure. Value is an unsigned integer clipped to INTMASK. */
4299 sxhash (Lisp_Object obj
, int depth
)
4303 if (depth
> SXHASH_MAX_DEPTH
)
4306 switch (XTYPE (obj
))
4317 obj
= SYMBOL_NAME (obj
);
4321 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4324 /* This can be everything from a vector to an overlay. */
4325 case Lisp_Vectorlike
:
4327 /* According to the CL HyperSpec, two arrays are equal only if
4328 they are `eq', except for strings and bit-vectors. In
4329 Emacs, this works differently. We have to compare element
4331 hash
= sxhash_vector (obj
, depth
);
4332 else if (BOOL_VECTOR_P (obj
))
4333 hash
= sxhash_bool_vector (obj
);
4335 /* Others are `equal' if they are `eq', so let's take their
4341 hash
= sxhash_list (obj
, depth
);
4345 hash
= sxhash_float (XFLOAT_DATA (obj
));
4357 /***********************************************************************
4359 ***********************************************************************/
4362 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4363 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4366 EMACS_UINT hash
= sxhash (obj
, 0);
4367 return make_number (hash
);
4371 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4372 doc
: /* Create and return a new hash table.
4374 Arguments are specified as keyword/argument pairs. The following
4375 arguments are defined:
4377 :test TEST -- TEST must be a symbol that specifies how to compare
4378 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4379 `equal'. User-supplied test and hash functions can be specified via
4380 `define-hash-table-test'.
4382 :size SIZE -- A hint as to how many elements will be put in the table.
4385 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4386 fills up. If REHASH-SIZE is an integer, increase the size by that
4387 amount. If it is a float, it must be > 1.0, and the new size is the
4388 old size multiplied by that factor. Default is 1.5.
4390 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4391 Resize the hash table when the ratio (number of entries / table size)
4392 is greater than or equal to THRESHOLD. Default is 0.8.
4394 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4395 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4396 returned is a weak table. Key/value pairs are removed from a weak
4397 hash table when there are no non-weak references pointing to their
4398 key, value, one of key or value, or both key and value, depending on
4399 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4402 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4403 (ptrdiff_t nargs
, Lisp_Object
*args
)
4405 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4406 struct hash_table_test testdesc
;
4410 /* The vector `used' is used to keep track of arguments that
4411 have been consumed. */
4412 used
= alloca (nargs
* sizeof *used
);
4413 memset (used
, 0, nargs
* sizeof *used
);
4415 /* See if there's a `:test TEST' among the arguments. */
4416 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4417 test
= i
? args
[i
] : Qeql
;
4419 testdesc
= hashtest_eq
;
4420 else if (EQ (test
, Qeql
))
4421 testdesc
= hashtest_eql
;
4422 else if (EQ (test
, Qequal
))
4423 testdesc
= hashtest_equal
;
4426 /* See if it is a user-defined test. */
4429 prop
= Fget (test
, Qhash_table_test
);
4430 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4431 signal_error ("Invalid hash table test", test
);
4432 testdesc
.name
= test
;
4433 testdesc
.user_cmp_function
= XCAR (prop
);
4434 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4435 testdesc
.hashfn
= hashfn_user_defined
;
4436 testdesc
.cmpfn
= cmpfn_user_defined
;
4439 /* See if there's a `:size SIZE' argument. */
4440 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4441 size
= i
? args
[i
] : Qnil
;
4443 size
= make_number (DEFAULT_HASH_SIZE
);
4444 else if (!INTEGERP (size
) || XINT (size
) < 0)
4445 signal_error ("Invalid hash table size", size
);
4447 /* Look for `:rehash-size SIZE'. */
4448 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4449 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4450 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4451 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4452 signal_error ("Invalid hash table rehash size", rehash_size
);
4454 /* Look for `:rehash-threshold THRESHOLD'. */
4455 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4456 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4457 if (! (FLOATP (rehash_threshold
)
4458 && 0 < XFLOAT_DATA (rehash_threshold
)
4459 && XFLOAT_DATA (rehash_threshold
) <= 1))
4460 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4462 /* Look for `:weakness WEAK'. */
4463 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4464 weak
= i
? args
[i
] : Qnil
;
4466 weak
= Qkey_and_value
;
4469 && !EQ (weak
, Qvalue
)
4470 && !EQ (weak
, Qkey_or_value
)
4471 && !EQ (weak
, Qkey_and_value
))
4472 signal_error ("Invalid hash table weakness", weak
);
4474 /* Now, all args should have been used up, or there's a problem. */
4475 for (i
= 0; i
< nargs
; ++i
)
4477 signal_error ("Invalid argument list", args
[i
]);
4479 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4483 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4484 doc
: /* Return a copy of hash table TABLE. */)
4487 return copy_hash_table (check_hash_table (table
));
4491 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4492 doc
: /* Return the number of elements in TABLE. */)
4495 return make_number (check_hash_table (table
)->count
);
4499 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4500 Shash_table_rehash_size
, 1, 1, 0,
4501 doc
: /* Return the current rehash size of TABLE. */)
4504 return check_hash_table (table
)->rehash_size
;
4508 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4509 Shash_table_rehash_threshold
, 1, 1, 0,
4510 doc
: /* Return the current rehash threshold of TABLE. */)
4513 return check_hash_table (table
)->rehash_threshold
;
4517 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4518 doc
: /* Return the size of TABLE.
4519 The size can be used as an argument to `make-hash-table' to create
4520 a hash table than can hold as many elements as TABLE holds
4521 without need for resizing. */)
4524 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4525 return make_number (HASH_TABLE_SIZE (h
));
4529 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4530 doc
: /* Return the test TABLE uses. */)
4533 return check_hash_table (table
)->test
.name
;
4537 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4539 doc
: /* Return the weakness of TABLE. */)
4542 return check_hash_table (table
)->weak
;
4546 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4547 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4550 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4554 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4555 doc
: /* Clear hash table TABLE and return it. */)
4558 hash_clear (check_hash_table (table
));
4559 /* Be compatible with XEmacs. */
4564 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4565 doc
: /* Look up KEY in TABLE and return its associated value.
4566 If KEY is not found, return DFLT which defaults to nil. */)
4567 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4569 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4570 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4571 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4575 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4576 doc
: /* Associate KEY with VALUE in hash table TABLE.
4577 If KEY is already present in table, replace its current value with
4578 VALUE. In any case, return VALUE. */)
4579 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4581 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4585 i
= hash_lookup (h
, key
, &hash
);
4587 set_hash_value_slot (h
, i
, value
);
4589 hash_put (h
, key
, value
, hash
);
4595 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4596 doc
: /* Remove KEY from TABLE. */)
4597 (Lisp_Object key
, Lisp_Object table
)
4599 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4600 hash_remove_from_table (h
, key
);
4605 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4606 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4607 FUNCTION is called with two arguments, KEY and VALUE.
4608 `maphash' always returns nil. */)
4609 (Lisp_Object function
, Lisp_Object table
)
4611 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4612 Lisp_Object args
[3];
4615 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4616 if (!NILP (HASH_HASH (h
, i
)))
4619 args
[1] = HASH_KEY (h
, i
);
4620 args
[2] = HASH_VALUE (h
, i
);
4628 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4629 Sdefine_hash_table_test
, 3, 3, 0,
4630 doc
: /* Define a new hash table test with name NAME, a symbol.
4632 In hash tables created with NAME specified as test, use TEST to
4633 compare keys, and HASH for computing hash codes of keys.
4635 TEST must be a function taking two arguments and returning non-nil if
4636 both arguments are the same. HASH must be a function taking one
4637 argument and returning an object that is the hash code of the argument.
4638 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4639 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4640 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4642 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4647 /************************************************************************
4648 MD5, SHA-1, and SHA-2
4649 ************************************************************************/
4656 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4659 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4663 EMACS_INT start_char
= 0, end_char
= 0;
4664 ptrdiff_t start_byte
, end_byte
;
4665 register EMACS_INT b
, e
;
4666 register struct buffer
*bp
;
4669 void *(*hash_func
) (const char *, size_t, void *);
4672 CHECK_SYMBOL (algorithm
);
4674 if (STRINGP (object
))
4676 if (NILP (coding_system
))
4678 /* Decide the coding-system to encode the data with. */
4680 if (STRING_MULTIBYTE (object
))
4681 /* use default, we can't guess correct value */
4682 coding_system
= preferred_coding_system ();
4684 coding_system
= Qraw_text
;
4687 if (NILP (Fcoding_system_p (coding_system
)))
4689 /* Invalid coding system. */
4691 if (!NILP (noerror
))
4692 coding_system
= Qraw_text
;
4694 xsignal1 (Qcoding_system_error
, coding_system
);
4697 if (STRING_MULTIBYTE (object
))
4698 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4700 size
= SCHARS (object
);
4701 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4703 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4704 end_byte
= (end_char
== size
4706 : string_char_to_byte (object
, end_char
));
4710 struct buffer
*prev
= current_buffer
;
4712 record_unwind_current_buffer ();
4714 CHECK_BUFFER (object
);
4716 bp
= XBUFFER (object
);
4717 set_buffer_internal (bp
);
4723 CHECK_NUMBER_COERCE_MARKER (start
);
4731 CHECK_NUMBER_COERCE_MARKER (end
);
4736 temp
= b
, b
= e
, e
= temp
;
4738 if (!(BEGV
<= b
&& e
<= ZV
))
4739 args_out_of_range (start
, end
);
4741 if (NILP (coding_system
))
4743 /* Decide the coding-system to encode the data with.
4744 See fileio.c:Fwrite-region */
4746 if (!NILP (Vcoding_system_for_write
))
4747 coding_system
= Vcoding_system_for_write
;
4750 bool force_raw_text
= 0;
4752 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4753 if (NILP (coding_system
)
4754 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4756 coding_system
= Qnil
;
4757 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4761 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4763 /* Check file-coding-system-alist. */
4764 Lisp_Object args
[4], val
;
4766 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4767 args
[3] = Fbuffer_file_name (object
);
4768 val
= Ffind_operation_coding_system (4, args
);
4769 if (CONSP (val
) && !NILP (XCDR (val
)))
4770 coding_system
= XCDR (val
);
4773 if (NILP (coding_system
)
4774 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4776 /* If we still have not decided a coding system, use the
4777 default value of buffer-file-coding-system. */
4778 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4782 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4783 /* Confirm that VAL can surely encode the current region. */
4784 coding_system
= call4 (Vselect_safe_coding_system_function
,
4785 make_number (b
), make_number (e
),
4786 coding_system
, Qnil
);
4789 coding_system
= Qraw_text
;
4792 if (NILP (Fcoding_system_p (coding_system
)))
4794 /* Invalid coding system. */
4796 if (!NILP (noerror
))
4797 coding_system
= Qraw_text
;
4799 xsignal1 (Qcoding_system_error
, coding_system
);
4803 object
= make_buffer_string (b
, e
, 0);
4804 set_buffer_internal (prev
);
4805 /* Discard the unwind protect for recovering the current
4809 if (STRING_MULTIBYTE (object
))
4810 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4812 end_byte
= SBYTES (object
);
4815 if (EQ (algorithm
, Qmd5
))
4817 digest_size
= MD5_DIGEST_SIZE
;
4818 hash_func
= md5_buffer
;
4820 else if (EQ (algorithm
, Qsha1
))
4822 digest_size
= SHA1_DIGEST_SIZE
;
4823 hash_func
= sha1_buffer
;
4825 else if (EQ (algorithm
, Qsha224
))
4827 digest_size
= SHA224_DIGEST_SIZE
;
4828 hash_func
= sha224_buffer
;
4830 else if (EQ (algorithm
, Qsha256
))
4832 digest_size
= SHA256_DIGEST_SIZE
;
4833 hash_func
= sha256_buffer
;
4835 else if (EQ (algorithm
, Qsha384
))
4837 digest_size
= SHA384_DIGEST_SIZE
;
4838 hash_func
= sha384_buffer
;
4840 else if (EQ (algorithm
, Qsha512
))
4842 digest_size
= SHA512_DIGEST_SIZE
;
4843 hash_func
= sha512_buffer
;
4846 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4848 /* allocate 2 x digest_size so that it can be re-used to hold the
4850 digest
= make_uninit_string (digest_size
* 2);
4852 hash_func (SSDATA (object
) + start_byte
,
4853 end_byte
- start_byte
,
4858 unsigned char *p
= SDATA (digest
);
4859 for (i
= digest_size
- 1; i
>= 0; i
--)
4861 static char const hexdigit
[16] = "0123456789abcdef";
4863 p
[2 * i
] = hexdigit
[p_i
>> 4];
4864 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4869 return make_unibyte_string (SSDATA (digest
), digest_size
);
4872 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4873 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4875 A message digest is a cryptographic checksum of a document, and the
4876 algorithm to calculate it is defined in RFC 1321.
4878 The two optional arguments START and END are character positions
4879 specifying for which part of OBJECT the message digest should be
4880 computed. If nil or omitted, the digest is computed for the whole
4883 The MD5 message digest is computed from the result of encoding the
4884 text in a coding system, not directly from the internal Emacs form of
4885 the text. The optional fourth argument CODING-SYSTEM specifies which
4886 coding system to encode the text with. It should be the same coding
4887 system that you used or will use when actually writing the text into a
4890 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4891 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4892 system would be chosen by default for writing this text into a file.
4894 If OBJECT is a string, the most preferred coding system (see the
4895 command `prefer-coding-system') is used.
4897 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4898 guesswork fails. Normally, an error is signaled in such case. */)
4899 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4901 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4904 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4905 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4906 ALGORITHM is a symbol specifying the hash to use:
4907 md5, sha1, sha224, sha256, sha384 or sha512.
4909 The two optional arguments START and END are positions specifying for
4910 which part of OBJECT to compute the hash. If nil or omitted, uses the
4913 If BINARY is non-nil, returns a string in binary form. */)
4914 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4916 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4922 DEFSYM (Qmd5
, "md5");
4923 DEFSYM (Qsha1
, "sha1");
4924 DEFSYM (Qsha224
, "sha224");
4925 DEFSYM (Qsha256
, "sha256");
4926 DEFSYM (Qsha384
, "sha384");
4927 DEFSYM (Qsha512
, "sha512");
4929 /* Hash table stuff. */
4930 DEFSYM (Qhash_table_p
, "hash-table-p");
4932 DEFSYM (Qeql
, "eql");
4933 DEFSYM (Qequal
, "equal");
4934 DEFSYM (QCtest
, ":test");
4935 DEFSYM (QCsize
, ":size");
4936 DEFSYM (QCrehash_size
, ":rehash-size");
4937 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4938 DEFSYM (QCweakness
, ":weakness");
4939 DEFSYM (Qkey
, "key");
4940 DEFSYM (Qvalue
, "value");
4941 DEFSYM (Qhash_table_test
, "hash-table-test");
4942 DEFSYM (Qkey_or_value
, "key-or-value");
4943 DEFSYM (Qkey_and_value
, "key-and-value");
4946 defsubr (&Smake_hash_table
);
4947 defsubr (&Scopy_hash_table
);
4948 defsubr (&Shash_table_count
);
4949 defsubr (&Shash_table_rehash_size
);
4950 defsubr (&Shash_table_rehash_threshold
);
4951 defsubr (&Shash_table_size
);
4952 defsubr (&Shash_table_test
);
4953 defsubr (&Shash_table_weakness
);
4954 defsubr (&Shash_table_p
);
4955 defsubr (&Sclrhash
);
4956 defsubr (&Sgethash
);
4957 defsubr (&Sputhash
);
4958 defsubr (&Sremhash
);
4959 defsubr (&Smaphash
);
4960 defsubr (&Sdefine_hash_table_test
);
4962 DEFSYM (Qstring_lessp
, "string-lessp");
4963 DEFSYM (Qprovide
, "provide");
4964 DEFSYM (Qrequire
, "require");
4965 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4966 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4967 DEFSYM (Qwidget_type
, "widget-type");
4969 staticpro (&string_char_byte_cache_string
);
4970 string_char_byte_cache_string
= Qnil
;
4972 require_nesting_list
= Qnil
;
4973 staticpro (&require_nesting_list
);
4975 Fset (Qyes_or_no_p_history
, Qnil
);
4977 DEFVAR_LISP ("features", Vfeatures
,
4978 doc
: /* A list of symbols which are the features of the executing Emacs.
4979 Used by `featurep' and `require', and altered by `provide'. */);
4980 Vfeatures
= list1 (intern_c_string ("emacs"));
4981 DEFSYM (Qsubfeatures
, "subfeatures");
4982 DEFSYM (Qfuncall
, "funcall");
4984 #ifdef HAVE_LANGINFO_CODESET
4985 DEFSYM (Qcodeset
, "codeset");
4986 DEFSYM (Qdays
, "days");
4987 DEFSYM (Qmonths
, "months");
4988 DEFSYM (Qpaper
, "paper");
4989 #endif /* HAVE_LANGINFO_CODESET */
4991 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4992 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4993 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4994 invoked by mouse clicks and mouse menu items.
4996 On some platforms, file selection dialogs are also enabled if this is
5000 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5001 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5002 This applies to commands from menus and tool bar buttons even when
5003 they are initiated from the keyboard. If `use-dialog-box' is nil,
5004 that disables the use of a file dialog, regardless of the value of
5006 use_file_dialog
= 1;
5008 defsubr (&Sidentity
);
5011 defsubr (&Ssafe_length
);
5012 defsubr (&Sstring_bytes
);
5013 defsubr (&Sstring_equal
);
5014 defsubr (&Scompare_strings
);
5015 defsubr (&Sstring_lessp
);
5018 defsubr (&Svconcat
);
5019 defsubr (&Scopy_sequence
);
5020 defsubr (&Sstring_make_multibyte
);
5021 defsubr (&Sstring_make_unibyte
);
5022 defsubr (&Sstring_as_multibyte
);
5023 defsubr (&Sstring_as_unibyte
);
5024 defsubr (&Sstring_to_multibyte
);
5025 defsubr (&Sstring_to_unibyte
);
5026 defsubr (&Scopy_alist
);
5027 defsubr (&Ssubstring
);
5028 defsubr (&Ssubstring_no_properties
);
5041 defsubr (&Snreverse
);
5042 defsubr (&Sreverse
);
5044 defsubr (&Splist_get
);
5046 defsubr (&Splist_put
);
5048 defsubr (&Slax_plist_get
);
5049 defsubr (&Slax_plist_put
);
5052 defsubr (&Sequal_including_properties
);
5053 defsubr (&Sfillarray
);
5054 defsubr (&Sclear_string
);
5058 defsubr (&Smapconcat
);
5059 defsubr (&Syes_or_no_p
);
5060 defsubr (&Sload_average
);
5061 defsubr (&Sfeaturep
);
5062 defsubr (&Srequire
);
5063 defsubr (&Sprovide
);
5064 defsubr (&Splist_member
);
5065 defsubr (&Swidget_put
);
5066 defsubr (&Swidget_get
);
5067 defsubr (&Swidget_apply
);
5068 defsubr (&Sbase64_encode_region
);
5069 defsubr (&Sbase64_decode_region
);
5070 defsubr (&Sbase64_encode_string
);
5071 defsubr (&Sbase64_decode_string
);
5073 defsubr (&Ssecure_hash
);
5074 defsubr (&Slocale_info
);
5076 hashtest_eq
.name
= Qeq
;
5077 hashtest_eq
.user_hash_function
= Qnil
;
5078 hashtest_eq
.user_cmp_function
= Qnil
;
5079 hashtest_eq
.cmpfn
= 0;
5080 hashtest_eq
.hashfn
= hashfn_eq
;
5082 hashtest_eql
.name
= Qeql
;
5083 hashtest_eql
.user_hash_function
= Qnil
;
5084 hashtest_eql
.user_cmp_function
= Qnil
;
5085 hashtest_eql
.cmpfn
= cmpfn_eql
;
5086 hashtest_eql
.hashfn
= hashfn_eql
;
5088 hashtest_equal
.name
= Qequal
;
5089 hashtest_equal
.user_hash_function
= Qnil
;
5090 hashtest_equal
.user_cmp_function
= Qnil
;
5091 hashtest_equal
.cmpfn
= cmpfn_equal
;
5092 hashtest_equal
.hashfn
= hashfn_equal
;