1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
43 Lisp_Object Qstring_lessp
;
44 static Lisp_Object Qprovide
, Qrequire
;
45 static Lisp_Object Qyes_or_no_p_history
;
46 Lisp_Object Qcursor_in_echo_area
;
47 static Lisp_Object Qwidget_type
;
48 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
50 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
52 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
54 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
55 doc
: /* Return the argument unchanged. */)
61 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
62 doc
: /* Return a pseudo-random number.
63 All integers representable in Lisp, i.e. between `most-negative-fixnum'
64 and `most-positive-fixnum', inclusive, are equally likely.
66 With positive integer LIMIT, return random number in interval [0,LIMIT).
67 With argument t, set the random number seed from the current time and pid.
68 With a string argument, set the seed based on the string's contents.
69 Other values of LIMIT are ignored.
71 See Info node `(elisp)Random Numbers' for more details. */)
78 else if (STRINGP (limit
))
79 seed_random (SSDATA (limit
), SBYTES (limit
));
82 if (INTEGERP (limit
) && 0 < XINT (limit
))
85 /* Return the remainder, except reject the rare case where
86 get_random returns a number so close to INTMASK that the
87 remainder isn't random. */
88 EMACS_INT remainder
= val
% XINT (limit
);
89 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
90 return make_number (remainder
);
93 return make_number (val
);
96 /* Heuristic on how many iterations of a tight loop can be safely done
97 before it's time to do a QUIT. This must be a power of 2. */
98 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
100 /* Random data-structure functions. */
103 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
105 CHECK_TYPE (NILP (x
), Qlistp
, y
);
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
118 if (STRINGP (sequence
))
119 XSETFASTINT (val
, SCHARS (sequence
));
120 else if (VECTORP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
));
122 else if (CHAR_TABLE_P (sequence
))
123 XSETFASTINT (val
, MAX_CHAR
);
124 else if (BOOL_VECTOR_P (sequence
))
125 XSETFASTINT (val
, bool_vector_size (sequence
));
126 else if (COMPILEDP (sequence
))
127 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
128 else if (CONSP (sequence
))
135 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
137 if (MOST_POSITIVE_FIXNUM
< i
)
138 error ("List too long");
141 sequence
= XCDR (sequence
);
143 while (CONSP (sequence
));
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
158 doc
: /* Return the length of a list, but avoid error or infinite loop.
159 This function never gets an error. If LIST is not really a list,
160 it returns 0. If LIST is circular, it returns a finite value
161 which is at least the number of distinct elements. */)
164 Lisp_Object tail
, halftail
;
169 return make_number (0);
171 /* halftail is used to detect circular lists. */
172 for (tail
= halftail
= list
; ; )
177 if (EQ (tail
, halftail
))
180 if ((lolen
& 1) == 0)
182 halftail
= XCDR (halftail
);
183 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
187 hilen
+= UINTMAX_MAX
+ 1.0;
192 /* If the length does not fit into a fixnum, return a float.
193 On all known practical machines this returns an upper bound on
195 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
198 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
199 doc
: /* Return the number of bytes in STRING.
200 If STRING is multibyte, this may be greater than the length of STRING. */)
203 CHECK_STRING (string
);
204 return make_number (SBYTES (string
));
207 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
208 doc
: /* Return t if two strings have identical contents.
209 Case is significant, but text properties are ignored.
210 Symbols are also allowed; their print names are used instead. */)
211 (register Lisp_Object s1
, Lisp_Object s2
)
214 s1
= SYMBOL_NAME (s1
);
216 s2
= SYMBOL_NAME (s2
);
220 if (SCHARS (s1
) != SCHARS (s2
)
221 || SBYTES (s1
) != SBYTES (s2
)
222 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
227 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
228 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
229 The arguments START1, END1, START2, and END2, if non-nil, are
230 positions specifying which parts of STR1 or STR2 to compare. In
231 string STR1, compare the part between START1 (inclusive) and END1
232 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
233 the string; if END1 is nil, it defaults to the length of the string.
234 Likewise, in string STR2, compare the part between START2 and END2.
235 Like in `substring', negative values are counted from the end.
237 The strings are compared by the numeric values of their characters.
238 For instance, STR1 is "less than" STR2 if its first differing
239 character has a smaller numeric value. If IGNORE-CASE is non-nil,
240 characters are converted to lower-case before comparing them. Unibyte
241 strings are converted to multibyte for comparison.
243 The value is t if the strings (or specified portions) match.
244 If string STR1 is less, the value is a negative number N;
245 - 1 - N is the number of characters that match at the beginning.
246 If string STR1 is greater, the value is a positive number N;
247 N - 1 is the number of characters that match at the beginning. */)
248 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
249 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
251 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
256 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
257 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
262 i1_byte
= string_char_to_byte (str1
, i1
);
263 i2_byte
= string_char_to_byte (str2
, i2
);
265 while (i1
< to1
&& i2
< to2
)
267 /* When we find a mismatch, we must compare the
268 characters, not just the bytes. */
271 if (STRING_MULTIBYTE (str1
))
272 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
275 c1
= SREF (str1
, i1
++);
276 MAKE_CHAR_MULTIBYTE (c1
);
279 if (STRING_MULTIBYTE (str2
))
280 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
283 c2
= SREF (str2
, i2
++);
284 MAKE_CHAR_MULTIBYTE (c2
);
290 if (! NILP (ignore_case
))
292 c1
= XINT (Fupcase (make_number (c1
)));
293 c2
= XINT (Fupcase (make_number (c2
)));
299 /* Note that I1 has already been incremented
300 past the character that we are comparing;
301 hence we don't add or subtract 1 here. */
303 return make_number (- i1
+ from1
);
305 return make_number (i1
- from1
);
309 return make_number (i1
- from1
+ 1);
311 return make_number (- i1
+ from1
- 1);
316 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
317 doc
: /* Return t if first arg string is less than second in lexicographic order.
319 Symbols are also allowed; their print names are used instead. */)
320 (register Lisp_Object s1
, Lisp_Object s2
)
322 register ptrdiff_t end
;
323 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
326 s1
= SYMBOL_NAME (s1
);
328 s2
= SYMBOL_NAME (s2
);
332 i1
= i1_byte
= i2
= i2_byte
= 0;
335 if (end
> SCHARS (s2
))
340 /* When we find a mismatch, we must compare the
341 characters, not just the bytes. */
344 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
345 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
348 return c1
< c2
? Qt
: Qnil
;
350 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
353 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
354 enum Lisp_Type target_type
, bool last_special
);
358 concat2 (Lisp_Object s1
, Lisp_Object s2
)
363 return concat (2, args
, Lisp_String
, 0);
368 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
374 return concat (3, args
, Lisp_String
, 0);
377 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
378 doc
: /* Concatenate all the arguments and make the result a list.
379 The result is a list whose elements are the elements of all the arguments.
380 Each argument may be a list, vector or string.
381 The last argument is not copied, just used as the tail of the new list.
382 usage: (append &rest SEQUENCES) */)
383 (ptrdiff_t nargs
, Lisp_Object
*args
)
385 return concat (nargs
, args
, Lisp_Cons
, 1);
388 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
389 doc
: /* Concatenate all the arguments and make the result a string.
390 The result is a string whose elements are the elements of all the arguments.
391 Each argument may be a string or a list or vector of characters (integers).
392 usage: (concat &rest SEQUENCES) */)
393 (ptrdiff_t nargs
, Lisp_Object
*args
)
395 return concat (nargs
, args
, Lisp_String
, 0);
398 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
399 doc
: /* Concatenate all the arguments and make the result a vector.
400 The result is a vector whose elements are the elements of all the arguments.
401 Each argument may be a list, vector or string.
402 usage: (vconcat &rest SEQUENCES) */)
403 (ptrdiff_t nargs
, Lisp_Object
*args
)
405 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
409 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
410 doc
: /* Return a copy of a list, vector, string or char-table.
411 The elements of a list or vector are not copied; they are shared
412 with the original. */)
415 if (NILP (arg
)) return arg
;
417 if (CHAR_TABLE_P (arg
))
419 return copy_char_table (arg
);
422 if (BOOL_VECTOR_P (arg
))
424 EMACS_INT nbits
= bool_vector_size (arg
);
425 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
426 Lisp_Object val
= make_uninit_bool_vector (nbits
);
427 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
431 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
432 wrong_type_argument (Qsequencep
, arg
);
434 return concat (1, &arg
, XTYPE (arg
), 0);
437 /* This structure holds information of an argument of `concat' that is
438 a string and has text properties to be copied. */
441 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
442 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
443 ptrdiff_t to
; /* refer to VAL (the target string) */
447 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
448 enum Lisp_Type target_type
, bool last_special
)
454 ptrdiff_t toindex_byte
= 0;
455 EMACS_INT result_len
;
456 EMACS_INT result_len_byte
;
458 Lisp_Object last_tail
;
461 /* When we make a multibyte string, we can't copy text properties
462 while concatenating each string because the length of resulting
463 string can't be decided until we finish the whole concatenation.
464 So, we record strings that have text properties to be copied
465 here, and copy the text properties after the concatenation. */
466 struct textprop_rec
*textprops
= NULL
;
467 /* Number of elements in textprops. */
468 ptrdiff_t num_textprops
= 0;
473 /* In append, the last arg isn't treated like the others */
474 if (last_special
&& nargs
> 0)
477 last_tail
= args
[nargs
];
482 /* Check each argument. */
483 for (argnum
= 0; argnum
< nargs
; argnum
++)
486 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
487 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
488 wrong_type_argument (Qsequencep
, this);
491 /* Compute total length in chars of arguments in RESULT_LEN.
492 If desired output is a string, also compute length in bytes
493 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
494 whether the result should be a multibyte string. */
498 for (argnum
= 0; argnum
< nargs
; argnum
++)
502 len
= XFASTINT (Flength (this));
503 if (target_type
== Lisp_String
)
505 /* We must count the number of bytes needed in the string
506 as well as the number of characters. */
510 ptrdiff_t this_len_byte
;
512 if (VECTORP (this) || COMPILEDP (this))
513 for (i
= 0; i
< len
; i
++)
516 CHECK_CHARACTER (ch
);
518 this_len_byte
= CHAR_BYTES (c
);
519 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
521 result_len_byte
+= this_len_byte
;
522 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
525 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
526 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
527 else if (CONSP (this))
528 for (; CONSP (this); this = XCDR (this))
531 CHECK_CHARACTER (ch
);
533 this_len_byte
= CHAR_BYTES (c
);
534 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
536 result_len_byte
+= this_len_byte
;
537 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
540 else if (STRINGP (this))
542 if (STRING_MULTIBYTE (this))
545 this_len_byte
= SBYTES (this);
548 this_len_byte
= count_size_as_multibyte (SDATA (this),
550 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
552 result_len_byte
+= this_len_byte
;
557 if (MOST_POSITIVE_FIXNUM
< result_len
)
558 memory_full (SIZE_MAX
);
561 if (! some_multibyte
)
562 result_len_byte
= result_len
;
564 /* Create the output object. */
565 if (target_type
== Lisp_Cons
)
566 val
= Fmake_list (make_number (result_len
), Qnil
);
567 else if (target_type
== Lisp_Vectorlike
)
568 val
= Fmake_vector (make_number (result_len
), Qnil
);
569 else if (some_multibyte
)
570 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
572 val
= make_uninit_string (result_len
);
574 /* In `append', if all but last arg are nil, return last arg. */
575 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
578 /* Copy the contents of the args into the result. */
580 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
582 toindex
= 0, toindex_byte
= 0;
586 SAFE_NALLOCA (textprops
, 1, nargs
);
588 for (argnum
= 0; argnum
< nargs
; argnum
++)
591 ptrdiff_t thisleni
= 0;
592 register ptrdiff_t thisindex
= 0;
593 register ptrdiff_t thisindex_byte
= 0;
597 thislen
= Flength (this), thisleni
= XINT (thislen
);
599 /* Between strings of the same kind, copy fast. */
600 if (STRINGP (this) && STRINGP (val
)
601 && STRING_MULTIBYTE (this) == some_multibyte
)
603 ptrdiff_t thislen_byte
= SBYTES (this);
605 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
606 if (string_intervals (this))
608 textprops
[num_textprops
].argnum
= argnum
;
609 textprops
[num_textprops
].from
= 0;
610 textprops
[num_textprops
++].to
= toindex
;
612 toindex_byte
+= thislen_byte
;
615 /* Copy a single-byte string to a multibyte string. */
616 else if (STRINGP (this) && STRINGP (val
))
618 if (string_intervals (this))
620 textprops
[num_textprops
].argnum
= argnum
;
621 textprops
[num_textprops
].from
= 0;
622 textprops
[num_textprops
++].to
= toindex
;
624 toindex_byte
+= copy_text (SDATA (this),
625 SDATA (val
) + toindex_byte
,
626 SCHARS (this), 0, 1);
630 /* Copy element by element. */
633 register Lisp_Object elt
;
635 /* Fetch next element of `this' arg into `elt', or break if
636 `this' is exhausted. */
637 if (NILP (this)) break;
639 elt
= XCAR (this), this = XCDR (this);
640 else if (thisindex
>= thisleni
)
642 else if (STRINGP (this))
645 if (STRING_MULTIBYTE (this))
646 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
651 c
= SREF (this, thisindex
); thisindex
++;
652 if (some_multibyte
&& !ASCII_CHAR_P (c
))
653 c
= BYTE8_TO_CHAR (c
);
655 XSETFASTINT (elt
, c
);
657 else if (BOOL_VECTOR_P (this))
659 elt
= bool_vector_ref (this, thisindex
);
664 elt
= AREF (this, thisindex
);
668 /* Store this element into the result. */
675 else if (VECTORP (val
))
677 ASET (val
, toindex
, elt
);
683 CHECK_CHARACTER (elt
);
686 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
688 SSET (val
, toindex_byte
++, c
);
694 XSETCDR (prev
, last_tail
);
696 if (num_textprops
> 0)
699 ptrdiff_t last_to_end
= -1;
701 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
703 this = args
[textprops
[argnum
].argnum
];
704 props
= text_property_list (this,
706 make_number (SCHARS (this)),
708 /* If successive arguments have properties, be sure that the
709 value of `composition' property be the copy. */
710 if (last_to_end
== textprops
[argnum
].to
)
711 make_composition_value_copy (props
);
712 add_text_properties_from_list (val
, props
,
713 make_number (textprops
[argnum
].to
));
714 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
722 static Lisp_Object string_char_byte_cache_string
;
723 static ptrdiff_t string_char_byte_cache_charpos
;
724 static ptrdiff_t string_char_byte_cache_bytepos
;
727 clear_string_char_byte_cache (void)
729 string_char_byte_cache_string
= Qnil
;
732 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
735 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
738 ptrdiff_t best_below
, best_below_byte
;
739 ptrdiff_t best_above
, best_above_byte
;
741 best_below
= best_below_byte
= 0;
742 best_above
= SCHARS (string
);
743 best_above_byte
= SBYTES (string
);
744 if (best_above
== best_above_byte
)
747 if (EQ (string
, string_char_byte_cache_string
))
749 if (string_char_byte_cache_charpos
< char_index
)
751 best_below
= string_char_byte_cache_charpos
;
752 best_below_byte
= string_char_byte_cache_bytepos
;
756 best_above
= string_char_byte_cache_charpos
;
757 best_above_byte
= string_char_byte_cache_bytepos
;
761 if (char_index
- best_below
< best_above
- char_index
)
763 unsigned char *p
= SDATA (string
) + best_below_byte
;
765 while (best_below
< char_index
)
767 p
+= BYTES_BY_CHAR_HEAD (*p
);
770 i_byte
= p
- SDATA (string
);
774 unsigned char *p
= SDATA (string
) + best_above_byte
;
776 while (best_above
> char_index
)
779 while (!CHAR_HEAD_P (*p
)) p
--;
782 i_byte
= p
- SDATA (string
);
785 string_char_byte_cache_bytepos
= i_byte
;
786 string_char_byte_cache_charpos
= char_index
;
787 string_char_byte_cache_string
= string
;
792 /* Return the character index corresponding to BYTE_INDEX in STRING. */
795 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
798 ptrdiff_t best_below
, best_below_byte
;
799 ptrdiff_t best_above
, best_above_byte
;
801 best_below
= best_below_byte
= 0;
802 best_above
= SCHARS (string
);
803 best_above_byte
= SBYTES (string
);
804 if (best_above
== best_above_byte
)
807 if (EQ (string
, string_char_byte_cache_string
))
809 if (string_char_byte_cache_bytepos
< byte_index
)
811 best_below
= string_char_byte_cache_charpos
;
812 best_below_byte
= string_char_byte_cache_bytepos
;
816 best_above
= string_char_byte_cache_charpos
;
817 best_above_byte
= string_char_byte_cache_bytepos
;
821 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
823 unsigned char *p
= SDATA (string
) + best_below_byte
;
824 unsigned char *pend
= SDATA (string
) + byte_index
;
828 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
837 unsigned char *pbeg
= SDATA (string
) + byte_index
;
842 while (!CHAR_HEAD_P (*p
)) p
--;
846 i_byte
= p
- SDATA (string
);
849 string_char_byte_cache_bytepos
= i_byte
;
850 string_char_byte_cache_charpos
= i
;
851 string_char_byte_cache_string
= string
;
856 /* Convert STRING to a multibyte string. */
859 string_make_multibyte (Lisp_Object string
)
866 if (STRING_MULTIBYTE (string
))
869 nbytes
= count_size_as_multibyte (SDATA (string
),
871 /* If all the chars are ASCII, they won't need any more bytes
872 once converted. In that case, we can return STRING itself. */
873 if (nbytes
== SBYTES (string
))
876 buf
= SAFE_ALLOCA (nbytes
);
877 copy_text (SDATA (string
), buf
, SBYTES (string
),
880 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
887 /* Convert STRING (if unibyte) to a multibyte string without changing
888 the number of characters. Characters 0200 trough 0237 are
889 converted to eight-bit characters. */
892 string_to_multibyte (Lisp_Object string
)
899 if (STRING_MULTIBYTE (string
))
902 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
903 /* If all the chars are ASCII, they won't need any more bytes once
905 if (nbytes
== SBYTES (string
))
906 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
908 buf
= SAFE_ALLOCA (nbytes
);
909 memcpy (buf
, SDATA (string
), SBYTES (string
));
910 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
912 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
919 /* Convert STRING to a single-byte string. */
922 string_make_unibyte (Lisp_Object string
)
929 if (! STRING_MULTIBYTE (string
))
932 nchars
= SCHARS (string
);
934 buf
= SAFE_ALLOCA (nchars
);
935 copy_text (SDATA (string
), buf
, SBYTES (string
),
938 ret
= make_unibyte_string ((char *) buf
, nchars
);
944 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
946 doc
: /* Return the multibyte equivalent of STRING.
947 If STRING is unibyte and contains non-ASCII characters, the function
948 `unibyte-char-to-multibyte' is used to convert each unibyte character
949 to a multibyte character. In this case, the returned string is a
950 newly created string with no text properties. If STRING is multibyte
951 or entirely ASCII, it is returned unchanged. In particular, when
952 STRING is unibyte and entirely ASCII, the returned string is unibyte.
953 \(When the characters are all ASCII, Emacs primitives will treat the
954 string the same way whether it is unibyte or multibyte.) */)
957 CHECK_STRING (string
);
959 return string_make_multibyte (string
);
962 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
964 doc
: /* Return the unibyte equivalent of STRING.
965 Multibyte character codes are converted to unibyte according to
966 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
967 If the lookup in the translation table fails, this function takes just
968 the low 8 bits of each character. */)
971 CHECK_STRING (string
);
973 return string_make_unibyte (string
);
976 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
978 doc
: /* Return a unibyte string with the same individual bytes as STRING.
979 If STRING is unibyte, the result is STRING itself.
980 Otherwise it is a newly created string, with no text properties.
981 If STRING is multibyte and contains a character of charset
982 `eight-bit', it is converted to the corresponding single byte. */)
985 CHECK_STRING (string
);
987 if (STRING_MULTIBYTE (string
))
989 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
990 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
992 string
= make_unibyte_string ((char *) str
, bytes
);
998 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1000 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1001 If STRING is multibyte, the result is STRING itself.
1002 Otherwise it is a newly created string, with no text properties.
1004 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1005 part of a correct utf-8 sequence), it is converted to the corresponding
1006 multibyte character of charset `eight-bit'.
1007 See also `string-to-multibyte'.
1009 Beware, this often doesn't really do what you think it does.
1010 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1011 If you're not sure, whether to use `string-as-multibyte' or
1012 `string-to-multibyte', use `string-to-multibyte'. */)
1013 (Lisp_Object string
)
1015 CHECK_STRING (string
);
1017 if (! STRING_MULTIBYTE (string
))
1019 Lisp_Object new_string
;
1020 ptrdiff_t nchars
, nbytes
;
1022 parse_str_as_multibyte (SDATA (string
),
1025 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1026 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1027 if (nbytes
!= SBYTES (string
))
1028 str_as_multibyte (SDATA (new_string
), nbytes
,
1029 SBYTES (string
), NULL
);
1030 string
= new_string
;
1031 set_string_intervals (string
, NULL
);
1036 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1038 doc
: /* Return a multibyte string with the same individual chars as STRING.
1039 If STRING is multibyte, the result is STRING itself.
1040 Otherwise it is a newly created string, with no text properties.
1042 If STRING is unibyte and contains an 8-bit byte, it is converted to
1043 the corresponding multibyte character of charset `eight-bit'.
1045 This differs from `string-as-multibyte' by converting each byte of a correct
1046 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1047 correct sequence. */)
1048 (Lisp_Object string
)
1050 CHECK_STRING (string
);
1052 return string_to_multibyte (string
);
1055 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1057 doc
: /* Return a unibyte string with the same individual chars as STRING.
1058 If STRING is unibyte, the result is STRING itself.
1059 Otherwise it is a newly created string, with no text properties,
1060 where each `eight-bit' character is converted to the corresponding byte.
1061 If STRING contains a non-ASCII, non-`eight-bit' character,
1062 an error is signaled. */)
1063 (Lisp_Object string
)
1065 CHECK_STRING (string
);
1067 if (STRING_MULTIBYTE (string
))
1069 ptrdiff_t chars
= SCHARS (string
);
1070 unsigned char *str
= xmalloc (chars
);
1071 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1073 if (converted
< chars
)
1074 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1075 string
= make_unibyte_string ((char *) str
, chars
);
1082 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1083 doc
: /* Return a copy of ALIST.
1084 This is an alist which represents the same mapping from objects to objects,
1085 but does not share the alist structure with ALIST.
1086 The objects mapped (cars and cdrs of elements of the alist)
1087 are shared, however.
1088 Elements of ALIST that are not conses are also shared. */)
1091 register Lisp_Object tem
;
1096 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1097 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1099 register Lisp_Object car
;
1103 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1108 /* Check that ARRAY can have a valid subarray [FROM..TO),
1109 given that its size is SIZE.
1110 If FROM is nil, use 0; if TO is nil, use SIZE.
1111 Count negative values backwards from the end.
1112 Set *IFROM and *ITO to the two indexes used. */
1115 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1116 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1120 if (INTEGERP (from
))
1126 else if (NILP (from
))
1129 wrong_type_argument (Qintegerp
, from
);
1140 wrong_type_argument (Qintegerp
, to
);
1142 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1143 args_out_of_range_3 (array
, from
, to
);
1149 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1150 doc
: /* Return a new string whose contents are a substring of STRING.
1151 The returned string consists of the characters between index FROM
1152 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1153 zero-indexed: 0 means the first character of STRING. Negative values
1154 are counted from the end of STRING. If TO is nil, the substring runs
1155 to the end of STRING.
1157 The STRING argument may also be a vector. In that case, the return
1158 value is a new vector that contains the elements between index FROM
1159 \(inclusive) and index TO (exclusive) of that vector argument.
1161 With one argument, just copy STRING (with properties, if any). */)
1162 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1165 ptrdiff_t size
, ifrom
, ito
;
1167 if (STRINGP (string
))
1168 size
= SCHARS (string
);
1169 else if (VECTORP (string
))
1170 size
= ASIZE (string
);
1172 wrong_type_argument (Qarrayp
, string
);
1174 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1176 if (STRINGP (string
))
1179 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1181 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1182 res
= make_specified_string (SSDATA (string
) + from_byte
,
1183 ito
- ifrom
, to_byte
- from_byte
,
1184 STRING_MULTIBYTE (string
));
1185 copy_text_properties (make_number (ifrom
), make_number (ito
),
1186 string
, make_number (0), res
, Qnil
);
1189 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1195 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1196 doc
: /* Return a substring of STRING, without text properties.
1197 It starts at index FROM and ends before TO.
1198 TO may be nil or omitted; then the substring runs to the end of STRING.
1199 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1200 If FROM or TO is negative, it counts from the end.
1202 With one argument, just copy STRING without its properties. */)
1203 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1205 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1207 CHECK_STRING (string
);
1209 size
= SCHARS (string
);
1210 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1212 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1214 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1215 return make_specified_string (SSDATA (string
) + from_byte
,
1216 to_char
- from_char
, to_byte
- from_byte
,
1217 STRING_MULTIBYTE (string
));
1220 /* Extract a substring of STRING, giving start and end positions
1221 both in characters and in bytes. */
1224 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1225 ptrdiff_t to
, ptrdiff_t to_byte
)
1230 CHECK_VECTOR_OR_STRING (string
);
1232 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1234 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1235 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1237 if (STRINGP (string
))
1239 res
= make_specified_string (SSDATA (string
) + from_byte
,
1240 to
- from
, to_byte
- from_byte
,
1241 STRING_MULTIBYTE (string
));
1242 copy_text_properties (make_number (from
), make_number (to
),
1243 string
, make_number (0), res
, Qnil
);
1246 res
= Fvector (to
- from
, aref_addr (string
, from
));
1251 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1252 doc
: /* Take cdr N times on LIST, return the result. */)
1253 (Lisp_Object n
, Lisp_Object list
)
1258 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1261 CHECK_LIST_CONS (list
, list
);
1267 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1268 doc
: /* Return the Nth element of LIST.
1269 N counts from zero. If LIST is not that long, nil is returned. */)
1270 (Lisp_Object n
, Lisp_Object list
)
1272 return Fcar (Fnthcdr (n
, list
));
1275 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1276 doc
: /* Return element of SEQUENCE at index N. */)
1277 (register Lisp_Object sequence
, Lisp_Object n
)
1280 if (CONSP (sequence
) || NILP (sequence
))
1281 return Fcar (Fnthcdr (n
, sequence
));
1283 /* Faref signals a "not array" error, so check here. */
1284 CHECK_ARRAY (sequence
, Qsequencep
);
1285 return Faref (sequence
, n
);
1288 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1289 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1290 The value is actually the tail of LIST whose car is ELT. */)
1291 (register Lisp_Object elt
, Lisp_Object list
)
1293 register Lisp_Object tail
;
1294 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1296 register Lisp_Object tem
;
1297 CHECK_LIST_CONS (tail
, list
);
1299 if (! NILP (Fequal (elt
, tem
)))
1306 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1307 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1308 The value is actually the tail of LIST whose car is ELT. */)
1309 (register Lisp_Object elt
, Lisp_Object list
)
1313 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1317 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1321 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1332 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1333 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1334 The value is actually the tail of LIST whose car is ELT. */)
1335 (register Lisp_Object elt
, Lisp_Object list
)
1337 register Lisp_Object tail
;
1340 return Fmemq (elt
, list
);
1342 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1344 register Lisp_Object tem
;
1345 CHECK_LIST_CONS (tail
, list
);
1347 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1354 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1355 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1356 The value is actually the first element of LIST whose car is KEY.
1357 Elements of LIST that are not conses are ignored. */)
1358 (Lisp_Object key
, Lisp_Object list
)
1363 || (CONSP (XCAR (list
))
1364 && EQ (XCAR (XCAR (list
)), key
)))
1369 || (CONSP (XCAR (list
))
1370 && EQ (XCAR (XCAR (list
)), key
)))
1375 || (CONSP (XCAR (list
))
1376 && EQ (XCAR (XCAR (list
)), key
)))
1386 /* Like Fassq but never report an error and do not allow quits.
1387 Use only on lists known never to be circular. */
1390 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1393 && (!CONSP (XCAR (list
))
1394 || !EQ (XCAR (XCAR (list
)), key
)))
1397 return CAR_SAFE (list
);
1400 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1401 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1402 The value is actually the first element of LIST whose car equals KEY. */)
1403 (Lisp_Object key
, Lisp_Object list
)
1410 || (CONSP (XCAR (list
))
1411 && (car
= XCAR (XCAR (list
)),
1412 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1417 || (CONSP (XCAR (list
))
1418 && (car
= XCAR (XCAR (list
)),
1419 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1424 || (CONSP (XCAR (list
))
1425 && (car
= XCAR (XCAR (list
)),
1426 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1436 /* Like Fassoc but never report an error and do not allow quits.
1437 Use only on lists known never to be circular. */
1440 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1443 && (!CONSP (XCAR (list
))
1444 || (!EQ (XCAR (XCAR (list
)), key
)
1445 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1448 return CONSP (list
) ? XCAR (list
) : Qnil
;
1451 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1452 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1453 The value is actually the first element of LIST whose cdr is KEY. */)
1454 (register Lisp_Object key
, Lisp_Object list
)
1459 || (CONSP (XCAR (list
))
1460 && EQ (XCDR (XCAR (list
)), key
)))
1465 || (CONSP (XCAR (list
))
1466 && EQ (XCDR (XCAR (list
)), key
)))
1471 || (CONSP (XCAR (list
))
1472 && EQ (XCDR (XCAR (list
)), key
)))
1482 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1483 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1484 The value is actually the first element of LIST whose cdr equals KEY. */)
1485 (Lisp_Object key
, Lisp_Object list
)
1492 || (CONSP (XCAR (list
))
1493 && (cdr
= XCDR (XCAR (list
)),
1494 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1499 || (CONSP (XCAR (list
))
1500 && (cdr
= XCDR (XCAR (list
)),
1501 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1506 || (CONSP (XCAR (list
))
1507 && (cdr
= XCDR (XCAR (list
)),
1508 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1518 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1519 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1520 More precisely, this function skips any members `eq' to ELT at the
1521 front of LIST, then removes members `eq' to ELT from the remaining
1522 sublist by modifying its list structure, then returns the resulting
1525 Write `(setq foo (delq element foo))' to be sure of correctly changing
1526 the value of a list `foo'. */)
1527 (register Lisp_Object elt
, Lisp_Object list
)
1529 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1532 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1534 Lisp_Object tem
= XCAR (tail
);
1540 Fsetcdr (prev
, XCDR (tail
));
1548 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1549 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1550 SEQ must be a sequence (i.e. a list, a vector, or a string).
1551 The return value is a sequence of the same type.
1553 If SEQ is a list, this behaves like `delq', except that it compares
1554 with `equal' instead of `eq'. In particular, it may remove elements
1555 by altering the list structure.
1557 If SEQ is not a list, deletion is never performed destructively;
1558 instead this function creates and returns a new vector or string.
1560 Write `(setq foo (delete element foo))' to be sure of correctly
1561 changing the value of a sequence `foo'. */)
1562 (Lisp_Object elt
, Lisp_Object seq
)
1568 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1569 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1572 if (n
!= ASIZE (seq
))
1574 struct Lisp_Vector
*p
= allocate_vector (n
);
1576 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1577 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1578 p
->contents
[n
++] = AREF (seq
, i
);
1580 XSETVECTOR (seq
, p
);
1583 else if (STRINGP (seq
))
1585 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1588 for (i
= nchars
= nbytes
= ibyte
= 0;
1590 ++i
, ibyte
+= cbytes
)
1592 if (STRING_MULTIBYTE (seq
))
1594 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1595 cbytes
= CHAR_BYTES (c
);
1603 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1610 if (nchars
!= SCHARS (seq
))
1614 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1615 if (!STRING_MULTIBYTE (seq
))
1616 STRING_SET_UNIBYTE (tem
);
1618 for (i
= nchars
= nbytes
= ibyte
= 0;
1620 ++i
, ibyte
+= cbytes
)
1622 if (STRING_MULTIBYTE (seq
))
1624 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1625 cbytes
= CHAR_BYTES (c
);
1633 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1635 unsigned char *from
= SDATA (seq
) + ibyte
;
1636 unsigned char *to
= SDATA (tem
) + nbytes
;
1642 for (n
= cbytes
; n
--; )
1652 Lisp_Object tail
, prev
;
1654 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1656 CHECK_LIST_CONS (tail
, seq
);
1658 if (!NILP (Fequal (elt
, XCAR (tail
))))
1663 Fsetcdr (prev
, XCDR (tail
));
1674 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1675 doc
: /* Reverse order of items in a list, vector or string SEQ.
1676 If SEQ is a list, it should be nil-terminated.
1677 This function may destructively modify SEQ to produce the value. */)
1682 else if (STRINGP (seq
))
1683 return Freverse (seq
);
1684 else if (CONSP (seq
))
1686 Lisp_Object prev
, tail
, next
;
1688 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1691 CHECK_LIST_CONS (tail
, tail
);
1693 Fsetcdr (tail
, prev
);
1698 else if (VECTORP (seq
))
1700 ptrdiff_t i
, size
= ASIZE (seq
);
1702 for (i
= 0; i
< size
/ 2; i
++)
1704 Lisp_Object tem
= AREF (seq
, i
);
1705 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1706 ASET (seq
, size
- i
- 1, tem
);
1709 else if (BOOL_VECTOR_P (seq
))
1711 ptrdiff_t i
, size
= bool_vector_size (seq
);
1713 for (i
= 0; i
< size
/ 2; i
++)
1715 bool tem
= bool_vector_bitref (seq
, i
);
1716 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1717 bool_vector_set (seq
, size
- i
- 1, tem
);
1721 wrong_type_argument (Qarrayp
, seq
);
1725 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1726 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1727 See also the function `nreverse', which is used more often. */)
1734 else if (CONSP (seq
))
1736 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1739 new = Fcons (XCAR (seq
), new);
1741 CHECK_LIST_END (seq
, seq
);
1743 else if (VECTORP (seq
))
1745 ptrdiff_t i
, size
= ASIZE (seq
);
1747 new = make_uninit_vector (size
);
1748 for (i
= 0; i
< size
; i
++)
1749 ASET (new, i
, AREF (seq
, size
- i
- 1));
1751 else if (BOOL_VECTOR_P (seq
))
1754 EMACS_INT nbits
= bool_vector_size (seq
);
1756 new = make_uninit_bool_vector (nbits
);
1757 for (i
= 0; i
< nbits
; i
++)
1758 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1760 else if (STRINGP (seq
))
1762 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1768 new = make_uninit_string (size
);
1769 for (i
= 0; i
< size
; i
++)
1770 SSET (new, i
, SREF (seq
, size
- i
- 1));
1774 unsigned char *p
, *q
;
1776 new = make_uninit_multibyte_string (size
, bytes
);
1777 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1778 while (q
> SDATA (new))
1782 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1784 CHAR_STRING (ch
, q
);
1789 wrong_type_argument (Qsequencep
, seq
);
1793 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1794 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1795 Returns the sorted list. LIST is modified by side effects.
1796 PREDICATE is called with two elements of LIST, and should return non-nil
1797 if the first element should sort before the second. */)
1798 (Lisp_Object list
, Lisp_Object predicate
)
1800 Lisp_Object front
, back
;
1801 register Lisp_Object len
, tem
;
1802 struct gcpro gcpro1
, gcpro2
;
1806 len
= Flength (list
);
1807 length
= XINT (len
);
1811 XSETINT (len
, (length
/ 2) - 1);
1812 tem
= Fnthcdr (len
, list
);
1814 Fsetcdr (tem
, Qnil
);
1816 GCPRO2 (front
, back
);
1817 front
= Fsort (front
, predicate
);
1818 back
= Fsort (back
, predicate
);
1820 return merge (front
, back
, predicate
);
1824 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1827 register Lisp_Object tail
;
1829 register Lisp_Object l1
, l2
;
1830 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1837 /* It is sufficient to protect org_l1 and org_l2.
1838 When l1 and l2 are updated, we copy the new values
1839 back into the org_ vars. */
1840 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1860 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1876 Fsetcdr (tail
, tem
);
1882 /* This does not check for quits. That is safe since it must terminate. */
1884 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1885 doc
: /* Extract a value from a property list.
1886 PLIST is a property list, which is a list of the form
1887 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1888 corresponding to the given PROP, or nil if PROP is not one of the
1889 properties on the list. This function never signals an error. */)
1890 (Lisp_Object plist
, Lisp_Object prop
)
1892 Lisp_Object tail
, halftail
;
1894 /* halftail is used to detect circular lists. */
1895 tail
= halftail
= plist
;
1896 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1898 if (EQ (prop
, XCAR (tail
)))
1899 return XCAR (XCDR (tail
));
1901 tail
= XCDR (XCDR (tail
));
1902 halftail
= XCDR (halftail
);
1903 if (EQ (tail
, halftail
))
1910 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1911 doc
: /* Return the value of SYMBOL's PROPNAME property.
1912 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1913 (Lisp_Object symbol
, Lisp_Object propname
)
1915 CHECK_SYMBOL (symbol
);
1916 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1919 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1920 doc
: /* Change value in PLIST of PROP to VAL.
1921 PLIST is a property list, which is a list of the form
1922 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1923 If PROP is already a property on the list, its value is set to VAL,
1924 otherwise the new PROP VAL pair is added. The new plist is returned;
1925 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1926 The PLIST is modified by side effects. */)
1927 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1929 register Lisp_Object tail
, prev
;
1930 Lisp_Object newcell
;
1932 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1933 tail
= XCDR (XCDR (tail
)))
1935 if (EQ (prop
, XCAR (tail
)))
1937 Fsetcar (XCDR (tail
), val
);
1944 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1948 Fsetcdr (XCDR (prev
), newcell
);
1952 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1953 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1954 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1955 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1957 CHECK_SYMBOL (symbol
);
1959 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1963 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1964 doc
: /* Extract a value from a property list, comparing with `equal'.
1965 PLIST is a property list, which is a list of the form
1966 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1967 corresponding to the given PROP, or nil if PROP is not
1968 one of the properties on the list. */)
1969 (Lisp_Object plist
, Lisp_Object prop
)
1974 CONSP (tail
) && CONSP (XCDR (tail
));
1975 tail
= XCDR (XCDR (tail
)))
1977 if (! NILP (Fequal (prop
, XCAR (tail
))))
1978 return XCAR (XCDR (tail
));
1983 CHECK_LIST_END (tail
, prop
);
1988 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1989 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1990 PLIST is a property list, which is a list of the form
1991 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1992 If PROP is already a property on the list, its value is set to VAL,
1993 otherwise the new PROP VAL pair is added. The new plist is returned;
1994 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1995 The PLIST is modified by side effects. */)
1996 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1998 register Lisp_Object tail
, prev
;
1999 Lisp_Object newcell
;
2001 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2002 tail
= XCDR (XCDR (tail
)))
2004 if (! NILP (Fequal (prop
, XCAR (tail
))))
2006 Fsetcar (XCDR (tail
), val
);
2013 newcell
= list2 (prop
, val
);
2017 Fsetcdr (XCDR (prev
), newcell
);
2021 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2022 doc
: /* Return t if the two args are the same Lisp object.
2023 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2024 (Lisp_Object obj1
, Lisp_Object obj2
)
2027 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2029 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2032 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2033 doc
: /* Return t if two Lisp objects have similar structure and contents.
2034 They must have the same data type.
2035 Conses are compared by comparing the cars and the cdrs.
2036 Vectors and strings are compared element by element.
2037 Numbers are compared by value, but integers cannot equal floats.
2038 (Use `=' if you want integers and floats to be able to be equal.)
2039 Symbols must match exactly. */)
2040 (register Lisp_Object o1
, Lisp_Object o2
)
2042 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2045 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2046 doc
: /* Return t if two Lisp objects have similar structure and contents.
2047 This is like `equal' except that it compares the text properties
2048 of strings. (`equal' ignores text properties.) */)
2049 (register Lisp_Object o1
, Lisp_Object o2
)
2051 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2054 /* DEPTH is current depth of recursion. Signal an error if it
2056 PROPS means compare string text properties too. */
2059 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2065 error ("Stack overflow in equal");
2068 Lisp_Object args
[2];
2071 ht
= Fmake_hash_table (2, args
);
2075 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2077 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2079 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2081 { /* `o1' was seen already. */
2082 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2083 if (!NILP (Fmemq (o2
, o2s
)))
2086 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2089 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2099 if (XTYPE (o1
) != XTYPE (o2
))
2108 d1
= extract_float (o1
);
2109 d2
= extract_float (o2
);
2110 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2111 though they are not =. */
2112 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2116 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2120 /* FIXME: This inf-loops in a circular list! */
2124 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2128 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2129 depth
+ 1, props
, ht
)
2130 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2131 depth
+ 1, props
, ht
))
2133 o1
= XOVERLAY (o1
)->plist
;
2134 o2
= XOVERLAY (o2
)->plist
;
2139 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2140 && (XMARKER (o1
)->buffer
== 0
2141 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2145 case Lisp_Vectorlike
:
2148 ptrdiff_t size
= ASIZE (o1
);
2149 /* Pseudovectors have the type encoded in the size field, so this test
2150 actually checks that the objects have the same type as well as the
2152 if (ASIZE (o2
) != size
)
2154 /* Boolvectors are compared much like strings. */
2155 if (BOOL_VECTOR_P (o1
))
2157 EMACS_INT size
= bool_vector_size (o1
);
2158 if (size
!= bool_vector_size (o2
))
2160 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2161 bool_vector_bytes (size
)))
2165 if (WINDOW_CONFIGURATIONP (o1
))
2166 return compare_window_configurations (o1
, o2
, 0);
2168 /* Aside from them, only true vectors, char-tables, compiled
2169 functions, and fonts (font-spec, font-entity, font-object)
2170 are sensible to compare, so eliminate the others now. */
2171 if (size
& PSEUDOVECTOR_FLAG
)
2173 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2176 size
&= PSEUDOVECTOR_SIZE_MASK
;
2178 for (i
= 0; i
< size
; i
++)
2183 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2191 if (SCHARS (o1
) != SCHARS (o2
))
2193 if (SBYTES (o1
) != SBYTES (o2
))
2195 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2197 if (props
&& !compare_string_intervals (o1
, o2
))
2209 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2210 doc
: /* Store each element of ARRAY with ITEM.
2211 ARRAY is a vector, string, char-table, or bool-vector. */)
2212 (Lisp_Object array
, Lisp_Object item
)
2214 register ptrdiff_t size
, idx
;
2216 if (VECTORP (array
))
2217 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2218 ASET (array
, idx
, item
);
2219 else if (CHAR_TABLE_P (array
))
2223 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2224 set_char_table_contents (array
, i
, item
);
2225 set_char_table_defalt (array
, item
);
2227 else if (STRINGP (array
))
2229 register unsigned char *p
= SDATA (array
);
2231 CHECK_CHARACTER (item
);
2232 charval
= XFASTINT (item
);
2233 size
= SCHARS (array
);
2234 if (STRING_MULTIBYTE (array
))
2236 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2237 int len
= CHAR_STRING (charval
, str
);
2238 ptrdiff_t size_byte
= SBYTES (array
);
2240 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2241 || SCHARS (array
) * len
!= size_byte
)
2242 error ("Attempt to change byte length of a string");
2243 for (idx
= 0; idx
< size_byte
; idx
++)
2244 *p
++ = str
[idx
% len
];
2247 for (idx
= 0; idx
< size
; idx
++)
2250 else if (BOOL_VECTOR_P (array
))
2251 return bool_vector_fill (array
, item
);
2253 wrong_type_argument (Qarrayp
, array
);
2257 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2259 doc
: /* Clear the contents of STRING.
2260 This makes STRING unibyte and may change its length. */)
2261 (Lisp_Object string
)
2264 CHECK_STRING (string
);
2265 len
= SBYTES (string
);
2266 memset (SDATA (string
), 0, len
);
2267 STRING_SET_CHARS (string
, len
);
2268 STRING_SET_UNIBYTE (string
);
2274 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2276 Lisp_Object args
[2];
2279 return Fnconc (2, args
);
2282 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2283 doc
: /* Concatenate any number of lists by altering them.
2284 Only the last argument is not altered, and need not be a list.
2285 usage: (nconc &rest LISTS) */)
2286 (ptrdiff_t nargs
, Lisp_Object
*args
)
2289 register Lisp_Object tail
, tem
, val
;
2293 for (argnum
= 0; argnum
< nargs
; argnum
++)
2296 if (NILP (tem
)) continue;
2301 if (argnum
+ 1 == nargs
) break;
2303 CHECK_LIST_CONS (tem
, tem
);
2312 tem
= args
[argnum
+ 1];
2313 Fsetcdr (tail
, tem
);
2315 args
[argnum
+ 1] = tail
;
2321 /* This is the guts of all mapping functions.
2322 Apply FN to each element of SEQ, one by one,
2323 storing the results into elements of VALS, a C vector of Lisp_Objects.
2324 LENI is the length of VALS, which should also be the length of SEQ. */
2327 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2329 register Lisp_Object tail
;
2331 register EMACS_INT i
;
2332 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2336 /* Don't let vals contain any garbage when GC happens. */
2337 for (i
= 0; i
< leni
; i
++)
2340 GCPRO3 (dummy
, fn
, seq
);
2342 gcpro1
.nvars
= leni
;
2346 /* We need not explicitly protect `tail' because it is used only on lists, and
2347 1) lists are not relocated and 2) the list is marked via `seq' so will not
2350 if (VECTORP (seq
) || COMPILEDP (seq
))
2352 for (i
= 0; i
< leni
; i
++)
2354 dummy
= call1 (fn
, AREF (seq
, i
));
2359 else if (BOOL_VECTOR_P (seq
))
2361 for (i
= 0; i
< leni
; i
++)
2363 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2368 else if (STRINGP (seq
))
2372 for (i
= 0, i_byte
= 0; i
< leni
;)
2375 ptrdiff_t i_before
= i
;
2377 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2378 XSETFASTINT (dummy
, c
);
2379 dummy
= call1 (fn
, dummy
);
2381 vals
[i_before
] = dummy
;
2384 else /* Must be a list, since Flength did not get an error */
2387 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2389 dummy
= call1 (fn
, XCAR (tail
));
2399 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2400 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2401 In between each pair of results, stick in SEPARATOR. Thus, " " as
2402 SEPARATOR results in spaces between the values returned by FUNCTION.
2403 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2404 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2407 register EMACS_INT leni
;
2410 register Lisp_Object
*args
;
2411 struct gcpro gcpro1
;
2415 len
= Flength (sequence
);
2416 if (CHAR_TABLE_P (sequence
))
2417 wrong_type_argument (Qlistp
, sequence
);
2419 nargs
= leni
+ leni
- 1;
2420 if (nargs
< 0) return empty_unibyte_string
;
2422 SAFE_ALLOCA_LISP (args
, nargs
);
2425 mapcar1 (leni
, args
, function
, sequence
);
2428 for (i
= leni
- 1; i
> 0; i
--)
2429 args
[i
+ i
] = args
[i
];
2431 for (i
= 1; i
< nargs
; i
+= 2)
2432 args
[i
] = separator
;
2434 ret
= Fconcat (nargs
, args
);
2440 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2441 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2442 The result is a list just as long as SEQUENCE.
2443 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2444 (Lisp_Object function
, Lisp_Object sequence
)
2446 register Lisp_Object len
;
2447 register EMACS_INT leni
;
2448 register Lisp_Object
*args
;
2452 len
= Flength (sequence
);
2453 if (CHAR_TABLE_P (sequence
))
2454 wrong_type_argument (Qlistp
, sequence
);
2455 leni
= XFASTINT (len
);
2457 SAFE_ALLOCA_LISP (args
, leni
);
2459 mapcar1 (leni
, args
, function
, sequence
);
2461 ret
= Flist (leni
, args
);
2467 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2468 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2469 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2470 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2471 (Lisp_Object function
, Lisp_Object sequence
)
2473 register EMACS_INT leni
;
2475 leni
= XFASTINT (Flength (sequence
));
2476 if (CHAR_TABLE_P (sequence
))
2477 wrong_type_argument (Qlistp
, sequence
);
2478 mapcar1 (leni
, 0, function
, sequence
);
2483 /* This is how C code calls `yes-or-no-p' and allows the user
2486 Anything that calls this function must protect from GC! */
2489 do_yes_or_no_p (Lisp_Object prompt
)
2491 return call1 (intern ("yes-or-no-p"), prompt
);
2494 /* Anything that calls this function must protect from GC! */
2496 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2497 doc
: /* Ask user a yes-or-no question.
2498 Return t if answer is yes, and nil if the answer is no.
2499 PROMPT is the string to display to ask the question. It should end in
2500 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2502 The user must confirm the answer with RET, and can edit it until it
2505 If dialog boxes are supported, a dialog box will be used
2506 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2507 (Lisp_Object prompt
)
2509 register Lisp_Object ans
;
2510 Lisp_Object args
[2];
2511 struct gcpro gcpro1
;
2513 CHECK_STRING (prompt
);
2515 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2518 Lisp_Object pane
, menu
, obj
;
2519 redisplay_preserve_echo_area (4);
2520 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2521 Fcons (build_string ("No"), Qnil
));
2523 menu
= Fcons (prompt
, pane
);
2524 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2530 args
[1] = build_string ("(yes or no) ");
2531 prompt
= Fconcat (2, args
);
2537 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2538 Qyes_or_no_p_history
, Qnil
,
2540 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2545 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2553 message1 ("Please answer yes or no.");
2554 Fsleep_for (make_number (2), Qnil
);
2558 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2559 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2561 Each of the three load averages is multiplied by 100, then converted
2564 When USE-FLOATS is non-nil, floats will be used instead of integers.
2565 These floats are not multiplied by 100.
2567 If the 5-minute or 15-minute load averages are not available, return a
2568 shortened list, containing only those averages which are available.
2570 An error is thrown if the load average can't be obtained. In some
2571 cases making it work would require Emacs being installed setuid or
2572 setgid so that it can read kernel information, and that usually isn't
2574 (Lisp_Object use_floats
)
2577 int loads
= getloadavg (load_ave
, 3);
2578 Lisp_Object ret
= Qnil
;
2581 error ("load-average not implemented for this operating system");
2585 Lisp_Object load
= (NILP (use_floats
)
2586 ? make_number (100.0 * load_ave
[loads
])
2587 : make_float (load_ave
[loads
]));
2588 ret
= Fcons (load
, ret
);
2594 static Lisp_Object Qsubfeatures
;
2596 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2597 doc
: /* Return t if FEATURE is present in this Emacs.
2599 Use this to conditionalize execution of lisp code based on the
2600 presence or absence of Emacs or environment extensions.
2601 Use `provide' to declare that a feature is available. This function
2602 looks at the value of the variable `features'. The optional argument
2603 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2604 (Lisp_Object feature
, Lisp_Object subfeature
)
2606 register Lisp_Object tem
;
2607 CHECK_SYMBOL (feature
);
2608 tem
= Fmemq (feature
, Vfeatures
);
2609 if (!NILP (tem
) && !NILP (subfeature
))
2610 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2611 return (NILP (tem
)) ? Qnil
: Qt
;
2614 static Lisp_Object Qfuncall
;
2616 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2617 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2618 The optional argument SUBFEATURES should be a list of symbols listing
2619 particular subfeatures supported in this version of FEATURE. */)
2620 (Lisp_Object feature
, Lisp_Object subfeatures
)
2622 register Lisp_Object tem
;
2623 CHECK_SYMBOL (feature
);
2624 CHECK_LIST (subfeatures
);
2625 if (!NILP (Vautoload_queue
))
2626 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2628 tem
= Fmemq (feature
, Vfeatures
);
2630 Vfeatures
= Fcons (feature
, Vfeatures
);
2631 if (!NILP (subfeatures
))
2632 Fput (feature
, Qsubfeatures
, subfeatures
);
2633 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2635 /* Run any load-hooks for this file. */
2636 tem
= Fassq (feature
, Vafter_load_alist
);
2638 Fmapc (Qfuncall
, XCDR (tem
));
2643 /* `require' and its subroutines. */
2645 /* List of features currently being require'd, innermost first. */
2647 static Lisp_Object require_nesting_list
;
2650 require_unwind (Lisp_Object old_value
)
2652 require_nesting_list
= old_value
;
2655 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2656 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2657 If FEATURE is not a member of the list `features', then the feature
2658 is not loaded; so load the file FILENAME.
2659 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2660 and `load' will try to load this name appended with the suffix `.elc' or
2661 `.el', in that order. The name without appended suffix will not be used.
2662 See `get-load-suffixes' for the complete list of suffixes.
2663 If the optional third argument NOERROR is non-nil,
2664 then return nil if the file is not found instead of signaling an error.
2665 Normally the return value is FEATURE.
2666 The normal messages at start and end of loading FILENAME are suppressed. */)
2667 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2670 struct gcpro gcpro1
, gcpro2
;
2671 bool from_file
= load_in_progress
;
2673 CHECK_SYMBOL (feature
);
2675 /* Record the presence of `require' in this file
2676 even if the feature specified is already loaded.
2677 But not more than once in any file,
2678 and not when we aren't loading or reading from a file. */
2680 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2681 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2686 tem
= Fcons (Qrequire
, feature
);
2687 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2688 LOADHIST_ATTACH (tem
);
2690 tem
= Fmemq (feature
, Vfeatures
);
2694 ptrdiff_t count
= SPECPDL_INDEX ();
2697 /* This is to make sure that loadup.el gives a clear picture
2698 of what files are preloaded and when. */
2699 if (! NILP (Vpurify_flag
))
2700 error ("(require %s) while preparing to dump",
2701 SDATA (SYMBOL_NAME (feature
)));
2703 /* A certain amount of recursive `require' is legitimate,
2704 but if we require the same feature recursively 3 times,
2706 tem
= require_nesting_list
;
2707 while (! NILP (tem
))
2709 if (! NILP (Fequal (feature
, XCAR (tem
))))
2714 error ("Recursive `require' for feature `%s'",
2715 SDATA (SYMBOL_NAME (feature
)));
2717 /* Update the list for any nested `require's that occur. */
2718 record_unwind_protect (require_unwind
, require_nesting_list
);
2719 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2721 /* Value saved here is to be restored into Vautoload_queue */
2722 record_unwind_protect (un_autoload
, Vautoload_queue
);
2723 Vautoload_queue
= Qt
;
2725 /* Load the file. */
2726 GCPRO2 (feature
, filename
);
2727 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2728 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2731 /* If load failed entirely, return nil. */
2733 return unbind_to (count
, Qnil
);
2735 tem
= Fmemq (feature
, Vfeatures
);
2737 error ("Required feature `%s' was not provided",
2738 SDATA (SYMBOL_NAME (feature
)));
2740 /* Once loading finishes, don't undo it. */
2741 Vautoload_queue
= Qt
;
2742 feature
= unbind_to (count
, feature
);
2748 /* Primitives for work of the "widget" library.
2749 In an ideal world, this section would not have been necessary.
2750 However, lisp function calls being as slow as they are, it turns
2751 out that some functions in the widget library (wid-edit.el) are the
2752 bottleneck of Widget operation. Here is their translation to C,
2753 for the sole reason of efficiency. */
2755 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2756 doc
: /* Return non-nil if PLIST has the property PROP.
2757 PLIST is a property list, which is a list of the form
2758 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2759 Unlike `plist-get', this allows you to distinguish between a missing
2760 property and a property with the value nil.
2761 The value is actually the tail of PLIST whose car is PROP. */)
2762 (Lisp_Object plist
, Lisp_Object prop
)
2764 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2767 plist
= XCDR (plist
);
2768 plist
= CDR (plist
);
2773 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2774 doc
: /* In WIDGET, set PROPERTY to VALUE.
2775 The value can later be retrieved with `widget-get'. */)
2776 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2778 CHECK_CONS (widget
);
2779 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2783 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2784 doc
: /* In WIDGET, get the value of PROPERTY.
2785 The value could either be specified when the widget was created, or
2786 later with `widget-put'. */)
2787 (Lisp_Object widget
, Lisp_Object property
)
2795 CHECK_CONS (widget
);
2796 tmp
= Fplist_member (XCDR (widget
), property
);
2802 tmp
= XCAR (widget
);
2805 widget
= Fget (tmp
, Qwidget_type
);
2809 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2810 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2811 ARGS are passed as extra arguments to the function.
2812 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2813 (ptrdiff_t nargs
, Lisp_Object
*args
)
2815 /* This function can GC. */
2816 Lisp_Object newargs
[3];
2817 struct gcpro gcpro1
, gcpro2
;
2820 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2821 newargs
[1] = args
[0];
2822 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2823 GCPRO2 (newargs
[0], newargs
[2]);
2824 result
= Fapply (3, newargs
);
2829 #ifdef HAVE_LANGINFO_CODESET
2830 #include <langinfo.h>
2833 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2834 doc
: /* Access locale data ITEM for the current C locale, if available.
2835 ITEM should be one of the following:
2837 `codeset', returning the character set as a string (locale item CODESET);
2839 `days', returning a 7-element vector of day names (locale items DAY_n);
2841 `months', returning a 12-element vector of month names (locale items MON_n);
2843 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2844 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2846 If the system can't provide such information through a call to
2847 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2849 See also Info node `(libc)Locales'.
2851 The data read from the system are decoded using `locale-coding-system'. */)
2855 #ifdef HAVE_LANGINFO_CODESET
2857 if (EQ (item
, Qcodeset
))
2859 str
= nl_langinfo (CODESET
);
2860 return build_string (str
);
2863 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2865 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2866 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2868 struct gcpro gcpro1
;
2870 synchronize_system_time_locale ();
2871 for (i
= 0; i
< 7; i
++)
2873 str
= nl_langinfo (days
[i
]);
2874 val
= build_unibyte_string (str
);
2875 /* Fixme: Is this coding system necessarily right, even if
2876 it is consistent with CODESET? If not, what to do? */
2877 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2885 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2887 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2888 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2889 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2891 struct gcpro gcpro1
;
2893 synchronize_system_time_locale ();
2894 for (i
= 0; i
< 12; i
++)
2896 str
= nl_langinfo (months
[i
]);
2897 val
= build_unibyte_string (str
);
2898 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2905 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2906 but is in the locale files. This could be used by ps-print. */
2908 else if (EQ (item
, Qpaper
))
2909 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2910 #endif /* PAPER_WIDTH */
2911 #endif /* HAVE_LANGINFO_CODESET*/
2915 /* base64 encode/decode functions (RFC 2045).
2916 Based on code from GNU recode. */
2918 #define MIME_LINE_LENGTH 76
2920 #define IS_ASCII(Character) \
2922 #define IS_BASE64(Character) \
2923 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2924 #define IS_BASE64_IGNORABLE(Character) \
2925 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2926 || (Character) == '\f' || (Character) == '\r')
2928 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2929 character or return retval if there are no characters left to
2931 #define READ_QUADRUPLET_BYTE(retval) \
2936 if (nchars_return) \
2937 *nchars_return = nchars; \
2942 while (IS_BASE64_IGNORABLE (c))
2944 /* Table of characters coding the 64 values. */
2945 static const char base64_value_to_char
[64] =
2947 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2948 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2949 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2950 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2951 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2952 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2953 '8', '9', '+', '/' /* 60-63 */
2956 /* Table of base64 values for first 128 characters. */
2957 static const short base64_char_to_value
[128] =
2959 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2960 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2961 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2962 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2963 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2964 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2965 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2966 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2967 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2968 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2969 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2970 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2971 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2974 /* The following diagram shows the logical steps by which three octets
2975 get transformed into four base64 characters.
2977 .--------. .--------. .--------.
2978 |aaaaaabb| |bbbbcccc| |ccdddddd|
2979 `--------' `--------' `--------'
2981 .--------+--------+--------+--------.
2982 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2983 `--------+--------+--------+--------'
2985 .--------+--------+--------+--------.
2986 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2987 `--------+--------+--------+--------'
2989 The octets are divided into 6 bit chunks, which are then encoded into
2990 base64 characters. */
2993 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2994 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2997 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2999 doc
: /* Base64-encode the region between BEG and END.
3000 Return the length of the encoded text.
3001 Optional third argument NO-LINE-BREAK means do not break long lines
3002 into shorter lines. */)
3003 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3006 ptrdiff_t allength
, length
;
3007 ptrdiff_t ibeg
, iend
, encoded_length
;
3008 ptrdiff_t old_pos
= PT
;
3011 validate_region (&beg
, &end
);
3013 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3014 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3015 move_gap_both (XFASTINT (beg
), ibeg
);
3017 /* We need to allocate enough room for encoding the text.
3018 We need 33 1/3% more space, plus a newline every 76
3019 characters, and then we round up. */
3020 length
= iend
- ibeg
;
3021 allength
= length
+ length
/3 + 1;
3022 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3024 encoded
= SAFE_ALLOCA (allength
);
3025 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3026 encoded
, length
, NILP (no_line_break
),
3027 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3028 if (encoded_length
> allength
)
3031 if (encoded_length
< 0)
3033 /* The encoding wasn't possible. */
3035 error ("Multibyte character in data for base64 encoding");
3038 /* Now we have encoded the region, so we insert the new contents
3039 and delete the old. (Insert first in order to preserve markers.) */
3040 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3041 insert (encoded
, encoded_length
);
3043 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3045 /* If point was outside of the region, restore it exactly; else just
3046 move to the beginning of the region. */
3047 if (old_pos
>= XFASTINT (end
))
3048 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3049 else if (old_pos
> XFASTINT (beg
))
3050 old_pos
= XFASTINT (beg
);
3053 /* We return the length of the encoded text. */
3054 return make_number (encoded_length
);
3057 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3059 doc
: /* Base64-encode STRING and return the result.
3060 Optional second argument NO-LINE-BREAK means do not break long lines
3061 into shorter lines. */)
3062 (Lisp_Object string
, Lisp_Object no_line_break
)
3064 ptrdiff_t allength
, length
, encoded_length
;
3066 Lisp_Object encoded_string
;
3069 CHECK_STRING (string
);
3071 /* We need to allocate enough room for encoding the text.
3072 We need 33 1/3% more space, plus a newline every 76
3073 characters, and then we round up. */
3074 length
= SBYTES (string
);
3075 allength
= length
+ length
/3 + 1;
3076 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3078 /* We need to allocate enough room for decoding the text. */
3079 encoded
= SAFE_ALLOCA (allength
);
3081 encoded_length
= base64_encode_1 (SSDATA (string
),
3082 encoded
, length
, NILP (no_line_break
),
3083 STRING_MULTIBYTE (string
));
3084 if (encoded_length
> allength
)
3087 if (encoded_length
< 0)
3089 /* The encoding wasn't possible. */
3091 error ("Multibyte character in data for base64 encoding");
3094 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3097 return encoded_string
;
3101 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3102 bool line_break
, bool multibyte
)
3115 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3116 if (CHAR_BYTE8_P (c
))
3117 c
= CHAR_TO_BYTE8 (c
);
3125 /* Wrap line every 76 characters. */
3129 if (counter
< MIME_LINE_LENGTH
/ 4)
3138 /* Process first byte of a triplet. */
3140 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3141 value
= (0x03 & c
) << 4;
3143 /* Process second byte of a triplet. */
3147 *e
++ = base64_value_to_char
[value
];
3155 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3156 if (CHAR_BYTE8_P (c
))
3157 c
= CHAR_TO_BYTE8 (c
);
3165 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3166 value
= (0x0f & c
) << 2;
3168 /* Process third byte of a triplet. */
3172 *e
++ = base64_value_to_char
[value
];
3179 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3180 if (CHAR_BYTE8_P (c
))
3181 c
= CHAR_TO_BYTE8 (c
);
3189 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3190 *e
++ = base64_value_to_char
[0x3f & c
];
3197 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3199 doc
: /* Base64-decode the region between BEG and END.
3200 Return the length of the decoded text.
3201 If the region can't be decoded, signal an error and don't modify the buffer. */)
3202 (Lisp_Object beg
, Lisp_Object end
)
3204 ptrdiff_t ibeg
, iend
, length
, allength
;
3206 ptrdiff_t old_pos
= PT
;
3207 ptrdiff_t decoded_length
;
3208 ptrdiff_t inserted_chars
;
3209 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3212 validate_region (&beg
, &end
);
3214 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3215 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3217 length
= iend
- ibeg
;
3219 /* We need to allocate enough room for decoding the text. If we are
3220 working on a multibyte buffer, each decoded code may occupy at
3222 allength
= multibyte
? length
* 2 : length
;
3223 decoded
= SAFE_ALLOCA (allength
);
3225 move_gap_both (XFASTINT (beg
), ibeg
);
3226 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3228 multibyte
, &inserted_chars
);
3229 if (decoded_length
> allength
)
3232 if (decoded_length
< 0)
3234 /* The decoding wasn't possible. */
3236 error ("Invalid base64 data");
3239 /* Now we have decoded the region, so we insert the new contents
3240 and delete the old. (Insert first in order to preserve markers.) */
3241 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3242 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3245 /* Delete the original text. */
3246 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3247 iend
+ decoded_length
, 1);
3249 /* If point was outside of the region, restore it exactly; else just
3250 move to the beginning of the region. */
3251 if (old_pos
>= XFASTINT (end
))
3252 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3253 else if (old_pos
> XFASTINT (beg
))
3254 old_pos
= XFASTINT (beg
);
3255 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3257 return make_number (inserted_chars
);
3260 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3262 doc
: /* Base64-decode STRING and return the result. */)
3263 (Lisp_Object string
)
3266 ptrdiff_t length
, decoded_length
;
3267 Lisp_Object decoded_string
;
3270 CHECK_STRING (string
);
3272 length
= SBYTES (string
);
3273 /* We need to allocate enough room for decoding the text. */
3274 decoded
= SAFE_ALLOCA (length
);
3276 /* The decoded result should be unibyte. */
3277 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3279 if (decoded_length
> length
)
3281 else if (decoded_length
>= 0)
3282 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3284 decoded_string
= Qnil
;
3287 if (!STRINGP (decoded_string
))
3288 error ("Invalid base64 data");
3290 return decoded_string
;
3293 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3294 MULTIBYTE, the decoded result should be in multibyte
3295 form. If NCHARS_RETURN is not NULL, store the number of produced
3296 characters in *NCHARS_RETURN. */
3299 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3300 bool multibyte
, ptrdiff_t *nchars_return
)
3302 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3305 unsigned long value
;
3306 ptrdiff_t nchars
= 0;
3310 /* Process first byte of a quadruplet. */
3312 READ_QUADRUPLET_BYTE (e
-to
);
3316 value
= base64_char_to_value
[c
] << 18;
3318 /* Process second byte of a quadruplet. */
3320 READ_QUADRUPLET_BYTE (-1);
3324 value
|= base64_char_to_value
[c
] << 12;
3326 c
= (unsigned char) (value
>> 16);
3327 if (multibyte
&& c
>= 128)
3328 e
+= BYTE8_STRING (c
, e
);
3333 /* Process third byte of a quadruplet. */
3335 READ_QUADRUPLET_BYTE (-1);
3339 READ_QUADRUPLET_BYTE (-1);
3348 value
|= base64_char_to_value
[c
] << 6;
3350 c
= (unsigned char) (0xff & value
>> 8);
3351 if (multibyte
&& c
>= 128)
3352 e
+= BYTE8_STRING (c
, e
);
3357 /* Process fourth byte of a quadruplet. */
3359 READ_QUADRUPLET_BYTE (-1);
3366 value
|= base64_char_to_value
[c
];
3368 c
= (unsigned char) (0xff & value
);
3369 if (multibyte
&& c
>= 128)
3370 e
+= BYTE8_STRING (c
, e
);
3379 /***********************************************************************
3381 ***** Hash Tables *****
3383 ***********************************************************************/
3385 /* Implemented by gerd@gnu.org. This hash table implementation was
3386 inspired by CMUCL hash tables. */
3390 1. For small tables, association lists are probably faster than
3391 hash tables because they have lower overhead.
3393 For uses of hash tables where the O(1) behavior of table
3394 operations is not a requirement, it might therefore be a good idea
3395 not to hash. Instead, we could just do a linear search in the
3396 key_and_value vector of the hash table. This could be done
3397 if a `:linear-search t' argument is given to make-hash-table. */
3400 /* The list of all weak hash tables. Don't staticpro this one. */
3402 static struct Lisp_Hash_Table
*weak_hash_tables
;
3404 /* Various symbols. */
3406 static Lisp_Object Qhash_table_p
;
3407 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3408 Lisp_Object Qeq
, Qequal
;
3409 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3410 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3413 /***********************************************************************
3415 ***********************************************************************/
3418 CHECK_HASH_TABLE (Lisp_Object x
)
3420 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3424 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3426 h
->key_and_value
= key_and_value
;
3429 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3434 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3436 gc_aset (h
->next
, idx
, val
);
3439 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3444 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3446 gc_aset (h
->hash
, idx
, val
);
3449 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3454 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3456 gc_aset (h
->index
, idx
, val
);
3459 /* If OBJ is a Lisp hash table, return a pointer to its struct
3460 Lisp_Hash_Table. Otherwise, signal an error. */
3462 static struct Lisp_Hash_Table
*
3463 check_hash_table (Lisp_Object obj
)
3465 CHECK_HASH_TABLE (obj
);
3466 return XHASH_TABLE (obj
);
3470 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3471 number. A number is "almost" a prime number if it is not divisible
3472 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3475 next_almost_prime (EMACS_INT n
)
3477 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3478 for (n
|= 1; ; n
+= 2)
3479 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3484 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3485 which USED[I] is non-zero. If found at index I in ARGS, set
3486 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3487 0. This function is used to extract a keyword/argument pair from
3488 a DEFUN parameter list. */
3491 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3495 for (i
= 1; i
< nargs
; i
++)
3496 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3507 /* Return a Lisp vector which has the same contents as VEC but has
3508 at least INCR_MIN more entries, where INCR_MIN is positive.
3509 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3510 than NITEMS_MAX. Entries in the resulting
3511 vector that are not copied from VEC are set to nil. */
3514 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3516 struct Lisp_Vector
*v
;
3517 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3518 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3519 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3520 ? nitems_max
: C_language_max
);
3521 eassert (VECTORP (vec
));
3522 eassert (0 < incr_min
&& -1 <= nitems_max
);
3523 old_size
= ASIZE (vec
);
3524 incr_max
= n_max
- old_size
;
3525 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3526 if (incr_max
< incr
)
3527 memory_full (SIZE_MAX
);
3528 new_size
= old_size
+ incr
;
3529 v
= allocate_vector (new_size
);
3530 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3531 for (i
= old_size
; i
< new_size
; ++i
)
3532 v
->contents
[i
] = Qnil
;
3533 XSETVECTOR (vec
, v
);
3538 /***********************************************************************
3540 ***********************************************************************/
3542 static struct hash_table_test hashtest_eq
;
3543 struct hash_table_test hashtest_eql
, hashtest_equal
;
3545 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3546 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3547 KEY2 are the same. */
3550 cmpfn_eql (struct hash_table_test
*ht
,
3554 return (FLOATP (key1
)
3556 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3560 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3561 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3562 KEY2 are the same. */
3565 cmpfn_equal (struct hash_table_test
*ht
,
3569 return !NILP (Fequal (key1
, key2
));
3573 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3574 HASH2 in hash table H using H->user_cmp_function. Value is true
3575 if KEY1 and KEY2 are the same. */
3578 cmpfn_user_defined (struct hash_table_test
*ht
,
3582 Lisp_Object args
[3];
3584 args
[0] = ht
->user_cmp_function
;
3587 return !NILP (Ffuncall (3, args
));
3591 /* Value is a hash code for KEY for use in hash table H which uses
3592 `eq' to compare keys. The hash code returned is guaranteed to fit
3593 in a Lisp integer. */
3596 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3598 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3602 /* Value is a hash code for KEY for use in hash table H which uses
3603 `eql' to compare keys. The hash code returned is guaranteed to fit
3604 in a Lisp integer. */
3607 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3611 hash
= sxhash (key
, 0);
3613 hash
= XHASH (key
) ^ XTYPE (key
);
3617 /* Value is a hash code for KEY for use in hash table H which uses
3618 `equal' to compare keys. The hash code returned is guaranteed to fit
3619 in a Lisp integer. */
3622 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3624 EMACS_UINT hash
= sxhash (key
, 0);
3628 /* Value is a hash code for KEY for use in hash table H which uses as
3629 user-defined function to compare keys. The hash code returned is
3630 guaranteed to fit in a Lisp integer. */
3633 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3635 Lisp_Object args
[2], hash
;
3637 args
[0] = ht
->user_hash_function
;
3639 hash
= Ffuncall (2, args
);
3640 return hashfn_eq (ht
, hash
);
3643 /* An upper bound on the size of a hash table index. It must fit in
3644 ptrdiff_t and be a valid Emacs fixnum. */
3645 #define INDEX_SIZE_BOUND \
3646 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3648 /* Create and initialize a new hash table.
3650 TEST specifies the test the hash table will use to compare keys.
3651 It must be either one of the predefined tests `eq', `eql' or
3652 `equal' or a symbol denoting a user-defined test named TEST with
3653 test and hash functions USER_TEST and USER_HASH.
3655 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3657 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3658 new size when it becomes full is computed by adding REHASH_SIZE to
3659 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3660 table's new size is computed by multiplying its old size with
3663 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3664 be resized when the ratio of (number of entries in the table) /
3665 (table size) is >= REHASH_THRESHOLD.
3667 WEAK specifies the weakness of the table. If non-nil, it must be
3668 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3671 make_hash_table (struct hash_table_test test
,
3672 Lisp_Object size
, Lisp_Object rehash_size
,
3673 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3675 struct Lisp_Hash_Table
*h
;
3677 EMACS_INT index_size
, sz
;
3681 /* Preconditions. */
3682 eassert (SYMBOLP (test
.name
));
3683 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3684 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3685 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3686 eassert (FLOATP (rehash_threshold
)
3687 && 0 < XFLOAT_DATA (rehash_threshold
)
3688 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3690 if (XFASTINT (size
) == 0)
3691 size
= make_number (1);
3693 sz
= XFASTINT (size
);
3694 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3695 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3696 ? next_almost_prime (index_float
)
3697 : INDEX_SIZE_BOUND
+ 1);
3698 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3699 error ("Hash table too large");
3701 /* Allocate a table and initialize it. */
3702 h
= allocate_hash_table ();
3704 /* Initialize hash table slots. */
3707 h
->rehash_threshold
= rehash_threshold
;
3708 h
->rehash_size
= rehash_size
;
3710 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3711 h
->hash
= Fmake_vector (size
, Qnil
);
3712 h
->next
= Fmake_vector (size
, Qnil
);
3713 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3715 /* Set up the free list. */
3716 for (i
= 0; i
< sz
- 1; ++i
)
3717 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3718 h
->next_free
= make_number (0);
3720 XSET_HASH_TABLE (table
, h
);
3721 eassert (HASH_TABLE_P (table
));
3722 eassert (XHASH_TABLE (table
) == h
);
3724 /* Maybe add this hash table to the list of all weak hash tables. */
3726 h
->next_weak
= NULL
;
3729 h
->next_weak
= weak_hash_tables
;
3730 weak_hash_tables
= h
;
3737 /* Return a copy of hash table H1. Keys and values are not copied,
3738 only the table itself is. */
3741 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3744 struct Lisp_Hash_Table
*h2
;
3746 h2
= allocate_hash_table ();
3748 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3749 h2
->hash
= Fcopy_sequence (h1
->hash
);
3750 h2
->next
= Fcopy_sequence (h1
->next
);
3751 h2
->index
= Fcopy_sequence (h1
->index
);
3752 XSET_HASH_TABLE (table
, h2
);
3754 /* Maybe add this hash table to the list of all weak hash tables. */
3755 if (!NILP (h2
->weak
))
3757 h2
->next_weak
= weak_hash_tables
;
3758 weak_hash_tables
= h2
;
3765 /* Resize hash table H if it's too full. If H cannot be resized
3766 because it's already too large, throw an error. */
3769 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3771 if (NILP (h
->next_free
))
3773 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3774 EMACS_INT new_size
, index_size
, nsize
;
3778 if (INTEGERP (h
->rehash_size
))
3779 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3782 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3783 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3785 new_size
= float_new_size
;
3786 if (new_size
<= old_size
)
3787 new_size
= old_size
+ 1;
3790 new_size
= INDEX_SIZE_BOUND
+ 1;
3792 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3793 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3794 ? next_almost_prime (index_float
)
3795 : INDEX_SIZE_BOUND
+ 1);
3796 nsize
= max (index_size
, 2 * new_size
);
3797 if (INDEX_SIZE_BOUND
< nsize
)
3798 error ("Hash table too large to resize");
3800 #ifdef ENABLE_CHECKING
3801 if (HASH_TABLE_P (Vpurify_flag
)
3802 && XHASH_TABLE (Vpurify_flag
) == h
)
3804 Lisp_Object args
[2];
3805 args
[0] = build_string ("Growing hash table to: %d");
3806 args
[1] = make_number (new_size
);
3811 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3812 2 * (new_size
- old_size
), -1));
3813 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3814 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3815 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3817 /* Update the free list. Do it so that new entries are added at
3818 the end of the free list. This makes some operations like
3820 for (i
= old_size
; i
< new_size
- 1; ++i
)
3821 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3823 if (!NILP (h
->next_free
))
3825 Lisp_Object last
, next
;
3827 last
= h
->next_free
;
3828 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3832 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3835 XSETFASTINT (h
->next_free
, old_size
);
3838 for (i
= 0; i
< old_size
; ++i
)
3839 if (!NILP (HASH_HASH (h
, i
)))
3841 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3842 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3843 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3844 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3850 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3851 the hash code of KEY. Value is the index of the entry in H
3852 matching KEY, or -1 if not found. */
3855 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3857 EMACS_UINT hash_code
;
3858 ptrdiff_t start_of_bucket
;
3861 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3862 eassert ((hash_code
& ~INTMASK
) == 0);
3866 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3867 idx
= HASH_INDEX (h
, start_of_bucket
);
3869 /* We need not gcpro idx since it's either an integer or nil. */
3872 ptrdiff_t i
= XFASTINT (idx
);
3873 if (EQ (key
, HASH_KEY (h
, i
))
3875 && hash_code
== XUINT (HASH_HASH (h
, i
))
3876 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3878 idx
= HASH_NEXT (h
, i
);
3881 return NILP (idx
) ? -1 : XFASTINT (idx
);
3885 /* Put an entry into hash table H that associates KEY with VALUE.
3886 HASH is a previously computed hash code of KEY.
3887 Value is the index of the entry in H matching KEY. */
3890 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3893 ptrdiff_t start_of_bucket
, i
;
3895 eassert ((hash
& ~INTMASK
) == 0);
3897 /* Increment count after resizing because resizing may fail. */
3898 maybe_resize_hash_table (h
);
3901 /* Store key/value in the key_and_value vector. */
3902 i
= XFASTINT (h
->next_free
);
3903 h
->next_free
= HASH_NEXT (h
, i
);
3904 set_hash_key_slot (h
, i
, key
);
3905 set_hash_value_slot (h
, i
, value
);
3907 /* Remember its hash code. */
3908 set_hash_hash_slot (h
, i
, make_number (hash
));
3910 /* Add new entry to its collision chain. */
3911 start_of_bucket
= hash
% ASIZE (h
->index
);
3912 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3913 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3918 /* Remove the entry matching KEY from hash table H, if there is one. */
3921 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3923 EMACS_UINT hash_code
;
3924 ptrdiff_t start_of_bucket
;
3925 Lisp_Object idx
, prev
;
3927 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3928 eassert ((hash_code
& ~INTMASK
) == 0);
3929 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3930 idx
= HASH_INDEX (h
, start_of_bucket
);
3933 /* We need not gcpro idx, prev since they're either integers or nil. */
3936 ptrdiff_t i
= XFASTINT (idx
);
3938 if (EQ (key
, HASH_KEY (h
, i
))
3940 && hash_code
== XUINT (HASH_HASH (h
, i
))
3941 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3943 /* Take entry out of collision chain. */
3945 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3947 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3949 /* Clear slots in key_and_value and add the slots to
3951 set_hash_key_slot (h
, i
, Qnil
);
3952 set_hash_value_slot (h
, i
, Qnil
);
3953 set_hash_hash_slot (h
, i
, Qnil
);
3954 set_hash_next_slot (h
, i
, h
->next_free
);
3955 h
->next_free
= make_number (i
);
3957 eassert (h
->count
>= 0);
3963 idx
= HASH_NEXT (h
, i
);
3969 /* Clear hash table H. */
3972 hash_clear (struct Lisp_Hash_Table
*h
)
3976 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3978 for (i
= 0; i
< size
; ++i
)
3980 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3981 set_hash_key_slot (h
, i
, Qnil
);
3982 set_hash_value_slot (h
, i
, Qnil
);
3983 set_hash_hash_slot (h
, i
, Qnil
);
3986 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3987 ASET (h
->index
, i
, Qnil
);
3989 h
->next_free
= make_number (0);
3996 /************************************************************************
3998 ************************************************************************/
4000 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4001 entries from the table that don't survive the current GC.
4002 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4003 true if anything was marked. */
4006 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4008 ptrdiff_t bucket
, n
;
4011 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4014 for (bucket
= 0; bucket
< n
; ++bucket
)
4016 Lisp_Object idx
, next
, prev
;
4018 /* Follow collision chain, removing entries that
4019 don't survive this garbage collection. */
4021 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4023 ptrdiff_t i
= XFASTINT (idx
);
4024 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4025 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4028 if (EQ (h
->weak
, Qkey
))
4029 remove_p
= !key_known_to_survive_p
;
4030 else if (EQ (h
->weak
, Qvalue
))
4031 remove_p
= !value_known_to_survive_p
;
4032 else if (EQ (h
->weak
, Qkey_or_value
))
4033 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4034 else if (EQ (h
->weak
, Qkey_and_value
))
4035 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4039 next
= HASH_NEXT (h
, i
);
4041 if (remove_entries_p
)
4045 /* Take out of collision chain. */
4047 set_hash_index_slot (h
, bucket
, next
);
4049 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4051 /* Add to free list. */
4052 set_hash_next_slot (h
, i
, h
->next_free
);
4055 /* Clear key, value, and hash. */
4056 set_hash_key_slot (h
, i
, Qnil
);
4057 set_hash_value_slot (h
, i
, Qnil
);
4058 set_hash_hash_slot (h
, i
, Qnil
);
4071 /* Make sure key and value survive. */
4072 if (!key_known_to_survive_p
)
4074 mark_object (HASH_KEY (h
, i
));
4078 if (!value_known_to_survive_p
)
4080 mark_object (HASH_VALUE (h
, i
));
4091 /* Remove elements from weak hash tables that don't survive the
4092 current garbage collection. Remove weak tables that don't survive
4093 from Vweak_hash_tables. Called from gc_sweep. */
4095 NO_INLINE
/* For better stack traces */
4097 sweep_weak_hash_tables (void)
4099 struct Lisp_Hash_Table
*h
, *used
, *next
;
4102 /* Mark all keys and values that are in use. Keep on marking until
4103 there is no more change. This is necessary for cases like
4104 value-weak table A containing an entry X -> Y, where Y is used in a
4105 key-weak table B, Z -> Y. If B comes after A in the list of weak
4106 tables, X -> Y might be removed from A, although when looking at B
4107 one finds that it shouldn't. */
4111 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4113 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4114 marked
|= sweep_weak_table (h
, 0);
4119 /* Remove tables and entries that aren't used. */
4120 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4122 next
= h
->next_weak
;
4124 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4126 /* TABLE is marked as used. Sweep its contents. */
4128 sweep_weak_table (h
, 1);
4130 /* Add table to the list of used weak hash tables. */
4131 h
->next_weak
= used
;
4136 weak_hash_tables
= used
;
4141 /***********************************************************************
4142 Hash Code Computation
4143 ***********************************************************************/
4145 /* Maximum depth up to which to dive into Lisp structures. */
4147 #define SXHASH_MAX_DEPTH 3
4149 /* Maximum length up to which to take list and vector elements into
4152 #define SXHASH_MAX_LEN 7
4154 /* Return a hash for string PTR which has length LEN. The hash value
4155 can be any EMACS_UINT value. */
4158 hash_string (char const *ptr
, ptrdiff_t len
)
4160 char const *p
= ptr
;
4161 char const *end
= p
+ len
;
4163 EMACS_UINT hash
= 0;
4168 hash
= sxhash_combine (hash
, c
);
4174 /* Return a hash for string PTR which has length LEN. The hash
4175 code returned is guaranteed to fit in a Lisp integer. */
4178 sxhash_string (char const *ptr
, ptrdiff_t len
)
4180 EMACS_UINT hash
= hash_string (ptr
, len
);
4181 return SXHASH_REDUCE (hash
);
4184 /* Return a hash for the floating point value VAL. */
4187 sxhash_float (double val
)
4189 EMACS_UINT hash
= 0;
4191 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4192 + (sizeof val
% sizeof hash
!= 0))
4196 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4200 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4201 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4202 hash
= sxhash_combine (hash
, u
.word
[i
]);
4203 return SXHASH_REDUCE (hash
);
4206 /* Return a hash for list LIST. DEPTH is the current depth in the
4207 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4210 sxhash_list (Lisp_Object list
, int depth
)
4212 EMACS_UINT hash
= 0;
4215 if (depth
< SXHASH_MAX_DEPTH
)
4217 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4218 list
= XCDR (list
), ++i
)
4220 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4221 hash
= sxhash_combine (hash
, hash2
);
4226 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4227 hash
= sxhash_combine (hash
, hash2
);
4230 return SXHASH_REDUCE (hash
);
4234 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4235 the Lisp structure. */
4238 sxhash_vector (Lisp_Object vec
, int depth
)
4240 EMACS_UINT hash
= ASIZE (vec
);
4243 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4244 for (i
= 0; i
< n
; ++i
)
4246 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4247 hash
= sxhash_combine (hash
, hash2
);
4250 return SXHASH_REDUCE (hash
);
4253 /* Return a hash for bool-vector VECTOR. */
4256 sxhash_bool_vector (Lisp_Object vec
)
4258 EMACS_INT size
= bool_vector_size (vec
);
4259 EMACS_UINT hash
= size
;
4262 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4263 for (i
= 0; i
< n
; ++i
)
4264 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4266 return SXHASH_REDUCE (hash
);
4270 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4271 structure. Value is an unsigned integer clipped to INTMASK. */
4274 sxhash (Lisp_Object obj
, int depth
)
4278 if (depth
> SXHASH_MAX_DEPTH
)
4281 switch (XTYPE (obj
))
4292 obj
= SYMBOL_NAME (obj
);
4296 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4299 /* This can be everything from a vector to an overlay. */
4300 case Lisp_Vectorlike
:
4302 /* According to the CL HyperSpec, two arrays are equal only if
4303 they are `eq', except for strings and bit-vectors. In
4304 Emacs, this works differently. We have to compare element
4306 hash
= sxhash_vector (obj
, depth
);
4307 else if (BOOL_VECTOR_P (obj
))
4308 hash
= sxhash_bool_vector (obj
);
4310 /* Others are `equal' if they are `eq', so let's take their
4316 hash
= sxhash_list (obj
, depth
);
4320 hash
= sxhash_float (XFLOAT_DATA (obj
));
4332 /***********************************************************************
4334 ***********************************************************************/
4337 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4338 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4341 EMACS_UINT hash
= sxhash (obj
, 0);
4342 return make_number (hash
);
4346 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4347 doc
: /* Create and return a new hash table.
4349 Arguments are specified as keyword/argument pairs. The following
4350 arguments are defined:
4352 :test TEST -- TEST must be a symbol that specifies how to compare
4353 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4354 `equal'. User-supplied test and hash functions can be specified via
4355 `define-hash-table-test'.
4357 :size SIZE -- A hint as to how many elements will be put in the table.
4360 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4361 fills up. If REHASH-SIZE is an integer, increase the size by that
4362 amount. If it is a float, it must be > 1.0, and the new size is the
4363 old size multiplied by that factor. Default is 1.5.
4365 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4366 Resize the hash table when the ratio (number of entries / table size)
4367 is greater than or equal to THRESHOLD. Default is 0.8.
4369 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4370 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4371 returned is a weak table. Key/value pairs are removed from a weak
4372 hash table when there are no non-weak references pointing to their
4373 key, value, one of key or value, or both key and value, depending on
4374 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4377 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4378 (ptrdiff_t nargs
, Lisp_Object
*args
)
4380 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4381 struct hash_table_test testdesc
;
4385 /* The vector `used' is used to keep track of arguments that
4386 have been consumed. */
4387 used
= alloca (nargs
* sizeof *used
);
4388 memset (used
, 0, nargs
* sizeof *used
);
4390 /* See if there's a `:test TEST' among the arguments. */
4391 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4392 test
= i
? args
[i
] : Qeql
;
4394 testdesc
= hashtest_eq
;
4395 else if (EQ (test
, Qeql
))
4396 testdesc
= hashtest_eql
;
4397 else if (EQ (test
, Qequal
))
4398 testdesc
= hashtest_equal
;
4401 /* See if it is a user-defined test. */
4404 prop
= Fget (test
, Qhash_table_test
);
4405 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4406 signal_error ("Invalid hash table test", test
);
4407 testdesc
.name
= test
;
4408 testdesc
.user_cmp_function
= XCAR (prop
);
4409 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4410 testdesc
.hashfn
= hashfn_user_defined
;
4411 testdesc
.cmpfn
= cmpfn_user_defined
;
4414 /* See if there's a `:size SIZE' argument. */
4415 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4416 size
= i
? args
[i
] : Qnil
;
4418 size
= make_number (DEFAULT_HASH_SIZE
);
4419 else if (!INTEGERP (size
) || XINT (size
) < 0)
4420 signal_error ("Invalid hash table size", size
);
4422 /* Look for `:rehash-size SIZE'. */
4423 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4424 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4425 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4426 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4427 signal_error ("Invalid hash table rehash size", rehash_size
);
4429 /* Look for `:rehash-threshold THRESHOLD'. */
4430 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4431 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4432 if (! (FLOATP (rehash_threshold
)
4433 && 0 < XFLOAT_DATA (rehash_threshold
)
4434 && XFLOAT_DATA (rehash_threshold
) <= 1))
4435 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4437 /* Look for `:weakness WEAK'. */
4438 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4439 weak
= i
? args
[i
] : Qnil
;
4441 weak
= Qkey_and_value
;
4444 && !EQ (weak
, Qvalue
)
4445 && !EQ (weak
, Qkey_or_value
)
4446 && !EQ (weak
, Qkey_and_value
))
4447 signal_error ("Invalid hash table weakness", weak
);
4449 /* Now, all args should have been used up, or there's a problem. */
4450 for (i
= 0; i
< nargs
; ++i
)
4452 signal_error ("Invalid argument list", args
[i
]);
4454 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4458 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4459 doc
: /* Return a copy of hash table TABLE. */)
4462 return copy_hash_table (check_hash_table (table
));
4466 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4467 doc
: /* Return the number of elements in TABLE. */)
4470 return make_number (check_hash_table (table
)->count
);
4474 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4475 Shash_table_rehash_size
, 1, 1, 0,
4476 doc
: /* Return the current rehash size of TABLE. */)
4479 return check_hash_table (table
)->rehash_size
;
4483 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4484 Shash_table_rehash_threshold
, 1, 1, 0,
4485 doc
: /* Return the current rehash threshold of TABLE. */)
4488 return check_hash_table (table
)->rehash_threshold
;
4492 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4493 doc
: /* Return the size of TABLE.
4494 The size can be used as an argument to `make-hash-table' to create
4495 a hash table than can hold as many elements as TABLE holds
4496 without need for resizing. */)
4499 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4500 return make_number (HASH_TABLE_SIZE (h
));
4504 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4505 doc
: /* Return the test TABLE uses. */)
4508 return check_hash_table (table
)->test
.name
;
4512 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4514 doc
: /* Return the weakness of TABLE. */)
4517 return check_hash_table (table
)->weak
;
4521 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4522 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4525 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4529 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4530 doc
: /* Clear hash table TABLE and return it. */)
4533 hash_clear (check_hash_table (table
));
4534 /* Be compatible with XEmacs. */
4539 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4540 doc
: /* Look up KEY in TABLE and return its associated value.
4541 If KEY is not found, return DFLT which defaults to nil. */)
4542 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4544 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4545 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4546 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4550 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4551 doc
: /* Associate KEY with VALUE in hash table TABLE.
4552 If KEY is already present in table, replace its current value with
4553 VALUE. In any case, return VALUE. */)
4554 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4556 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4560 i
= hash_lookup (h
, key
, &hash
);
4562 set_hash_value_slot (h
, i
, value
);
4564 hash_put (h
, key
, value
, hash
);
4570 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4571 doc
: /* Remove KEY from TABLE. */)
4572 (Lisp_Object key
, Lisp_Object table
)
4574 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4575 hash_remove_from_table (h
, key
);
4580 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4581 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4582 FUNCTION is called with two arguments, KEY and VALUE.
4583 `maphash' always returns nil. */)
4584 (Lisp_Object function
, Lisp_Object table
)
4586 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4587 Lisp_Object args
[3];
4590 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4591 if (!NILP (HASH_HASH (h
, i
)))
4594 args
[1] = HASH_KEY (h
, i
);
4595 args
[2] = HASH_VALUE (h
, i
);
4603 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4604 Sdefine_hash_table_test
, 3, 3, 0,
4605 doc
: /* Define a new hash table test with name NAME, a symbol.
4607 In hash tables created with NAME specified as test, use TEST to
4608 compare keys, and HASH for computing hash codes of keys.
4610 TEST must be a function taking two arguments and returning non-nil if
4611 both arguments are the same. HASH must be a function taking one
4612 argument and returning an object that is the hash code of the argument.
4613 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4614 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4615 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4617 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4622 /************************************************************************
4623 MD5, SHA-1, and SHA-2
4624 ************************************************************************/
4631 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4634 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4635 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4639 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4640 register EMACS_INT b
, e
;
4641 register struct buffer
*bp
;
4644 void *(*hash_func
) (const char *, size_t, void *);
4647 CHECK_SYMBOL (algorithm
);
4649 if (STRINGP (object
))
4651 if (NILP (coding_system
))
4653 /* Decide the coding-system to encode the data with. */
4655 if (STRING_MULTIBYTE (object
))
4656 /* use default, we can't guess correct value */
4657 coding_system
= preferred_coding_system ();
4659 coding_system
= Qraw_text
;
4662 if (NILP (Fcoding_system_p (coding_system
)))
4664 /* Invalid coding system. */
4666 if (!NILP (noerror
))
4667 coding_system
= Qraw_text
;
4669 xsignal1 (Qcoding_system_error
, coding_system
);
4672 if (STRING_MULTIBYTE (object
))
4673 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4675 size
= SCHARS (object
);
4676 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4678 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4679 end_byte
= (end_char
== size
4681 : string_char_to_byte (object
, end_char
));
4685 struct buffer
*prev
= current_buffer
;
4687 record_unwind_current_buffer ();
4689 CHECK_BUFFER (object
);
4691 bp
= XBUFFER (object
);
4692 set_buffer_internal (bp
);
4698 CHECK_NUMBER_COERCE_MARKER (start
);
4706 CHECK_NUMBER_COERCE_MARKER (end
);
4711 temp
= b
, b
= e
, e
= temp
;
4713 if (!(BEGV
<= b
&& e
<= ZV
))
4714 args_out_of_range (start
, end
);
4716 if (NILP (coding_system
))
4718 /* Decide the coding-system to encode the data with.
4719 See fileio.c:Fwrite-region */
4721 if (!NILP (Vcoding_system_for_write
))
4722 coding_system
= Vcoding_system_for_write
;
4725 bool force_raw_text
= 0;
4727 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4728 if (NILP (coding_system
)
4729 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4731 coding_system
= Qnil
;
4732 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4736 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4738 /* Check file-coding-system-alist. */
4739 Lisp_Object args
[4], val
;
4741 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4742 args
[3] = Fbuffer_file_name (object
);
4743 val
= Ffind_operation_coding_system (4, args
);
4744 if (CONSP (val
) && !NILP (XCDR (val
)))
4745 coding_system
= XCDR (val
);
4748 if (NILP (coding_system
)
4749 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4751 /* If we still have not decided a coding system, use the
4752 default value of buffer-file-coding-system. */
4753 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4757 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4758 /* Confirm that VAL can surely encode the current region. */
4759 coding_system
= call4 (Vselect_safe_coding_system_function
,
4760 make_number (b
), make_number (e
),
4761 coding_system
, Qnil
);
4764 coding_system
= Qraw_text
;
4767 if (NILP (Fcoding_system_p (coding_system
)))
4769 /* Invalid coding system. */
4771 if (!NILP (noerror
))
4772 coding_system
= Qraw_text
;
4774 xsignal1 (Qcoding_system_error
, coding_system
);
4778 object
= make_buffer_string (b
, e
, 0);
4779 set_buffer_internal (prev
);
4780 /* Discard the unwind protect for recovering the current
4784 if (STRING_MULTIBYTE (object
))
4785 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4787 end_byte
= SBYTES (object
);
4790 if (EQ (algorithm
, Qmd5
))
4792 digest_size
= MD5_DIGEST_SIZE
;
4793 hash_func
= md5_buffer
;
4795 else if (EQ (algorithm
, Qsha1
))
4797 digest_size
= SHA1_DIGEST_SIZE
;
4798 hash_func
= sha1_buffer
;
4800 else if (EQ (algorithm
, Qsha224
))
4802 digest_size
= SHA224_DIGEST_SIZE
;
4803 hash_func
= sha224_buffer
;
4805 else if (EQ (algorithm
, Qsha256
))
4807 digest_size
= SHA256_DIGEST_SIZE
;
4808 hash_func
= sha256_buffer
;
4810 else if (EQ (algorithm
, Qsha384
))
4812 digest_size
= SHA384_DIGEST_SIZE
;
4813 hash_func
= sha384_buffer
;
4815 else if (EQ (algorithm
, Qsha512
))
4817 digest_size
= SHA512_DIGEST_SIZE
;
4818 hash_func
= sha512_buffer
;
4821 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4823 /* allocate 2 x digest_size so that it can be re-used to hold the
4825 digest
= make_uninit_string (digest_size
* 2);
4827 hash_func (SSDATA (object
) + start_byte
,
4828 end_byte
- start_byte
,
4833 unsigned char *p
= SDATA (digest
);
4834 for (i
= digest_size
- 1; i
>= 0; i
--)
4836 static char const hexdigit
[16] = "0123456789abcdef";
4838 p
[2 * i
] = hexdigit
[p_i
>> 4];
4839 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4844 return make_unibyte_string (SSDATA (digest
), digest_size
);
4847 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4848 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4850 A message digest is a cryptographic checksum of a document, and the
4851 algorithm to calculate it is defined in RFC 1321.
4853 The two optional arguments START and END are character positions
4854 specifying for which part of OBJECT the message digest should be
4855 computed. If nil or omitted, the digest is computed for the whole
4858 The MD5 message digest is computed from the result of encoding the
4859 text in a coding system, not directly from the internal Emacs form of
4860 the text. The optional fourth argument CODING-SYSTEM specifies which
4861 coding system to encode the text with. It should be the same coding
4862 system that you used or will use when actually writing the text into a
4865 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4866 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4867 system would be chosen by default for writing this text into a file.
4869 If OBJECT is a string, the most preferred coding system (see the
4870 command `prefer-coding-system') is used.
4872 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4873 guesswork fails. Normally, an error is signaled in such case. */)
4874 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4876 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4879 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4880 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4881 ALGORITHM is a symbol specifying the hash to use:
4882 md5, sha1, sha224, sha256, sha384 or sha512.
4884 The two optional arguments START and END are positions specifying for
4885 which part of OBJECT to compute the hash. If nil or omitted, uses the
4888 If BINARY is non-nil, returns a string in binary form. */)
4889 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4891 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4897 DEFSYM (Qmd5
, "md5");
4898 DEFSYM (Qsha1
, "sha1");
4899 DEFSYM (Qsha224
, "sha224");
4900 DEFSYM (Qsha256
, "sha256");
4901 DEFSYM (Qsha384
, "sha384");
4902 DEFSYM (Qsha512
, "sha512");
4904 /* Hash table stuff. */
4905 DEFSYM (Qhash_table_p
, "hash-table-p");
4907 DEFSYM (Qeql
, "eql");
4908 DEFSYM (Qequal
, "equal");
4909 DEFSYM (QCtest
, ":test");
4910 DEFSYM (QCsize
, ":size");
4911 DEFSYM (QCrehash_size
, ":rehash-size");
4912 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4913 DEFSYM (QCweakness
, ":weakness");
4914 DEFSYM (Qkey
, "key");
4915 DEFSYM (Qvalue
, "value");
4916 DEFSYM (Qhash_table_test
, "hash-table-test");
4917 DEFSYM (Qkey_or_value
, "key-or-value");
4918 DEFSYM (Qkey_and_value
, "key-and-value");
4921 defsubr (&Smake_hash_table
);
4922 defsubr (&Scopy_hash_table
);
4923 defsubr (&Shash_table_count
);
4924 defsubr (&Shash_table_rehash_size
);
4925 defsubr (&Shash_table_rehash_threshold
);
4926 defsubr (&Shash_table_size
);
4927 defsubr (&Shash_table_test
);
4928 defsubr (&Shash_table_weakness
);
4929 defsubr (&Shash_table_p
);
4930 defsubr (&Sclrhash
);
4931 defsubr (&Sgethash
);
4932 defsubr (&Sputhash
);
4933 defsubr (&Sremhash
);
4934 defsubr (&Smaphash
);
4935 defsubr (&Sdefine_hash_table_test
);
4937 DEFSYM (Qstring_lessp
, "string-lessp");
4938 DEFSYM (Qprovide
, "provide");
4939 DEFSYM (Qrequire
, "require");
4940 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4941 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4942 DEFSYM (Qwidget_type
, "widget-type");
4944 staticpro (&string_char_byte_cache_string
);
4945 string_char_byte_cache_string
= Qnil
;
4947 require_nesting_list
= Qnil
;
4948 staticpro (&require_nesting_list
);
4950 Fset (Qyes_or_no_p_history
, Qnil
);
4952 DEFVAR_LISP ("features", Vfeatures
,
4953 doc
: /* A list of symbols which are the features of the executing Emacs.
4954 Used by `featurep' and `require', and altered by `provide'. */);
4955 Vfeatures
= list1 (intern_c_string ("emacs"));
4956 DEFSYM (Qsubfeatures
, "subfeatures");
4957 DEFSYM (Qfuncall
, "funcall");
4959 #ifdef HAVE_LANGINFO_CODESET
4960 DEFSYM (Qcodeset
, "codeset");
4961 DEFSYM (Qdays
, "days");
4962 DEFSYM (Qmonths
, "months");
4963 DEFSYM (Qpaper
, "paper");
4964 #endif /* HAVE_LANGINFO_CODESET */
4966 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4967 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4968 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4969 invoked by mouse clicks and mouse menu items.
4971 On some platforms, file selection dialogs are also enabled if this is
4975 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4976 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4977 This applies to commands from menus and tool bar buttons even when
4978 they are initiated from the keyboard. If `use-dialog-box' is nil,
4979 that disables the use of a file dialog, regardless of the value of
4981 use_file_dialog
= 1;
4983 defsubr (&Sidentity
);
4986 defsubr (&Ssafe_length
);
4987 defsubr (&Sstring_bytes
);
4988 defsubr (&Sstring_equal
);
4989 defsubr (&Scompare_strings
);
4990 defsubr (&Sstring_lessp
);
4993 defsubr (&Svconcat
);
4994 defsubr (&Scopy_sequence
);
4995 defsubr (&Sstring_make_multibyte
);
4996 defsubr (&Sstring_make_unibyte
);
4997 defsubr (&Sstring_as_multibyte
);
4998 defsubr (&Sstring_as_unibyte
);
4999 defsubr (&Sstring_to_multibyte
);
5000 defsubr (&Sstring_to_unibyte
);
5001 defsubr (&Scopy_alist
);
5002 defsubr (&Ssubstring
);
5003 defsubr (&Ssubstring_no_properties
);
5016 defsubr (&Snreverse
);
5017 defsubr (&Sreverse
);
5019 defsubr (&Splist_get
);
5021 defsubr (&Splist_put
);
5023 defsubr (&Slax_plist_get
);
5024 defsubr (&Slax_plist_put
);
5027 defsubr (&Sequal_including_properties
);
5028 defsubr (&Sfillarray
);
5029 defsubr (&Sclear_string
);
5033 defsubr (&Smapconcat
);
5034 defsubr (&Syes_or_no_p
);
5035 defsubr (&Sload_average
);
5036 defsubr (&Sfeaturep
);
5037 defsubr (&Srequire
);
5038 defsubr (&Sprovide
);
5039 defsubr (&Splist_member
);
5040 defsubr (&Swidget_put
);
5041 defsubr (&Swidget_get
);
5042 defsubr (&Swidget_apply
);
5043 defsubr (&Sbase64_encode_region
);
5044 defsubr (&Sbase64_decode_region
);
5045 defsubr (&Sbase64_encode_string
);
5046 defsubr (&Sbase64_decode_string
);
5048 defsubr (&Ssecure_hash
);
5049 defsubr (&Slocale_info
);
5051 hashtest_eq
.name
= Qeq
;
5052 hashtest_eq
.user_hash_function
= Qnil
;
5053 hashtest_eq
.user_cmp_function
= Qnil
;
5054 hashtest_eq
.cmpfn
= 0;
5055 hashtest_eq
.hashfn
= hashfn_eq
;
5057 hashtest_eql
.name
= Qeql
;
5058 hashtest_eql
.user_hash_function
= Qnil
;
5059 hashtest_eql
.user_cmp_function
= Qnil
;
5060 hashtest_eql
.cmpfn
= cmpfn_eql
;
5061 hashtest_eql
.hashfn
= hashfn_eql
;
5063 hashtest_equal
.name
= Qequal
;
5064 hashtest_equal
.user_hash_function
= Qnil
;
5065 hashtest_equal
.user_cmp_function
= Qnil
;
5066 hashtest_equal
.cmpfn
= cmpfn_equal
;
5067 hashtest_equal
.hashfn
= hashfn_equal
;