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 or vector SEQ.
1701 If SEQ is a list, it should be nil-terminated, and reversed
1702 by modifying cdr pointers. Return the reversed SEQ.
1704 Note that unlike `reverse', this function doesn't work with strings.
1705 It is strongly encouraged to treat them as immutable. */)
1710 else if (CONSP (seq
))
1712 Lisp_Object prev
, tail
, next
;
1714 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1717 CHECK_LIST_CONS (tail
, tail
);
1719 Fsetcdr (tail
, prev
);
1724 else if (VECTORP (seq
))
1726 ptrdiff_t i
, size
= ASIZE (seq
);
1728 for (i
= 0; i
< size
/ 2; i
++)
1730 Lisp_Object tem
= AREF (seq
, i
);
1731 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1732 ASET (seq
, size
- i
- 1, tem
);
1735 else if (BOOL_VECTOR_P (seq
))
1737 ptrdiff_t i
, size
= bool_vector_size (seq
);
1739 for (i
= 0; i
< size
/ 2; i
++)
1741 bool tem
= bool_vector_bitref (seq
, i
);
1742 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1743 bool_vector_set (seq
, size
- i
- 1, tem
);
1747 wrong_type_argument (Qarrayp
, seq
);
1751 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1752 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1753 See also the function `nreverse', which is used more often. */)
1760 else if (CONSP (seq
))
1762 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1765 new = Fcons (XCAR (seq
), new);
1767 CHECK_LIST_END (seq
, seq
);
1769 else if (VECTORP (seq
))
1771 ptrdiff_t i
, size
= ASIZE (seq
);
1773 new = make_uninit_vector (size
);
1774 for (i
= 0; i
< size
; i
++)
1775 ASET (new, i
, AREF (seq
, size
- i
- 1));
1777 else if (BOOL_VECTOR_P (seq
))
1780 EMACS_INT nbits
= bool_vector_size (seq
);
1782 new = make_uninit_bool_vector (nbits
);
1783 for (i
= 0; i
< nbits
; i
++)
1784 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1786 else if (STRINGP (seq
))
1788 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1794 new = make_uninit_string (size
);
1795 for (i
= 0; i
< size
; i
++)
1796 SSET (new, i
, SREF (seq
, size
- i
- 1));
1800 unsigned char *p
, *q
;
1802 new = make_uninit_multibyte_string (size
, bytes
);
1803 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1804 while (q
> SDATA (new))
1808 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1810 CHAR_STRING (ch
, q
);
1815 wrong_type_argument (Qsequencep
, seq
);
1819 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1820 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1821 Returns the sorted list. LIST is modified by side effects.
1822 PREDICATE is called with two elements of LIST, and should return non-nil
1823 if the first element should sort before the second. */)
1824 (Lisp_Object list
, Lisp_Object predicate
)
1826 Lisp_Object front
, back
;
1827 register Lisp_Object len
, tem
;
1828 struct gcpro gcpro1
, gcpro2
;
1832 len
= Flength (list
);
1833 length
= XINT (len
);
1837 XSETINT (len
, (length
/ 2) - 1);
1838 tem
= Fnthcdr (len
, list
);
1840 Fsetcdr (tem
, Qnil
);
1842 GCPRO2 (front
, back
);
1843 front
= Fsort (front
, predicate
);
1844 back
= Fsort (back
, predicate
);
1846 return merge (front
, back
, predicate
);
1850 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1853 register Lisp_Object tail
;
1855 register Lisp_Object l1
, l2
;
1856 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1863 /* It is sufficient to protect org_l1 and org_l2.
1864 When l1 and l2 are updated, we copy the new values
1865 back into the org_ vars. */
1866 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1886 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1902 Fsetcdr (tail
, tem
);
1908 /* This does not check for quits. That is safe since it must terminate. */
1910 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1911 doc
: /* Extract a value from a property list.
1912 PLIST is a property list, which is a list of the form
1913 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1914 corresponding to the given PROP, or nil if PROP is not one of the
1915 properties on the list. This function never signals an error. */)
1916 (Lisp_Object plist
, Lisp_Object prop
)
1918 Lisp_Object tail
, halftail
;
1920 /* halftail is used to detect circular lists. */
1921 tail
= halftail
= plist
;
1922 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1924 if (EQ (prop
, XCAR (tail
)))
1925 return XCAR (XCDR (tail
));
1927 tail
= XCDR (XCDR (tail
));
1928 halftail
= XCDR (halftail
);
1929 if (EQ (tail
, halftail
))
1936 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1937 doc
: /* Return the value of SYMBOL's PROPNAME property.
1938 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1939 (Lisp_Object symbol
, Lisp_Object propname
)
1941 CHECK_SYMBOL (symbol
);
1942 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1945 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1946 doc
: /* Change value in PLIST of PROP to VAL.
1947 PLIST is a property list, which is a list of the form
1948 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1949 If PROP is already a property on the list, its value is set to VAL,
1950 otherwise the new PROP VAL pair is added. The new plist is returned;
1951 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1952 The PLIST is modified by side effects. */)
1953 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1955 register Lisp_Object tail
, prev
;
1956 Lisp_Object newcell
;
1958 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1959 tail
= XCDR (XCDR (tail
)))
1961 if (EQ (prop
, XCAR (tail
)))
1963 Fsetcar (XCDR (tail
), val
);
1970 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1974 Fsetcdr (XCDR (prev
), newcell
);
1978 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1979 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1980 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1981 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1983 CHECK_SYMBOL (symbol
);
1985 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1989 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1990 doc
: /* Extract a value from a property list, comparing with `equal'.
1991 PLIST is a property list, which is a list of the form
1992 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1993 corresponding to the given PROP, or nil if PROP is not
1994 one of the properties on the list. */)
1995 (Lisp_Object plist
, Lisp_Object prop
)
2000 CONSP (tail
) && CONSP (XCDR (tail
));
2001 tail
= XCDR (XCDR (tail
)))
2003 if (! NILP (Fequal (prop
, XCAR (tail
))))
2004 return XCAR (XCDR (tail
));
2009 CHECK_LIST_END (tail
, prop
);
2014 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2015 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2016 PLIST is a property list, which is a list of the form
2017 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2018 If PROP is already a property on the list, its value is set to VAL,
2019 otherwise the new PROP VAL pair is added. The new plist is returned;
2020 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2021 The PLIST is modified by side effects. */)
2022 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2024 register Lisp_Object tail
, prev
;
2025 Lisp_Object newcell
;
2027 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2028 tail
= XCDR (XCDR (tail
)))
2030 if (! NILP (Fequal (prop
, XCAR (tail
))))
2032 Fsetcar (XCDR (tail
), val
);
2039 newcell
= list2 (prop
, val
);
2043 Fsetcdr (XCDR (prev
), newcell
);
2047 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2048 doc
: /* Return t if the two args are the same Lisp object.
2049 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2050 (Lisp_Object obj1
, Lisp_Object obj2
)
2053 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2055 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2058 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2059 doc
: /* Return t if two Lisp objects have similar structure and contents.
2060 They must have the same data type.
2061 Conses are compared by comparing the cars and the cdrs.
2062 Vectors and strings are compared element by element.
2063 Numbers are compared by value, but integers cannot equal floats.
2064 (Use `=' if you want integers and floats to be able to be equal.)
2065 Symbols must match exactly. */)
2066 (register Lisp_Object o1
, Lisp_Object o2
)
2068 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2071 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2072 doc
: /* Return t if two Lisp objects have similar structure and contents.
2073 This is like `equal' except that it compares the text properties
2074 of strings. (`equal' ignores text properties.) */)
2075 (register Lisp_Object o1
, Lisp_Object o2
)
2077 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2080 /* DEPTH is current depth of recursion. Signal an error if it
2082 PROPS means compare string text properties too. */
2085 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2091 error ("Stack overflow in equal");
2094 Lisp_Object args
[2];
2097 ht
= Fmake_hash_table (2, args
);
2101 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2103 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2105 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2107 { /* `o1' was seen already. */
2108 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2109 if (!NILP (Fmemq (o2
, o2s
)))
2112 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2115 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2125 if (XTYPE (o1
) != XTYPE (o2
))
2134 d1
= extract_float (o1
);
2135 d2
= extract_float (o2
);
2136 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2137 though they are not =. */
2138 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2142 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2146 /* FIXME: This inf-loops in a circular list! */
2150 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2154 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2155 depth
+ 1, props
, ht
)
2156 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2157 depth
+ 1, props
, ht
))
2159 o1
= XOVERLAY (o1
)->plist
;
2160 o2
= XOVERLAY (o2
)->plist
;
2165 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2166 && (XMARKER (o1
)->buffer
== 0
2167 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2171 case Lisp_Vectorlike
:
2174 ptrdiff_t size
= ASIZE (o1
);
2175 /* Pseudovectors have the type encoded in the size field, so this test
2176 actually checks that the objects have the same type as well as the
2178 if (ASIZE (o2
) != size
)
2180 /* Boolvectors are compared much like strings. */
2181 if (BOOL_VECTOR_P (o1
))
2183 EMACS_INT size
= bool_vector_size (o1
);
2184 if (size
!= bool_vector_size (o2
))
2186 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2187 bool_vector_bytes (size
)))
2191 if (WINDOW_CONFIGURATIONP (o1
))
2192 return compare_window_configurations (o1
, o2
, 0);
2194 /* Aside from them, only true vectors, char-tables, compiled
2195 functions, and fonts (font-spec, font-entity, font-object)
2196 are sensible to compare, so eliminate the others now. */
2197 if (size
& PSEUDOVECTOR_FLAG
)
2199 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2202 size
&= PSEUDOVECTOR_SIZE_MASK
;
2204 for (i
= 0; i
< size
; i
++)
2209 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2217 if (SCHARS (o1
) != SCHARS (o2
))
2219 if (SBYTES (o1
) != SBYTES (o2
))
2221 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2223 if (props
&& !compare_string_intervals (o1
, o2
))
2235 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2236 doc
: /* Store each element of ARRAY with ITEM.
2237 ARRAY is a vector, string, char-table, or bool-vector. */)
2238 (Lisp_Object array
, Lisp_Object item
)
2240 register ptrdiff_t size
, idx
;
2242 if (VECTORP (array
))
2243 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2244 ASET (array
, idx
, item
);
2245 else if (CHAR_TABLE_P (array
))
2249 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2250 set_char_table_contents (array
, i
, item
);
2251 set_char_table_defalt (array
, item
);
2253 else if (STRINGP (array
))
2255 register unsigned char *p
= SDATA (array
);
2257 CHECK_CHARACTER (item
);
2258 charval
= XFASTINT (item
);
2259 size
= SCHARS (array
);
2260 if (STRING_MULTIBYTE (array
))
2262 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2263 int len
= CHAR_STRING (charval
, str
);
2264 ptrdiff_t size_byte
= SBYTES (array
);
2266 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2267 || SCHARS (array
) * len
!= size_byte
)
2268 error ("Attempt to change byte length of a string");
2269 for (idx
= 0; idx
< size_byte
; idx
++)
2270 *p
++ = str
[idx
% len
];
2273 for (idx
= 0; idx
< size
; idx
++)
2276 else if (BOOL_VECTOR_P (array
))
2277 return bool_vector_fill (array
, item
);
2279 wrong_type_argument (Qarrayp
, array
);
2283 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2285 doc
: /* Clear the contents of STRING.
2286 This makes STRING unibyte and may change its length. */)
2287 (Lisp_Object string
)
2290 CHECK_STRING (string
);
2291 len
= SBYTES (string
);
2292 memset (SDATA (string
), 0, len
);
2293 STRING_SET_CHARS (string
, len
);
2294 STRING_SET_UNIBYTE (string
);
2300 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2302 Lisp_Object args
[2];
2305 return Fnconc (2, args
);
2308 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2309 doc
: /* Concatenate any number of lists by altering them.
2310 Only the last argument is not altered, and need not be a list.
2311 usage: (nconc &rest LISTS) */)
2312 (ptrdiff_t nargs
, Lisp_Object
*args
)
2315 register Lisp_Object tail
, tem
, val
;
2319 for (argnum
= 0; argnum
< nargs
; argnum
++)
2322 if (NILP (tem
)) continue;
2327 if (argnum
+ 1 == nargs
) break;
2329 CHECK_LIST_CONS (tem
, tem
);
2338 tem
= args
[argnum
+ 1];
2339 Fsetcdr (tail
, tem
);
2341 args
[argnum
+ 1] = tail
;
2347 /* This is the guts of all mapping functions.
2348 Apply FN to each element of SEQ, one by one,
2349 storing the results into elements of VALS, a C vector of Lisp_Objects.
2350 LENI is the length of VALS, which should also be the length of SEQ. */
2353 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2355 register Lisp_Object tail
;
2357 register EMACS_INT i
;
2358 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2362 /* Don't let vals contain any garbage when GC happens. */
2363 for (i
= 0; i
< leni
; i
++)
2366 GCPRO3 (dummy
, fn
, seq
);
2368 gcpro1
.nvars
= leni
;
2372 /* We need not explicitly protect `tail' because it is used only on lists, and
2373 1) lists are not relocated and 2) the list is marked via `seq' so will not
2376 if (VECTORP (seq
) || COMPILEDP (seq
))
2378 for (i
= 0; i
< leni
; i
++)
2380 dummy
= call1 (fn
, AREF (seq
, i
));
2385 else if (BOOL_VECTOR_P (seq
))
2387 for (i
= 0; i
< leni
; i
++)
2389 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2394 else if (STRINGP (seq
))
2398 for (i
= 0, i_byte
= 0; i
< leni
;)
2401 ptrdiff_t i_before
= i
;
2403 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2404 XSETFASTINT (dummy
, c
);
2405 dummy
= call1 (fn
, dummy
);
2407 vals
[i_before
] = dummy
;
2410 else /* Must be a list, since Flength did not get an error */
2413 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2415 dummy
= call1 (fn
, XCAR (tail
));
2425 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2426 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2427 In between each pair of results, stick in SEPARATOR. Thus, " " as
2428 SEPARATOR results in spaces between the values returned by FUNCTION.
2429 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2430 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2433 register EMACS_INT leni
;
2436 register Lisp_Object
*args
;
2437 struct gcpro gcpro1
;
2441 len
= Flength (sequence
);
2442 if (CHAR_TABLE_P (sequence
))
2443 wrong_type_argument (Qlistp
, sequence
);
2445 nargs
= leni
+ leni
- 1;
2446 if (nargs
< 0) return empty_unibyte_string
;
2448 SAFE_ALLOCA_LISP (args
, nargs
);
2451 mapcar1 (leni
, args
, function
, sequence
);
2454 for (i
= leni
- 1; i
> 0; i
--)
2455 args
[i
+ i
] = args
[i
];
2457 for (i
= 1; i
< nargs
; i
+= 2)
2458 args
[i
] = separator
;
2460 ret
= Fconcat (nargs
, args
);
2466 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2467 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2468 The result is a list just as long as SEQUENCE.
2469 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2470 (Lisp_Object function
, Lisp_Object sequence
)
2472 register Lisp_Object len
;
2473 register EMACS_INT leni
;
2474 register Lisp_Object
*args
;
2478 len
= Flength (sequence
);
2479 if (CHAR_TABLE_P (sequence
))
2480 wrong_type_argument (Qlistp
, sequence
);
2481 leni
= XFASTINT (len
);
2483 SAFE_ALLOCA_LISP (args
, leni
);
2485 mapcar1 (leni
, args
, function
, sequence
);
2487 ret
= Flist (leni
, args
);
2493 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2494 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2495 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2496 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2497 (Lisp_Object function
, Lisp_Object sequence
)
2499 register EMACS_INT leni
;
2501 leni
= XFASTINT (Flength (sequence
));
2502 if (CHAR_TABLE_P (sequence
))
2503 wrong_type_argument (Qlistp
, sequence
);
2504 mapcar1 (leni
, 0, function
, sequence
);
2509 /* This is how C code calls `yes-or-no-p' and allows the user
2512 Anything that calls this function must protect from GC! */
2515 do_yes_or_no_p (Lisp_Object prompt
)
2517 return call1 (intern ("yes-or-no-p"), prompt
);
2520 /* Anything that calls this function must protect from GC! */
2522 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2523 doc
: /* Ask user a yes-or-no question.
2524 Return t if answer is yes, and nil if the answer is no.
2525 PROMPT is the string to display to ask the question. It should end in
2526 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2528 The user must confirm the answer with RET, and can edit it until it
2531 If dialog boxes are supported, a dialog box will be used
2532 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2533 (Lisp_Object prompt
)
2535 register Lisp_Object ans
;
2536 Lisp_Object args
[2];
2537 struct gcpro gcpro1
;
2539 CHECK_STRING (prompt
);
2541 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2544 Lisp_Object pane
, menu
, obj
;
2545 redisplay_preserve_echo_area (4);
2546 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2547 Fcons (build_string ("No"), Qnil
));
2549 menu
= Fcons (prompt
, pane
);
2550 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2556 args
[1] = build_string ("(yes or no) ");
2557 prompt
= Fconcat (2, args
);
2563 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2564 Qyes_or_no_p_history
, Qnil
,
2566 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2571 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2579 message1 ("Please answer yes or no.");
2580 Fsleep_for (make_number (2), Qnil
);
2584 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2585 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2587 Each of the three load averages is multiplied by 100, then converted
2590 When USE-FLOATS is non-nil, floats will be used instead of integers.
2591 These floats are not multiplied by 100.
2593 If the 5-minute or 15-minute load averages are not available, return a
2594 shortened list, containing only those averages which are available.
2596 An error is thrown if the load average can't be obtained. In some
2597 cases making it work would require Emacs being installed setuid or
2598 setgid so that it can read kernel information, and that usually isn't
2600 (Lisp_Object use_floats
)
2603 int loads
= getloadavg (load_ave
, 3);
2604 Lisp_Object ret
= Qnil
;
2607 error ("load-average not implemented for this operating system");
2611 Lisp_Object load
= (NILP (use_floats
)
2612 ? make_number (100.0 * load_ave
[loads
])
2613 : make_float (load_ave
[loads
]));
2614 ret
= Fcons (load
, ret
);
2620 static Lisp_Object Qsubfeatures
;
2622 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2623 doc
: /* Return t if FEATURE is present in this Emacs.
2625 Use this to conditionalize execution of lisp code based on the
2626 presence or absence of Emacs or environment extensions.
2627 Use `provide' to declare that a feature is available. This function
2628 looks at the value of the variable `features'. The optional argument
2629 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2630 (Lisp_Object feature
, Lisp_Object subfeature
)
2632 register Lisp_Object tem
;
2633 CHECK_SYMBOL (feature
);
2634 tem
= Fmemq (feature
, Vfeatures
);
2635 if (!NILP (tem
) && !NILP (subfeature
))
2636 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2637 return (NILP (tem
)) ? Qnil
: Qt
;
2640 static Lisp_Object Qfuncall
;
2642 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2643 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2644 The optional argument SUBFEATURES should be a list of symbols listing
2645 particular subfeatures supported in this version of FEATURE. */)
2646 (Lisp_Object feature
, Lisp_Object subfeatures
)
2648 register Lisp_Object tem
;
2649 CHECK_SYMBOL (feature
);
2650 CHECK_LIST (subfeatures
);
2651 if (!NILP (Vautoload_queue
))
2652 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2654 tem
= Fmemq (feature
, Vfeatures
);
2656 Vfeatures
= Fcons (feature
, Vfeatures
);
2657 if (!NILP (subfeatures
))
2658 Fput (feature
, Qsubfeatures
, subfeatures
);
2659 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2661 /* Run any load-hooks for this file. */
2662 tem
= Fassq (feature
, Vafter_load_alist
);
2664 Fmapc (Qfuncall
, XCDR (tem
));
2669 /* `require' and its subroutines. */
2671 /* List of features currently being require'd, innermost first. */
2673 static Lisp_Object require_nesting_list
;
2676 require_unwind (Lisp_Object old_value
)
2678 require_nesting_list
= old_value
;
2681 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2682 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2683 If FEATURE is not a member of the list `features', then the feature
2684 is not loaded; so load the file FILENAME.
2685 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2686 and `load' will try to load this name appended with the suffix `.elc' or
2687 `.el', in that order. The name without appended suffix will not be used.
2688 See `get-load-suffixes' for the complete list of suffixes.
2689 If the optional third argument NOERROR is non-nil,
2690 then return nil if the file is not found instead of signaling an error.
2691 Normally the return value is FEATURE.
2692 The normal messages at start and end of loading FILENAME are suppressed. */)
2693 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2696 struct gcpro gcpro1
, gcpro2
;
2697 bool from_file
= load_in_progress
;
2699 CHECK_SYMBOL (feature
);
2701 /* Record the presence of `require' in this file
2702 even if the feature specified is already loaded.
2703 But not more than once in any file,
2704 and not when we aren't loading or reading from a file. */
2706 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2707 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2712 tem
= Fcons (Qrequire
, feature
);
2713 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2714 LOADHIST_ATTACH (tem
);
2716 tem
= Fmemq (feature
, Vfeatures
);
2720 ptrdiff_t count
= SPECPDL_INDEX ();
2723 /* This is to make sure that loadup.el gives a clear picture
2724 of what files are preloaded and when. */
2725 if (! NILP (Vpurify_flag
))
2726 error ("(require %s) while preparing to dump",
2727 SDATA (SYMBOL_NAME (feature
)));
2729 /* A certain amount of recursive `require' is legitimate,
2730 but if we require the same feature recursively 3 times,
2732 tem
= require_nesting_list
;
2733 while (! NILP (tem
))
2735 if (! NILP (Fequal (feature
, XCAR (tem
))))
2740 error ("Recursive `require' for feature `%s'",
2741 SDATA (SYMBOL_NAME (feature
)));
2743 /* Update the list for any nested `require's that occur. */
2744 record_unwind_protect (require_unwind
, require_nesting_list
);
2745 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2747 /* Value saved here is to be restored into Vautoload_queue */
2748 record_unwind_protect (un_autoload
, Vautoload_queue
);
2749 Vautoload_queue
= Qt
;
2751 /* Load the file. */
2752 GCPRO2 (feature
, filename
);
2753 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2754 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2757 /* If load failed entirely, return nil. */
2759 return unbind_to (count
, Qnil
);
2761 tem
= Fmemq (feature
, Vfeatures
);
2763 error ("Required feature `%s' was not provided",
2764 SDATA (SYMBOL_NAME (feature
)));
2766 /* Once loading finishes, don't undo it. */
2767 Vautoload_queue
= Qt
;
2768 feature
= unbind_to (count
, feature
);
2774 /* Primitives for work of the "widget" library.
2775 In an ideal world, this section would not have been necessary.
2776 However, lisp function calls being as slow as they are, it turns
2777 out that some functions in the widget library (wid-edit.el) are the
2778 bottleneck of Widget operation. Here is their translation to C,
2779 for the sole reason of efficiency. */
2781 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2782 doc
: /* Return non-nil if PLIST has the property PROP.
2783 PLIST is a property list, which is a list of the form
2784 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2785 Unlike `plist-get', this allows you to distinguish between a missing
2786 property and a property with the value nil.
2787 The value is actually the tail of PLIST whose car is PROP. */)
2788 (Lisp_Object plist
, Lisp_Object prop
)
2790 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2793 plist
= XCDR (plist
);
2794 plist
= CDR (plist
);
2799 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2800 doc
: /* In WIDGET, set PROPERTY to VALUE.
2801 The value can later be retrieved with `widget-get'. */)
2802 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2804 CHECK_CONS (widget
);
2805 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2809 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2810 doc
: /* In WIDGET, get the value of PROPERTY.
2811 The value could either be specified when the widget was created, or
2812 later with `widget-put'. */)
2813 (Lisp_Object widget
, Lisp_Object property
)
2821 CHECK_CONS (widget
);
2822 tmp
= Fplist_member (XCDR (widget
), property
);
2828 tmp
= XCAR (widget
);
2831 widget
= Fget (tmp
, Qwidget_type
);
2835 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2836 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2837 ARGS are passed as extra arguments to the function.
2838 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2839 (ptrdiff_t nargs
, Lisp_Object
*args
)
2841 /* This function can GC. */
2842 Lisp_Object newargs
[3];
2843 struct gcpro gcpro1
, gcpro2
;
2846 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2847 newargs
[1] = args
[0];
2848 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2849 GCPRO2 (newargs
[0], newargs
[2]);
2850 result
= Fapply (3, newargs
);
2855 #ifdef HAVE_LANGINFO_CODESET
2856 #include <langinfo.h>
2859 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2860 doc
: /* Access locale data ITEM for the current C locale, if available.
2861 ITEM should be one of the following:
2863 `codeset', returning the character set as a string (locale item CODESET);
2865 `days', returning a 7-element vector of day names (locale items DAY_n);
2867 `months', returning a 12-element vector of month names (locale items MON_n);
2869 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2870 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2872 If the system can't provide such information through a call to
2873 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2875 See also Info node `(libc)Locales'.
2877 The data read from the system are decoded using `locale-coding-system'. */)
2881 #ifdef HAVE_LANGINFO_CODESET
2883 if (EQ (item
, Qcodeset
))
2885 str
= nl_langinfo (CODESET
);
2886 return build_string (str
);
2889 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2891 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2892 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2894 struct gcpro gcpro1
;
2896 synchronize_system_time_locale ();
2897 for (i
= 0; i
< 7; i
++)
2899 str
= nl_langinfo (days
[i
]);
2900 val
= build_unibyte_string (str
);
2901 /* Fixme: Is this coding system necessarily right, even if
2902 it is consistent with CODESET? If not, what to do? */
2903 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2911 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2913 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2914 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2915 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2917 struct gcpro gcpro1
;
2919 synchronize_system_time_locale ();
2920 for (i
= 0; i
< 12; i
++)
2922 str
= nl_langinfo (months
[i
]);
2923 val
= build_unibyte_string (str
);
2924 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2931 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2932 but is in the locale files. This could be used by ps-print. */
2934 else if (EQ (item
, Qpaper
))
2935 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2936 #endif /* PAPER_WIDTH */
2937 #endif /* HAVE_LANGINFO_CODESET*/
2941 /* base64 encode/decode functions (RFC 2045).
2942 Based on code from GNU recode. */
2944 #define MIME_LINE_LENGTH 76
2946 #define IS_ASCII(Character) \
2948 #define IS_BASE64(Character) \
2949 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2950 #define IS_BASE64_IGNORABLE(Character) \
2951 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2952 || (Character) == '\f' || (Character) == '\r')
2954 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2955 character or return retval if there are no characters left to
2957 #define READ_QUADRUPLET_BYTE(retval) \
2962 if (nchars_return) \
2963 *nchars_return = nchars; \
2968 while (IS_BASE64_IGNORABLE (c))
2970 /* Table of characters coding the 64 values. */
2971 static const char base64_value_to_char
[64] =
2973 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2974 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2975 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2976 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2977 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2978 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2979 '8', '9', '+', '/' /* 60-63 */
2982 /* Table of base64 values for first 128 characters. */
2983 static const short base64_char_to_value
[128] =
2985 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2986 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2987 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2988 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2989 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2990 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2991 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2992 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2993 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2994 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2995 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2996 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2997 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3000 /* The following diagram shows the logical steps by which three octets
3001 get transformed into four base64 characters.
3003 .--------. .--------. .--------.
3004 |aaaaaabb| |bbbbcccc| |ccdddddd|
3005 `--------' `--------' `--------'
3007 .--------+--------+--------+--------.
3008 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3009 `--------+--------+--------+--------'
3011 .--------+--------+--------+--------.
3012 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3013 `--------+--------+--------+--------'
3015 The octets are divided into 6 bit chunks, which are then encoded into
3016 base64 characters. */
3019 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3020 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3023 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3025 doc
: /* Base64-encode the region between BEG and END.
3026 Return the length of the encoded text.
3027 Optional third argument NO-LINE-BREAK means do not break long lines
3028 into shorter lines. */)
3029 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3032 ptrdiff_t allength
, length
;
3033 ptrdiff_t ibeg
, iend
, encoded_length
;
3034 ptrdiff_t old_pos
= PT
;
3037 validate_region (&beg
, &end
);
3039 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3040 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3041 move_gap_both (XFASTINT (beg
), ibeg
);
3043 /* We need to allocate enough room for encoding the text.
3044 We need 33 1/3% more space, plus a newline every 76
3045 characters, and then we round up. */
3046 length
= iend
- ibeg
;
3047 allength
= length
+ length
/3 + 1;
3048 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3050 encoded
= SAFE_ALLOCA (allength
);
3051 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3052 encoded
, length
, NILP (no_line_break
),
3053 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3054 if (encoded_length
> allength
)
3057 if (encoded_length
< 0)
3059 /* The encoding wasn't possible. */
3061 error ("Multibyte character in data for base64 encoding");
3064 /* Now we have encoded the region, so we insert the new contents
3065 and delete the old. (Insert first in order to preserve markers.) */
3066 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3067 insert (encoded
, encoded_length
);
3069 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3071 /* If point was outside of the region, restore it exactly; else just
3072 move to the beginning of the region. */
3073 if (old_pos
>= XFASTINT (end
))
3074 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3075 else if (old_pos
> XFASTINT (beg
))
3076 old_pos
= XFASTINT (beg
);
3079 /* We return the length of the encoded text. */
3080 return make_number (encoded_length
);
3083 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3085 doc
: /* Base64-encode STRING and return the result.
3086 Optional second argument NO-LINE-BREAK means do not break long lines
3087 into shorter lines. */)
3088 (Lisp_Object string
, Lisp_Object no_line_break
)
3090 ptrdiff_t allength
, length
, encoded_length
;
3092 Lisp_Object encoded_string
;
3095 CHECK_STRING (string
);
3097 /* We need to allocate enough room for encoding the text.
3098 We need 33 1/3% more space, plus a newline every 76
3099 characters, and then we round up. */
3100 length
= SBYTES (string
);
3101 allength
= length
+ length
/3 + 1;
3102 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3104 /* We need to allocate enough room for decoding the text. */
3105 encoded
= SAFE_ALLOCA (allength
);
3107 encoded_length
= base64_encode_1 (SSDATA (string
),
3108 encoded
, length
, NILP (no_line_break
),
3109 STRING_MULTIBYTE (string
));
3110 if (encoded_length
> allength
)
3113 if (encoded_length
< 0)
3115 /* The encoding wasn't possible. */
3117 error ("Multibyte character in data for base64 encoding");
3120 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3123 return encoded_string
;
3127 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3128 bool line_break
, bool multibyte
)
3141 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3142 if (CHAR_BYTE8_P (c
))
3143 c
= CHAR_TO_BYTE8 (c
);
3151 /* Wrap line every 76 characters. */
3155 if (counter
< MIME_LINE_LENGTH
/ 4)
3164 /* Process first byte of a triplet. */
3166 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3167 value
= (0x03 & c
) << 4;
3169 /* Process second byte of a triplet. */
3173 *e
++ = base64_value_to_char
[value
];
3181 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3182 if (CHAR_BYTE8_P (c
))
3183 c
= CHAR_TO_BYTE8 (c
);
3191 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3192 value
= (0x0f & c
) << 2;
3194 /* Process third byte of a triplet. */
3198 *e
++ = base64_value_to_char
[value
];
3205 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3206 if (CHAR_BYTE8_P (c
))
3207 c
= CHAR_TO_BYTE8 (c
);
3215 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3216 *e
++ = base64_value_to_char
[0x3f & c
];
3223 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3225 doc
: /* Base64-decode the region between BEG and END.
3226 Return the length of the decoded text.
3227 If the region can't be decoded, signal an error and don't modify the buffer. */)
3228 (Lisp_Object beg
, Lisp_Object end
)
3230 ptrdiff_t ibeg
, iend
, length
, allength
;
3232 ptrdiff_t old_pos
= PT
;
3233 ptrdiff_t decoded_length
;
3234 ptrdiff_t inserted_chars
;
3235 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3238 validate_region (&beg
, &end
);
3240 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3241 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3243 length
= iend
- ibeg
;
3245 /* We need to allocate enough room for decoding the text. If we are
3246 working on a multibyte buffer, each decoded code may occupy at
3248 allength
= multibyte
? length
* 2 : length
;
3249 decoded
= SAFE_ALLOCA (allength
);
3251 move_gap_both (XFASTINT (beg
), ibeg
);
3252 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3254 multibyte
, &inserted_chars
);
3255 if (decoded_length
> allength
)
3258 if (decoded_length
< 0)
3260 /* The decoding wasn't possible. */
3262 error ("Invalid base64 data");
3265 /* Now we have decoded the region, so we insert the new contents
3266 and delete the old. (Insert first in order to preserve markers.) */
3267 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3268 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3271 /* Delete the original text. */
3272 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3273 iend
+ decoded_length
, 1);
3275 /* If point was outside of the region, restore it exactly; else just
3276 move to the beginning of the region. */
3277 if (old_pos
>= XFASTINT (end
))
3278 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3279 else if (old_pos
> XFASTINT (beg
))
3280 old_pos
= XFASTINT (beg
);
3281 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3283 return make_number (inserted_chars
);
3286 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3288 doc
: /* Base64-decode STRING and return the result. */)
3289 (Lisp_Object string
)
3292 ptrdiff_t length
, decoded_length
;
3293 Lisp_Object decoded_string
;
3296 CHECK_STRING (string
);
3298 length
= SBYTES (string
);
3299 /* We need to allocate enough room for decoding the text. */
3300 decoded
= SAFE_ALLOCA (length
);
3302 /* The decoded result should be unibyte. */
3303 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3305 if (decoded_length
> length
)
3307 else if (decoded_length
>= 0)
3308 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3310 decoded_string
= Qnil
;
3313 if (!STRINGP (decoded_string
))
3314 error ("Invalid base64 data");
3316 return decoded_string
;
3319 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3320 MULTIBYTE, the decoded result should be in multibyte
3321 form. If NCHARS_RETURN is not NULL, store the number of produced
3322 characters in *NCHARS_RETURN. */
3325 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3326 bool multibyte
, ptrdiff_t *nchars_return
)
3328 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3331 unsigned long value
;
3332 ptrdiff_t nchars
= 0;
3336 /* Process first byte of a quadruplet. */
3338 READ_QUADRUPLET_BYTE (e
-to
);
3342 value
= base64_char_to_value
[c
] << 18;
3344 /* Process second byte of a quadruplet. */
3346 READ_QUADRUPLET_BYTE (-1);
3350 value
|= base64_char_to_value
[c
] << 12;
3352 c
= (unsigned char) (value
>> 16);
3353 if (multibyte
&& c
>= 128)
3354 e
+= BYTE8_STRING (c
, e
);
3359 /* Process third byte of a quadruplet. */
3361 READ_QUADRUPLET_BYTE (-1);
3365 READ_QUADRUPLET_BYTE (-1);
3374 value
|= base64_char_to_value
[c
] << 6;
3376 c
= (unsigned char) (0xff & value
>> 8);
3377 if (multibyte
&& c
>= 128)
3378 e
+= BYTE8_STRING (c
, e
);
3383 /* Process fourth byte of a quadruplet. */
3385 READ_QUADRUPLET_BYTE (-1);
3392 value
|= base64_char_to_value
[c
];
3394 c
= (unsigned char) (0xff & value
);
3395 if (multibyte
&& c
>= 128)
3396 e
+= BYTE8_STRING (c
, e
);
3405 /***********************************************************************
3407 ***** Hash Tables *****
3409 ***********************************************************************/
3411 /* Implemented by gerd@gnu.org. This hash table implementation was
3412 inspired by CMUCL hash tables. */
3416 1. For small tables, association lists are probably faster than
3417 hash tables because they have lower overhead.
3419 For uses of hash tables where the O(1) behavior of table
3420 operations is not a requirement, it might therefore be a good idea
3421 not to hash. Instead, we could just do a linear search in the
3422 key_and_value vector of the hash table. This could be done
3423 if a `:linear-search t' argument is given to make-hash-table. */
3426 /* The list of all weak hash tables. Don't staticpro this one. */
3428 static struct Lisp_Hash_Table
*weak_hash_tables
;
3430 /* Various symbols. */
3432 static Lisp_Object Qhash_table_p
;
3433 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3434 Lisp_Object Qeq
, Qequal
;
3435 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3436 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3439 /***********************************************************************
3441 ***********************************************************************/
3444 CHECK_HASH_TABLE (Lisp_Object x
)
3446 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3450 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3452 h
->key_and_value
= key_and_value
;
3455 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3460 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3462 gc_aset (h
->next
, idx
, val
);
3465 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3470 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3472 gc_aset (h
->hash
, idx
, val
);
3475 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3480 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3482 gc_aset (h
->index
, idx
, val
);
3485 /* If OBJ is a Lisp hash table, return a pointer to its struct
3486 Lisp_Hash_Table. Otherwise, signal an error. */
3488 static struct Lisp_Hash_Table
*
3489 check_hash_table (Lisp_Object obj
)
3491 CHECK_HASH_TABLE (obj
);
3492 return XHASH_TABLE (obj
);
3496 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3497 number. A number is "almost" a prime number if it is not divisible
3498 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3501 next_almost_prime (EMACS_INT n
)
3503 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3504 for (n
|= 1; ; n
+= 2)
3505 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3510 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3511 which USED[I] is non-zero. If found at index I in ARGS, set
3512 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3513 0. This function is used to extract a keyword/argument pair from
3514 a DEFUN parameter list. */
3517 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3521 for (i
= 1; i
< nargs
; i
++)
3522 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3533 /* Return a Lisp vector which has the same contents as VEC but has
3534 at least INCR_MIN more entries, where INCR_MIN is positive.
3535 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3536 than NITEMS_MAX. Entries in the resulting
3537 vector that are not copied from VEC are set to nil. */
3540 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3542 struct Lisp_Vector
*v
;
3543 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3544 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3545 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3546 ? nitems_max
: C_language_max
);
3547 eassert (VECTORP (vec
));
3548 eassert (0 < incr_min
&& -1 <= nitems_max
);
3549 old_size
= ASIZE (vec
);
3550 incr_max
= n_max
- old_size
;
3551 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3552 if (incr_max
< incr
)
3553 memory_full (SIZE_MAX
);
3554 new_size
= old_size
+ incr
;
3555 v
= allocate_vector (new_size
);
3556 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3557 for (i
= old_size
; i
< new_size
; ++i
)
3558 v
->contents
[i
] = Qnil
;
3559 XSETVECTOR (vec
, v
);
3564 /***********************************************************************
3566 ***********************************************************************/
3568 static struct hash_table_test hashtest_eq
;
3569 struct hash_table_test hashtest_eql
, hashtest_equal
;
3571 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3572 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3573 KEY2 are the same. */
3576 cmpfn_eql (struct hash_table_test
*ht
,
3580 return (FLOATP (key1
)
3582 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3586 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3587 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3588 KEY2 are the same. */
3591 cmpfn_equal (struct hash_table_test
*ht
,
3595 return !NILP (Fequal (key1
, key2
));
3599 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3600 HASH2 in hash table H using H->user_cmp_function. Value is true
3601 if KEY1 and KEY2 are the same. */
3604 cmpfn_user_defined (struct hash_table_test
*ht
,
3608 Lisp_Object args
[3];
3610 args
[0] = ht
->user_cmp_function
;
3613 return !NILP (Ffuncall (3, args
));
3617 /* Value is a hash code for KEY for use in hash table H which uses
3618 `eq' to compare keys. The hash code returned is guaranteed to fit
3619 in a Lisp integer. */
3622 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3624 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3628 /* Value is a hash code for KEY for use in hash table H which uses
3629 `eql' to compare keys. The hash code returned is guaranteed to fit
3630 in a Lisp integer. */
3633 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3637 hash
= sxhash (key
, 0);
3639 hash
= XHASH (key
) ^ XTYPE (key
);
3643 /* Value is a hash code for KEY for use in hash table H which uses
3644 `equal' to compare keys. The hash code returned is guaranteed to fit
3645 in a Lisp integer. */
3648 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3650 EMACS_UINT hash
= sxhash (key
, 0);
3654 /* Value is a hash code for KEY for use in hash table H which uses as
3655 user-defined function to compare keys. The hash code returned is
3656 guaranteed to fit in a Lisp integer. */
3659 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3661 Lisp_Object args
[2], hash
;
3663 args
[0] = ht
->user_hash_function
;
3665 hash
= Ffuncall (2, args
);
3666 return hashfn_eq (ht
, hash
);
3669 /* An upper bound on the size of a hash table index. It must fit in
3670 ptrdiff_t and be a valid Emacs fixnum. */
3671 #define INDEX_SIZE_BOUND \
3672 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3674 /* Create and initialize a new hash table.
3676 TEST specifies the test the hash table will use to compare keys.
3677 It must be either one of the predefined tests `eq', `eql' or
3678 `equal' or a symbol denoting a user-defined test named TEST with
3679 test and hash functions USER_TEST and USER_HASH.
3681 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3683 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3684 new size when it becomes full is computed by adding REHASH_SIZE to
3685 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3686 table's new size is computed by multiplying its old size with
3689 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3690 be resized when the ratio of (number of entries in the table) /
3691 (table size) is >= REHASH_THRESHOLD.
3693 WEAK specifies the weakness of the table. If non-nil, it must be
3694 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3697 make_hash_table (struct hash_table_test test
,
3698 Lisp_Object size
, Lisp_Object rehash_size
,
3699 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3701 struct Lisp_Hash_Table
*h
;
3703 EMACS_INT index_size
, sz
;
3707 /* Preconditions. */
3708 eassert (SYMBOLP (test
.name
));
3709 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3710 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3711 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3712 eassert (FLOATP (rehash_threshold
)
3713 && 0 < XFLOAT_DATA (rehash_threshold
)
3714 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3716 if (XFASTINT (size
) == 0)
3717 size
= make_number (1);
3719 sz
= XFASTINT (size
);
3720 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3721 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3722 ? next_almost_prime (index_float
)
3723 : INDEX_SIZE_BOUND
+ 1);
3724 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3725 error ("Hash table too large");
3727 /* Allocate a table and initialize it. */
3728 h
= allocate_hash_table ();
3730 /* Initialize hash table slots. */
3733 h
->rehash_threshold
= rehash_threshold
;
3734 h
->rehash_size
= rehash_size
;
3736 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3737 h
->hash
= Fmake_vector (size
, Qnil
);
3738 h
->next
= Fmake_vector (size
, Qnil
);
3739 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3741 /* Set up the free list. */
3742 for (i
= 0; i
< sz
- 1; ++i
)
3743 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3744 h
->next_free
= make_number (0);
3746 XSET_HASH_TABLE (table
, h
);
3747 eassert (HASH_TABLE_P (table
));
3748 eassert (XHASH_TABLE (table
) == h
);
3750 /* Maybe add this hash table to the list of all weak hash tables. */
3752 h
->next_weak
= NULL
;
3755 h
->next_weak
= weak_hash_tables
;
3756 weak_hash_tables
= h
;
3763 /* Return a copy of hash table H1. Keys and values are not copied,
3764 only the table itself is. */
3767 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3770 struct Lisp_Hash_Table
*h2
;
3772 h2
= allocate_hash_table ();
3774 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3775 h2
->hash
= Fcopy_sequence (h1
->hash
);
3776 h2
->next
= Fcopy_sequence (h1
->next
);
3777 h2
->index
= Fcopy_sequence (h1
->index
);
3778 XSET_HASH_TABLE (table
, h2
);
3780 /* Maybe add this hash table to the list of all weak hash tables. */
3781 if (!NILP (h2
->weak
))
3783 h2
->next_weak
= weak_hash_tables
;
3784 weak_hash_tables
= h2
;
3791 /* Resize hash table H if it's too full. If H cannot be resized
3792 because it's already too large, throw an error. */
3795 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3797 if (NILP (h
->next_free
))
3799 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3800 EMACS_INT new_size
, index_size
, nsize
;
3804 if (INTEGERP (h
->rehash_size
))
3805 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3808 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3809 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3811 new_size
= float_new_size
;
3812 if (new_size
<= old_size
)
3813 new_size
= old_size
+ 1;
3816 new_size
= INDEX_SIZE_BOUND
+ 1;
3818 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3819 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3820 ? next_almost_prime (index_float
)
3821 : INDEX_SIZE_BOUND
+ 1);
3822 nsize
= max (index_size
, 2 * new_size
);
3823 if (INDEX_SIZE_BOUND
< nsize
)
3824 error ("Hash table too large to resize");
3826 #ifdef ENABLE_CHECKING
3827 if (HASH_TABLE_P (Vpurify_flag
)
3828 && XHASH_TABLE (Vpurify_flag
) == h
)
3830 Lisp_Object args
[2];
3831 args
[0] = build_string ("Growing hash table to: %d");
3832 args
[1] = make_number (new_size
);
3837 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3838 2 * (new_size
- old_size
), -1));
3839 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3840 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3841 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3843 /* Update the free list. Do it so that new entries are added at
3844 the end of the free list. This makes some operations like
3846 for (i
= old_size
; i
< new_size
- 1; ++i
)
3847 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3849 if (!NILP (h
->next_free
))
3851 Lisp_Object last
, next
;
3853 last
= h
->next_free
;
3854 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3858 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3861 XSETFASTINT (h
->next_free
, old_size
);
3864 for (i
= 0; i
< old_size
; ++i
)
3865 if (!NILP (HASH_HASH (h
, i
)))
3867 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3868 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3869 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3870 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3876 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3877 the hash code of KEY. Value is the index of the entry in H
3878 matching KEY, or -1 if not found. */
3881 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3883 EMACS_UINT hash_code
;
3884 ptrdiff_t start_of_bucket
;
3887 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3888 eassert ((hash_code
& ~INTMASK
) == 0);
3892 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3893 idx
= HASH_INDEX (h
, start_of_bucket
);
3895 /* We need not gcpro idx since it's either an integer or nil. */
3898 ptrdiff_t i
= XFASTINT (idx
);
3899 if (EQ (key
, HASH_KEY (h
, i
))
3901 && hash_code
== XUINT (HASH_HASH (h
, i
))
3902 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3904 idx
= HASH_NEXT (h
, i
);
3907 return NILP (idx
) ? -1 : XFASTINT (idx
);
3911 /* Put an entry into hash table H that associates KEY with VALUE.
3912 HASH is a previously computed hash code of KEY.
3913 Value is the index of the entry in H matching KEY. */
3916 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3919 ptrdiff_t start_of_bucket
, i
;
3921 eassert ((hash
& ~INTMASK
) == 0);
3923 /* Increment count after resizing because resizing may fail. */
3924 maybe_resize_hash_table (h
);
3927 /* Store key/value in the key_and_value vector. */
3928 i
= XFASTINT (h
->next_free
);
3929 h
->next_free
= HASH_NEXT (h
, i
);
3930 set_hash_key_slot (h
, i
, key
);
3931 set_hash_value_slot (h
, i
, value
);
3933 /* Remember its hash code. */
3934 set_hash_hash_slot (h
, i
, make_number (hash
));
3936 /* Add new entry to its collision chain. */
3937 start_of_bucket
= hash
% ASIZE (h
->index
);
3938 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3939 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3944 /* Remove the entry matching KEY from hash table H, if there is one. */
3947 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3949 EMACS_UINT hash_code
;
3950 ptrdiff_t start_of_bucket
;
3951 Lisp_Object idx
, prev
;
3953 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3954 eassert ((hash_code
& ~INTMASK
) == 0);
3955 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3956 idx
= HASH_INDEX (h
, start_of_bucket
);
3959 /* We need not gcpro idx, prev since they're either integers or nil. */
3962 ptrdiff_t i
= XFASTINT (idx
);
3964 if (EQ (key
, HASH_KEY (h
, i
))
3966 && hash_code
== XUINT (HASH_HASH (h
, i
))
3967 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3969 /* Take entry out of collision chain. */
3971 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3973 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3975 /* Clear slots in key_and_value and add the slots to
3977 set_hash_key_slot (h
, i
, Qnil
);
3978 set_hash_value_slot (h
, i
, Qnil
);
3979 set_hash_hash_slot (h
, i
, Qnil
);
3980 set_hash_next_slot (h
, i
, h
->next_free
);
3981 h
->next_free
= make_number (i
);
3983 eassert (h
->count
>= 0);
3989 idx
= HASH_NEXT (h
, i
);
3995 /* Clear hash table H. */
3998 hash_clear (struct Lisp_Hash_Table
*h
)
4002 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4004 for (i
= 0; i
< size
; ++i
)
4006 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4007 set_hash_key_slot (h
, i
, Qnil
);
4008 set_hash_value_slot (h
, i
, Qnil
);
4009 set_hash_hash_slot (h
, i
, Qnil
);
4012 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4013 ASET (h
->index
, i
, Qnil
);
4015 h
->next_free
= make_number (0);
4022 /************************************************************************
4024 ************************************************************************/
4026 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4027 entries from the table that don't survive the current GC.
4028 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4029 true if anything was marked. */
4032 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4034 ptrdiff_t bucket
, n
;
4037 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4040 for (bucket
= 0; bucket
< n
; ++bucket
)
4042 Lisp_Object idx
, next
, prev
;
4044 /* Follow collision chain, removing entries that
4045 don't survive this garbage collection. */
4047 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4049 ptrdiff_t i
= XFASTINT (idx
);
4050 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4051 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4054 if (EQ (h
->weak
, Qkey
))
4055 remove_p
= !key_known_to_survive_p
;
4056 else if (EQ (h
->weak
, Qvalue
))
4057 remove_p
= !value_known_to_survive_p
;
4058 else if (EQ (h
->weak
, Qkey_or_value
))
4059 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4060 else if (EQ (h
->weak
, Qkey_and_value
))
4061 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4065 next
= HASH_NEXT (h
, i
);
4067 if (remove_entries_p
)
4071 /* Take out of collision chain. */
4073 set_hash_index_slot (h
, bucket
, next
);
4075 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4077 /* Add to free list. */
4078 set_hash_next_slot (h
, i
, h
->next_free
);
4081 /* Clear key, value, and hash. */
4082 set_hash_key_slot (h
, i
, Qnil
);
4083 set_hash_value_slot (h
, i
, Qnil
);
4084 set_hash_hash_slot (h
, i
, Qnil
);
4097 /* Make sure key and value survive. */
4098 if (!key_known_to_survive_p
)
4100 mark_object (HASH_KEY (h
, i
));
4104 if (!value_known_to_survive_p
)
4106 mark_object (HASH_VALUE (h
, i
));
4117 /* Remove elements from weak hash tables that don't survive the
4118 current garbage collection. Remove weak tables that don't survive
4119 from Vweak_hash_tables. Called from gc_sweep. */
4121 NO_INLINE
/* For better stack traces */
4123 sweep_weak_hash_tables (void)
4125 struct Lisp_Hash_Table
*h
, *used
, *next
;
4128 /* Mark all keys and values that are in use. Keep on marking until
4129 there is no more change. This is necessary for cases like
4130 value-weak table A containing an entry X -> Y, where Y is used in a
4131 key-weak table B, Z -> Y. If B comes after A in the list of weak
4132 tables, X -> Y might be removed from A, although when looking at B
4133 one finds that it shouldn't. */
4137 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4139 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4140 marked
|= sweep_weak_table (h
, 0);
4145 /* Remove tables and entries that aren't used. */
4146 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4148 next
= h
->next_weak
;
4150 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4152 /* TABLE is marked as used. Sweep its contents. */
4154 sweep_weak_table (h
, 1);
4156 /* Add table to the list of used weak hash tables. */
4157 h
->next_weak
= used
;
4162 weak_hash_tables
= used
;
4167 /***********************************************************************
4168 Hash Code Computation
4169 ***********************************************************************/
4171 /* Maximum depth up to which to dive into Lisp structures. */
4173 #define SXHASH_MAX_DEPTH 3
4175 /* Maximum length up to which to take list and vector elements into
4178 #define SXHASH_MAX_LEN 7
4180 /* Return a hash for string PTR which has length LEN. The hash value
4181 can be any EMACS_UINT value. */
4184 hash_string (char const *ptr
, ptrdiff_t len
)
4186 char const *p
= ptr
;
4187 char const *end
= p
+ len
;
4189 EMACS_UINT hash
= 0;
4194 hash
= sxhash_combine (hash
, c
);
4200 /* Return a hash for string PTR which has length LEN. The hash
4201 code returned is guaranteed to fit in a Lisp integer. */
4204 sxhash_string (char const *ptr
, ptrdiff_t len
)
4206 EMACS_UINT hash
= hash_string (ptr
, len
);
4207 return SXHASH_REDUCE (hash
);
4210 /* Return a hash for the floating point value VAL. */
4213 sxhash_float (double val
)
4215 EMACS_UINT hash
= 0;
4217 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4218 + (sizeof val
% sizeof hash
!= 0))
4222 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4226 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4227 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4228 hash
= sxhash_combine (hash
, u
.word
[i
]);
4229 return SXHASH_REDUCE (hash
);
4232 /* Return a hash for list LIST. DEPTH is the current depth in the
4233 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4236 sxhash_list (Lisp_Object list
, int depth
)
4238 EMACS_UINT hash
= 0;
4241 if (depth
< SXHASH_MAX_DEPTH
)
4243 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4244 list
= XCDR (list
), ++i
)
4246 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4247 hash
= sxhash_combine (hash
, hash2
);
4252 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4253 hash
= sxhash_combine (hash
, hash2
);
4256 return SXHASH_REDUCE (hash
);
4260 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4261 the Lisp structure. */
4264 sxhash_vector (Lisp_Object vec
, int depth
)
4266 EMACS_UINT hash
= ASIZE (vec
);
4269 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4270 for (i
= 0; i
< n
; ++i
)
4272 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4273 hash
= sxhash_combine (hash
, hash2
);
4276 return SXHASH_REDUCE (hash
);
4279 /* Return a hash for bool-vector VECTOR. */
4282 sxhash_bool_vector (Lisp_Object vec
)
4284 EMACS_INT size
= bool_vector_size (vec
);
4285 EMACS_UINT hash
= size
;
4288 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4289 for (i
= 0; i
< n
; ++i
)
4290 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4292 return SXHASH_REDUCE (hash
);
4296 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4297 structure. Value is an unsigned integer clipped to INTMASK. */
4300 sxhash (Lisp_Object obj
, int depth
)
4304 if (depth
> SXHASH_MAX_DEPTH
)
4307 switch (XTYPE (obj
))
4318 obj
= SYMBOL_NAME (obj
);
4322 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4325 /* This can be everything from a vector to an overlay. */
4326 case Lisp_Vectorlike
:
4328 /* According to the CL HyperSpec, two arrays are equal only if
4329 they are `eq', except for strings and bit-vectors. In
4330 Emacs, this works differently. We have to compare element
4332 hash
= sxhash_vector (obj
, depth
);
4333 else if (BOOL_VECTOR_P (obj
))
4334 hash
= sxhash_bool_vector (obj
);
4336 /* Others are `equal' if they are `eq', so let's take their
4342 hash
= sxhash_list (obj
, depth
);
4346 hash
= sxhash_float (XFLOAT_DATA (obj
));
4358 /***********************************************************************
4360 ***********************************************************************/
4363 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4364 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4367 EMACS_UINT hash
= sxhash (obj
, 0);
4368 return make_number (hash
);
4372 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4373 doc
: /* Create and return a new hash table.
4375 Arguments are specified as keyword/argument pairs. The following
4376 arguments are defined:
4378 :test TEST -- TEST must be a symbol that specifies how to compare
4379 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4380 `equal'. User-supplied test and hash functions can be specified via
4381 `define-hash-table-test'.
4383 :size SIZE -- A hint as to how many elements will be put in the table.
4386 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4387 fills up. If REHASH-SIZE is an integer, increase the size by that
4388 amount. If it is a float, it must be > 1.0, and the new size is the
4389 old size multiplied by that factor. Default is 1.5.
4391 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4392 Resize the hash table when the ratio (number of entries / table size)
4393 is greater than or equal to THRESHOLD. Default is 0.8.
4395 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4396 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4397 returned is a weak table. Key/value pairs are removed from a weak
4398 hash table when there are no non-weak references pointing to their
4399 key, value, one of key or value, or both key and value, depending on
4400 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4403 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4404 (ptrdiff_t nargs
, Lisp_Object
*args
)
4406 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4407 struct hash_table_test testdesc
;
4411 /* The vector `used' is used to keep track of arguments that
4412 have been consumed. */
4413 used
= alloca (nargs
* sizeof *used
);
4414 memset (used
, 0, nargs
* sizeof *used
);
4416 /* See if there's a `:test TEST' among the arguments. */
4417 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4418 test
= i
? args
[i
] : Qeql
;
4420 testdesc
= hashtest_eq
;
4421 else if (EQ (test
, Qeql
))
4422 testdesc
= hashtest_eql
;
4423 else if (EQ (test
, Qequal
))
4424 testdesc
= hashtest_equal
;
4427 /* See if it is a user-defined test. */
4430 prop
= Fget (test
, Qhash_table_test
);
4431 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4432 signal_error ("Invalid hash table test", test
);
4433 testdesc
.name
= test
;
4434 testdesc
.user_cmp_function
= XCAR (prop
);
4435 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4436 testdesc
.hashfn
= hashfn_user_defined
;
4437 testdesc
.cmpfn
= cmpfn_user_defined
;
4440 /* See if there's a `:size SIZE' argument. */
4441 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4442 size
= i
? args
[i
] : Qnil
;
4444 size
= make_number (DEFAULT_HASH_SIZE
);
4445 else if (!INTEGERP (size
) || XINT (size
) < 0)
4446 signal_error ("Invalid hash table size", size
);
4448 /* Look for `:rehash-size SIZE'. */
4449 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4450 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4451 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4452 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4453 signal_error ("Invalid hash table rehash size", rehash_size
);
4455 /* Look for `:rehash-threshold THRESHOLD'. */
4456 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4457 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4458 if (! (FLOATP (rehash_threshold
)
4459 && 0 < XFLOAT_DATA (rehash_threshold
)
4460 && XFLOAT_DATA (rehash_threshold
) <= 1))
4461 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4463 /* Look for `:weakness WEAK'. */
4464 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4465 weak
= i
? args
[i
] : Qnil
;
4467 weak
= Qkey_and_value
;
4470 && !EQ (weak
, Qvalue
)
4471 && !EQ (weak
, Qkey_or_value
)
4472 && !EQ (weak
, Qkey_and_value
))
4473 signal_error ("Invalid hash table weakness", weak
);
4475 /* Now, all args should have been used up, or there's a problem. */
4476 for (i
= 0; i
< nargs
; ++i
)
4478 signal_error ("Invalid argument list", args
[i
]);
4480 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4484 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4485 doc
: /* Return a copy of hash table TABLE. */)
4488 return copy_hash_table (check_hash_table (table
));
4492 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4493 doc
: /* Return the number of elements in TABLE. */)
4496 return make_number (check_hash_table (table
)->count
);
4500 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4501 Shash_table_rehash_size
, 1, 1, 0,
4502 doc
: /* Return the current rehash size of TABLE. */)
4505 return check_hash_table (table
)->rehash_size
;
4509 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4510 Shash_table_rehash_threshold
, 1, 1, 0,
4511 doc
: /* Return the current rehash threshold of TABLE. */)
4514 return check_hash_table (table
)->rehash_threshold
;
4518 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4519 doc
: /* Return the size of TABLE.
4520 The size can be used as an argument to `make-hash-table' to create
4521 a hash table than can hold as many elements as TABLE holds
4522 without need for resizing. */)
4525 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4526 return make_number (HASH_TABLE_SIZE (h
));
4530 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4531 doc
: /* Return the test TABLE uses. */)
4534 return check_hash_table (table
)->test
.name
;
4538 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4540 doc
: /* Return the weakness of TABLE. */)
4543 return check_hash_table (table
)->weak
;
4547 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4548 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4551 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4555 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4556 doc
: /* Clear hash table TABLE and return it. */)
4559 hash_clear (check_hash_table (table
));
4560 /* Be compatible with XEmacs. */
4565 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4566 doc
: /* Look up KEY in TABLE and return its associated value.
4567 If KEY is not found, return DFLT which defaults to nil. */)
4568 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4570 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4571 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4572 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4576 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4577 doc
: /* Associate KEY with VALUE in hash table TABLE.
4578 If KEY is already present in table, replace its current value with
4579 VALUE. In any case, return VALUE. */)
4580 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4582 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4586 i
= hash_lookup (h
, key
, &hash
);
4588 set_hash_value_slot (h
, i
, value
);
4590 hash_put (h
, key
, value
, hash
);
4596 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4597 doc
: /* Remove KEY from TABLE. */)
4598 (Lisp_Object key
, Lisp_Object table
)
4600 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4601 hash_remove_from_table (h
, key
);
4606 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4607 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4608 FUNCTION is called with two arguments, KEY and VALUE.
4609 `maphash' always returns nil. */)
4610 (Lisp_Object function
, Lisp_Object table
)
4612 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4613 Lisp_Object args
[3];
4616 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4617 if (!NILP (HASH_HASH (h
, i
)))
4620 args
[1] = HASH_KEY (h
, i
);
4621 args
[2] = HASH_VALUE (h
, i
);
4629 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4630 Sdefine_hash_table_test
, 3, 3, 0,
4631 doc
: /* Define a new hash table test with name NAME, a symbol.
4633 In hash tables created with NAME specified as test, use TEST to
4634 compare keys, and HASH for computing hash codes of keys.
4636 TEST must be a function taking two arguments and returning non-nil if
4637 both arguments are the same. HASH must be a function taking one
4638 argument and returning an object that is the hash code of the argument.
4639 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4640 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4641 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4643 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4648 /************************************************************************
4649 MD5, SHA-1, and SHA-2
4650 ************************************************************************/
4657 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4660 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4664 EMACS_INT start_char
= 0, end_char
= 0;
4665 ptrdiff_t start_byte
, end_byte
;
4666 register EMACS_INT b
, e
;
4667 register struct buffer
*bp
;
4670 void *(*hash_func
) (const char *, size_t, void *);
4673 CHECK_SYMBOL (algorithm
);
4675 if (STRINGP (object
))
4677 if (NILP (coding_system
))
4679 /* Decide the coding-system to encode the data with. */
4681 if (STRING_MULTIBYTE (object
))
4682 /* use default, we can't guess correct value */
4683 coding_system
= preferred_coding_system ();
4685 coding_system
= Qraw_text
;
4688 if (NILP (Fcoding_system_p (coding_system
)))
4690 /* Invalid coding system. */
4692 if (!NILP (noerror
))
4693 coding_system
= Qraw_text
;
4695 xsignal1 (Qcoding_system_error
, coding_system
);
4698 if (STRING_MULTIBYTE (object
))
4699 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4701 size
= SCHARS (object
);
4702 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4704 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4705 end_byte
= (end_char
== size
4707 : string_char_to_byte (object
, end_char
));
4711 struct buffer
*prev
= current_buffer
;
4713 record_unwind_current_buffer ();
4715 CHECK_BUFFER (object
);
4717 bp
= XBUFFER (object
);
4718 set_buffer_internal (bp
);
4724 CHECK_NUMBER_COERCE_MARKER (start
);
4732 CHECK_NUMBER_COERCE_MARKER (end
);
4737 temp
= b
, b
= e
, e
= temp
;
4739 if (!(BEGV
<= b
&& e
<= ZV
))
4740 args_out_of_range (start
, end
);
4742 if (NILP (coding_system
))
4744 /* Decide the coding-system to encode the data with.
4745 See fileio.c:Fwrite-region */
4747 if (!NILP (Vcoding_system_for_write
))
4748 coding_system
= Vcoding_system_for_write
;
4751 bool force_raw_text
= 0;
4753 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4754 if (NILP (coding_system
)
4755 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4757 coding_system
= Qnil
;
4758 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4762 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4764 /* Check file-coding-system-alist. */
4765 Lisp_Object args
[4], val
;
4767 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4768 args
[3] = Fbuffer_file_name (object
);
4769 val
= Ffind_operation_coding_system (4, args
);
4770 if (CONSP (val
) && !NILP (XCDR (val
)))
4771 coding_system
= XCDR (val
);
4774 if (NILP (coding_system
)
4775 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4777 /* If we still have not decided a coding system, use the
4778 default value of buffer-file-coding-system. */
4779 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4783 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4784 /* Confirm that VAL can surely encode the current region. */
4785 coding_system
= call4 (Vselect_safe_coding_system_function
,
4786 make_number (b
), make_number (e
),
4787 coding_system
, Qnil
);
4790 coding_system
= Qraw_text
;
4793 if (NILP (Fcoding_system_p (coding_system
)))
4795 /* Invalid coding system. */
4797 if (!NILP (noerror
))
4798 coding_system
= Qraw_text
;
4800 xsignal1 (Qcoding_system_error
, coding_system
);
4804 object
= make_buffer_string (b
, e
, 0);
4805 set_buffer_internal (prev
);
4806 /* Discard the unwind protect for recovering the current
4810 if (STRING_MULTIBYTE (object
))
4811 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4813 end_byte
= SBYTES (object
);
4816 if (EQ (algorithm
, Qmd5
))
4818 digest_size
= MD5_DIGEST_SIZE
;
4819 hash_func
= md5_buffer
;
4821 else if (EQ (algorithm
, Qsha1
))
4823 digest_size
= SHA1_DIGEST_SIZE
;
4824 hash_func
= sha1_buffer
;
4826 else if (EQ (algorithm
, Qsha224
))
4828 digest_size
= SHA224_DIGEST_SIZE
;
4829 hash_func
= sha224_buffer
;
4831 else if (EQ (algorithm
, Qsha256
))
4833 digest_size
= SHA256_DIGEST_SIZE
;
4834 hash_func
= sha256_buffer
;
4836 else if (EQ (algorithm
, Qsha384
))
4838 digest_size
= SHA384_DIGEST_SIZE
;
4839 hash_func
= sha384_buffer
;
4841 else if (EQ (algorithm
, Qsha512
))
4843 digest_size
= SHA512_DIGEST_SIZE
;
4844 hash_func
= sha512_buffer
;
4847 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4849 /* allocate 2 x digest_size so that it can be re-used to hold the
4851 digest
= make_uninit_string (digest_size
* 2);
4853 hash_func (SSDATA (object
) + start_byte
,
4854 end_byte
- start_byte
,
4859 unsigned char *p
= SDATA (digest
);
4860 for (i
= digest_size
- 1; i
>= 0; i
--)
4862 static char const hexdigit
[16] = "0123456789abcdef";
4864 p
[2 * i
] = hexdigit
[p_i
>> 4];
4865 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4870 return make_unibyte_string (SSDATA (digest
), digest_size
);
4873 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4874 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4876 A message digest is a cryptographic checksum of a document, and the
4877 algorithm to calculate it is defined in RFC 1321.
4879 The two optional arguments START and END are character positions
4880 specifying for which part of OBJECT the message digest should be
4881 computed. If nil or omitted, the digest is computed for the whole
4884 The MD5 message digest is computed from the result of encoding the
4885 text in a coding system, not directly from the internal Emacs form of
4886 the text. The optional fourth argument CODING-SYSTEM specifies which
4887 coding system to encode the text with. It should be the same coding
4888 system that you used or will use when actually writing the text into a
4891 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4892 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4893 system would be chosen by default for writing this text into a file.
4895 If OBJECT is a string, the most preferred coding system (see the
4896 command `prefer-coding-system') is used.
4898 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4899 guesswork fails. Normally, an error is signaled in such case. */)
4900 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4902 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4905 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4906 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4907 ALGORITHM is a symbol specifying the hash to use:
4908 md5, sha1, sha224, sha256, sha384 or sha512.
4910 The two optional arguments START and END are positions specifying for
4911 which part of OBJECT to compute the hash. If nil or omitted, uses the
4914 If BINARY is non-nil, returns a string in binary form. */)
4915 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4917 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4923 DEFSYM (Qmd5
, "md5");
4924 DEFSYM (Qsha1
, "sha1");
4925 DEFSYM (Qsha224
, "sha224");
4926 DEFSYM (Qsha256
, "sha256");
4927 DEFSYM (Qsha384
, "sha384");
4928 DEFSYM (Qsha512
, "sha512");
4930 /* Hash table stuff. */
4931 DEFSYM (Qhash_table_p
, "hash-table-p");
4933 DEFSYM (Qeql
, "eql");
4934 DEFSYM (Qequal
, "equal");
4935 DEFSYM (QCtest
, ":test");
4936 DEFSYM (QCsize
, ":size");
4937 DEFSYM (QCrehash_size
, ":rehash-size");
4938 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4939 DEFSYM (QCweakness
, ":weakness");
4940 DEFSYM (Qkey
, "key");
4941 DEFSYM (Qvalue
, "value");
4942 DEFSYM (Qhash_table_test
, "hash-table-test");
4943 DEFSYM (Qkey_or_value
, "key-or-value");
4944 DEFSYM (Qkey_and_value
, "key-and-value");
4947 defsubr (&Smake_hash_table
);
4948 defsubr (&Scopy_hash_table
);
4949 defsubr (&Shash_table_count
);
4950 defsubr (&Shash_table_rehash_size
);
4951 defsubr (&Shash_table_rehash_threshold
);
4952 defsubr (&Shash_table_size
);
4953 defsubr (&Shash_table_test
);
4954 defsubr (&Shash_table_weakness
);
4955 defsubr (&Shash_table_p
);
4956 defsubr (&Sclrhash
);
4957 defsubr (&Sgethash
);
4958 defsubr (&Sputhash
);
4959 defsubr (&Sremhash
);
4960 defsubr (&Smaphash
);
4961 defsubr (&Sdefine_hash_table_test
);
4963 DEFSYM (Qstring_lessp
, "string-lessp");
4964 DEFSYM (Qprovide
, "provide");
4965 DEFSYM (Qrequire
, "require");
4966 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4967 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4968 DEFSYM (Qwidget_type
, "widget-type");
4970 staticpro (&string_char_byte_cache_string
);
4971 string_char_byte_cache_string
= Qnil
;
4973 require_nesting_list
= Qnil
;
4974 staticpro (&require_nesting_list
);
4976 Fset (Qyes_or_no_p_history
, Qnil
);
4978 DEFVAR_LISP ("features", Vfeatures
,
4979 doc
: /* A list of symbols which are the features of the executing Emacs.
4980 Used by `featurep' and `require', and altered by `provide'. */);
4981 Vfeatures
= list1 (intern_c_string ("emacs"));
4982 DEFSYM (Qsubfeatures
, "subfeatures");
4983 DEFSYM (Qfuncall
, "funcall");
4985 #ifdef HAVE_LANGINFO_CODESET
4986 DEFSYM (Qcodeset
, "codeset");
4987 DEFSYM (Qdays
, "days");
4988 DEFSYM (Qmonths
, "months");
4989 DEFSYM (Qpaper
, "paper");
4990 #endif /* HAVE_LANGINFO_CODESET */
4992 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4993 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4994 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4995 invoked by mouse clicks and mouse menu items.
4997 On some platforms, file selection dialogs are also enabled if this is
5001 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5002 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5003 This applies to commands from menus and tool bar buttons even when
5004 they are initiated from the keyboard. If `use-dialog-box' is nil,
5005 that disables the use of a file dialog, regardless of the value of
5007 use_file_dialog
= 1;
5009 defsubr (&Sidentity
);
5012 defsubr (&Ssafe_length
);
5013 defsubr (&Sstring_bytes
);
5014 defsubr (&Sstring_equal
);
5015 defsubr (&Scompare_strings
);
5016 defsubr (&Sstring_lessp
);
5019 defsubr (&Svconcat
);
5020 defsubr (&Scopy_sequence
);
5021 defsubr (&Sstring_make_multibyte
);
5022 defsubr (&Sstring_make_unibyte
);
5023 defsubr (&Sstring_as_multibyte
);
5024 defsubr (&Sstring_as_unibyte
);
5025 defsubr (&Sstring_to_multibyte
);
5026 defsubr (&Sstring_to_unibyte
);
5027 defsubr (&Scopy_alist
);
5028 defsubr (&Ssubstring
);
5029 defsubr (&Ssubstring_no_properties
);
5042 defsubr (&Snreverse
);
5043 defsubr (&Sreverse
);
5045 defsubr (&Splist_get
);
5047 defsubr (&Splist_put
);
5049 defsubr (&Slax_plist_get
);
5050 defsubr (&Slax_plist_put
);
5053 defsubr (&Sequal_including_properties
);
5054 defsubr (&Sfillarray
);
5055 defsubr (&Sclear_string
);
5059 defsubr (&Smapconcat
);
5060 defsubr (&Syes_or_no_p
);
5061 defsubr (&Sload_average
);
5062 defsubr (&Sfeaturep
);
5063 defsubr (&Srequire
);
5064 defsubr (&Sprovide
);
5065 defsubr (&Splist_member
);
5066 defsubr (&Swidget_put
);
5067 defsubr (&Swidget_get
);
5068 defsubr (&Swidget_apply
);
5069 defsubr (&Sbase64_encode_region
);
5070 defsubr (&Sbase64_decode_region
);
5071 defsubr (&Sbase64_encode_string
);
5072 defsubr (&Sbase64_decode_string
);
5074 defsubr (&Ssecure_hash
);
5075 defsubr (&Slocale_info
);
5077 hashtest_eq
.name
= Qeq
;
5078 hashtest_eq
.user_hash_function
= Qnil
;
5079 hashtest_eq
.user_cmp_function
= Qnil
;
5080 hashtest_eq
.cmpfn
= 0;
5081 hashtest_eq
.hashfn
= hashfn_eq
;
5083 hashtest_eql
.name
= Qeql
;
5084 hashtest_eql
.user_hash_function
= Qnil
;
5085 hashtest_eql
.user_cmp_function
= Qnil
;
5086 hashtest_eql
.cmpfn
= cmpfn_eql
;
5087 hashtest_eql
.hashfn
= hashfn_eql
;
5089 hashtest_equal
.name
= Qequal
;
5090 hashtest_equal
.user_hash_function
= Qnil
;
5091 hashtest_equal
.user_cmp_function
= Qnil
;
5092 hashtest_equal
.cmpfn
= cmpfn_equal
;
5093 hashtest_equal
.hashfn
= hashfn_equal
;