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 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
272 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
277 if (! NILP (ignore_case
))
279 c1
= XINT (Fupcase (make_number (c1
)));
280 c2
= XINT (Fupcase (make_number (c2
)));
286 /* Note that I1 has already been incremented
287 past the character that we are comparing;
288 hence we don't add or subtract 1 here. */
290 return make_number (- i1
+ from1
);
292 return make_number (i1
- from1
);
296 return make_number (i1
- from1
+ 1);
298 return make_number (- i1
+ from1
- 1);
303 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
304 doc
: /* Return t if first arg string is less than second in lexicographic order.
306 Symbols are also allowed; their print names are used instead. */)
307 (register Lisp_Object s1
, Lisp_Object s2
)
309 register ptrdiff_t end
;
310 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
313 s1
= SYMBOL_NAME (s1
);
315 s2
= SYMBOL_NAME (s2
);
319 i1
= i1_byte
= i2
= i2_byte
= 0;
322 if (end
> SCHARS (s2
))
327 /* When we find a mismatch, we must compare the
328 characters, not just the bytes. */
331 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
332 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
335 return c1
< c2
? Qt
: Qnil
;
337 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
340 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
341 enum Lisp_Type target_type
, bool last_special
);
345 concat2 (Lisp_Object s1
, Lisp_Object s2
)
350 return concat (2, args
, Lisp_String
, 0);
355 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
361 return concat (3, args
, Lisp_String
, 0);
364 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
365 doc
: /* Concatenate all the arguments and make the result a list.
366 The result is a list whose elements are the elements of all the arguments.
367 Each argument may be a list, vector or string.
368 The last argument is not copied, just used as the tail of the new list.
369 usage: (append &rest SEQUENCES) */)
370 (ptrdiff_t nargs
, Lisp_Object
*args
)
372 return concat (nargs
, args
, Lisp_Cons
, 1);
375 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
376 doc
: /* Concatenate all the arguments and make the result a string.
377 The result is a string whose elements are the elements of all the arguments.
378 Each argument may be a string or a list or vector of characters (integers).
379 usage: (concat &rest SEQUENCES) */)
380 (ptrdiff_t nargs
, Lisp_Object
*args
)
382 return concat (nargs
, args
, Lisp_String
, 0);
385 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
386 doc
: /* Concatenate all the arguments and make the result a vector.
387 The result is a vector whose elements are the elements of all the arguments.
388 Each argument may be a list, vector or string.
389 usage: (vconcat &rest SEQUENCES) */)
390 (ptrdiff_t nargs
, Lisp_Object
*args
)
392 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
396 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
397 doc
: /* Return a copy of a list, vector, string or char-table.
398 The elements of a list or vector are not copied; they are shared
399 with the original. */)
402 if (NILP (arg
)) return arg
;
404 if (CHAR_TABLE_P (arg
))
406 return copy_char_table (arg
);
409 if (BOOL_VECTOR_P (arg
))
411 EMACS_INT nbits
= bool_vector_size (arg
);
412 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
413 Lisp_Object val
= make_uninit_bool_vector (nbits
);
414 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
418 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
419 wrong_type_argument (Qsequencep
, arg
);
421 return concat (1, &arg
, XTYPE (arg
), 0);
424 /* This structure holds information of an argument of `concat' that is
425 a string and has text properties to be copied. */
428 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
429 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
430 ptrdiff_t to
; /* refer to VAL (the target string) */
434 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
435 enum Lisp_Type target_type
, bool last_special
)
441 ptrdiff_t toindex_byte
= 0;
442 EMACS_INT result_len
;
443 EMACS_INT result_len_byte
;
445 Lisp_Object last_tail
;
448 /* When we make a multibyte string, we can't copy text properties
449 while concatenating each string because the length of resulting
450 string can't be decided until we finish the whole concatenation.
451 So, we record strings that have text properties to be copied
452 here, and copy the text properties after the concatenation. */
453 struct textprop_rec
*textprops
= NULL
;
454 /* Number of elements in textprops. */
455 ptrdiff_t num_textprops
= 0;
460 /* In append, the last arg isn't treated like the others */
461 if (last_special
&& nargs
> 0)
464 last_tail
= args
[nargs
];
469 /* Check each argument. */
470 for (argnum
= 0; argnum
< nargs
; argnum
++)
473 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
474 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
475 wrong_type_argument (Qsequencep
, this);
478 /* Compute total length in chars of arguments in RESULT_LEN.
479 If desired output is a string, also compute length in bytes
480 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
481 whether the result should be a multibyte string. */
485 for (argnum
= 0; argnum
< nargs
; argnum
++)
489 len
= XFASTINT (Flength (this));
490 if (target_type
== Lisp_String
)
492 /* We must count the number of bytes needed in the string
493 as well as the number of characters. */
497 ptrdiff_t this_len_byte
;
499 if (VECTORP (this) || COMPILEDP (this))
500 for (i
= 0; i
< len
; i
++)
503 CHECK_CHARACTER (ch
);
505 this_len_byte
= CHAR_BYTES (c
);
506 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
508 result_len_byte
+= this_len_byte
;
509 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
512 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
513 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
514 else if (CONSP (this))
515 for (; CONSP (this); this = XCDR (this))
518 CHECK_CHARACTER (ch
);
520 this_len_byte
= CHAR_BYTES (c
);
521 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
523 result_len_byte
+= this_len_byte
;
524 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
527 else if (STRINGP (this))
529 if (STRING_MULTIBYTE (this))
532 this_len_byte
= SBYTES (this);
535 this_len_byte
= count_size_as_multibyte (SDATA (this),
537 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
539 result_len_byte
+= this_len_byte
;
544 if (MOST_POSITIVE_FIXNUM
< result_len
)
545 memory_full (SIZE_MAX
);
548 if (! some_multibyte
)
549 result_len_byte
= result_len
;
551 /* Create the output object. */
552 if (target_type
== Lisp_Cons
)
553 val
= Fmake_list (make_number (result_len
), Qnil
);
554 else if (target_type
== Lisp_Vectorlike
)
555 val
= Fmake_vector (make_number (result_len
), Qnil
);
556 else if (some_multibyte
)
557 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
559 val
= make_uninit_string (result_len
);
561 /* In `append', if all but last arg are nil, return last arg. */
562 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
565 /* Copy the contents of the args into the result. */
567 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
569 toindex
= 0, toindex_byte
= 0;
573 SAFE_NALLOCA (textprops
, 1, nargs
);
575 for (argnum
= 0; argnum
< nargs
; argnum
++)
578 ptrdiff_t thisleni
= 0;
579 register ptrdiff_t thisindex
= 0;
580 register ptrdiff_t thisindex_byte
= 0;
584 thislen
= Flength (this), thisleni
= XINT (thislen
);
586 /* Between strings of the same kind, copy fast. */
587 if (STRINGP (this) && STRINGP (val
)
588 && STRING_MULTIBYTE (this) == some_multibyte
)
590 ptrdiff_t thislen_byte
= SBYTES (this);
592 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
593 if (string_intervals (this))
595 textprops
[num_textprops
].argnum
= argnum
;
596 textprops
[num_textprops
].from
= 0;
597 textprops
[num_textprops
++].to
= toindex
;
599 toindex_byte
+= thislen_byte
;
602 /* Copy a single-byte string to a multibyte string. */
603 else if (STRINGP (this) && STRINGP (val
))
605 if (string_intervals (this))
607 textprops
[num_textprops
].argnum
= argnum
;
608 textprops
[num_textprops
].from
= 0;
609 textprops
[num_textprops
++].to
= toindex
;
611 toindex_byte
+= copy_text (SDATA (this),
612 SDATA (val
) + toindex_byte
,
613 SCHARS (this), 0, 1);
617 /* Copy element by element. */
620 register Lisp_Object elt
;
622 /* Fetch next element of `this' arg into `elt', or break if
623 `this' is exhausted. */
624 if (NILP (this)) break;
626 elt
= XCAR (this), this = XCDR (this);
627 else if (thisindex
>= thisleni
)
629 else if (STRINGP (this))
632 if (STRING_MULTIBYTE (this))
633 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
638 c
= SREF (this, thisindex
); thisindex
++;
639 if (some_multibyte
&& !ASCII_CHAR_P (c
))
640 c
= BYTE8_TO_CHAR (c
);
642 XSETFASTINT (elt
, c
);
644 else if (BOOL_VECTOR_P (this))
646 elt
= bool_vector_ref (this, thisindex
);
651 elt
= AREF (this, thisindex
);
655 /* Store this element into the result. */
662 else if (VECTORP (val
))
664 ASET (val
, toindex
, elt
);
670 CHECK_CHARACTER (elt
);
673 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
675 SSET (val
, toindex_byte
++, c
);
681 XSETCDR (prev
, last_tail
);
683 if (num_textprops
> 0)
686 ptrdiff_t last_to_end
= -1;
688 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
690 this = args
[textprops
[argnum
].argnum
];
691 props
= text_property_list (this,
693 make_number (SCHARS (this)),
695 /* If successive arguments have properties, be sure that the
696 value of `composition' property be the copy. */
697 if (last_to_end
== textprops
[argnum
].to
)
698 make_composition_value_copy (props
);
699 add_text_properties_from_list (val
, props
,
700 make_number (textprops
[argnum
].to
));
701 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
709 static Lisp_Object string_char_byte_cache_string
;
710 static ptrdiff_t string_char_byte_cache_charpos
;
711 static ptrdiff_t string_char_byte_cache_bytepos
;
714 clear_string_char_byte_cache (void)
716 string_char_byte_cache_string
= Qnil
;
719 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
722 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
725 ptrdiff_t best_below
, best_below_byte
;
726 ptrdiff_t best_above
, best_above_byte
;
728 best_below
= best_below_byte
= 0;
729 best_above
= SCHARS (string
);
730 best_above_byte
= SBYTES (string
);
731 if (best_above
== best_above_byte
)
734 if (EQ (string
, string_char_byte_cache_string
))
736 if (string_char_byte_cache_charpos
< char_index
)
738 best_below
= string_char_byte_cache_charpos
;
739 best_below_byte
= string_char_byte_cache_bytepos
;
743 best_above
= string_char_byte_cache_charpos
;
744 best_above_byte
= string_char_byte_cache_bytepos
;
748 if (char_index
- best_below
< best_above
- char_index
)
750 unsigned char *p
= SDATA (string
) + best_below_byte
;
752 while (best_below
< char_index
)
754 p
+= BYTES_BY_CHAR_HEAD (*p
);
757 i_byte
= p
- SDATA (string
);
761 unsigned char *p
= SDATA (string
) + best_above_byte
;
763 while (best_above
> char_index
)
766 while (!CHAR_HEAD_P (*p
)) p
--;
769 i_byte
= p
- SDATA (string
);
772 string_char_byte_cache_bytepos
= i_byte
;
773 string_char_byte_cache_charpos
= char_index
;
774 string_char_byte_cache_string
= string
;
779 /* Return the character index corresponding to BYTE_INDEX in STRING. */
782 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
785 ptrdiff_t best_below
, best_below_byte
;
786 ptrdiff_t best_above
, best_above_byte
;
788 best_below
= best_below_byte
= 0;
789 best_above
= SCHARS (string
);
790 best_above_byte
= SBYTES (string
);
791 if (best_above
== best_above_byte
)
794 if (EQ (string
, string_char_byte_cache_string
))
796 if (string_char_byte_cache_bytepos
< byte_index
)
798 best_below
= string_char_byte_cache_charpos
;
799 best_below_byte
= string_char_byte_cache_bytepos
;
803 best_above
= string_char_byte_cache_charpos
;
804 best_above_byte
= string_char_byte_cache_bytepos
;
808 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
810 unsigned char *p
= SDATA (string
) + best_below_byte
;
811 unsigned char *pend
= SDATA (string
) + byte_index
;
815 p
+= BYTES_BY_CHAR_HEAD (*p
);
819 i_byte
= p
- SDATA (string
);
823 unsigned char *p
= SDATA (string
) + best_above_byte
;
824 unsigned char *pbeg
= SDATA (string
) + byte_index
;
829 while (!CHAR_HEAD_P (*p
)) p
--;
833 i_byte
= p
- SDATA (string
);
836 string_char_byte_cache_bytepos
= i_byte
;
837 string_char_byte_cache_charpos
= i
;
838 string_char_byte_cache_string
= string
;
843 /* Convert STRING to a multibyte string. */
846 string_make_multibyte (Lisp_Object string
)
853 if (STRING_MULTIBYTE (string
))
856 nbytes
= count_size_as_multibyte (SDATA (string
),
858 /* If all the chars are ASCII, they won't need any more bytes
859 once converted. In that case, we can return STRING itself. */
860 if (nbytes
== SBYTES (string
))
863 buf
= SAFE_ALLOCA (nbytes
);
864 copy_text (SDATA (string
), buf
, SBYTES (string
),
867 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
874 /* Convert STRING (if unibyte) to a multibyte string without changing
875 the number of characters. Characters 0200 trough 0237 are
876 converted to eight-bit characters. */
879 string_to_multibyte (Lisp_Object string
)
886 if (STRING_MULTIBYTE (string
))
889 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
890 /* If all the chars are ASCII, they won't need any more bytes once
892 if (nbytes
== SBYTES (string
))
893 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
895 buf
= SAFE_ALLOCA (nbytes
);
896 memcpy (buf
, SDATA (string
), SBYTES (string
));
897 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
899 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
906 /* Convert STRING to a single-byte string. */
909 string_make_unibyte (Lisp_Object string
)
916 if (! STRING_MULTIBYTE (string
))
919 nchars
= SCHARS (string
);
921 buf
= SAFE_ALLOCA (nchars
);
922 copy_text (SDATA (string
), buf
, SBYTES (string
),
925 ret
= make_unibyte_string ((char *) buf
, nchars
);
931 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
933 doc
: /* Return the multibyte equivalent of STRING.
934 If STRING is unibyte and contains non-ASCII characters, the function
935 `unibyte-char-to-multibyte' is used to convert each unibyte character
936 to a multibyte character. In this case, the returned string is a
937 newly created string with no text properties. If STRING is multibyte
938 or entirely ASCII, it is returned unchanged. In particular, when
939 STRING is unibyte and entirely ASCII, the returned string is unibyte.
940 \(When the characters are all ASCII, Emacs primitives will treat the
941 string the same way whether it is unibyte or multibyte.) */)
944 CHECK_STRING (string
);
946 return string_make_multibyte (string
);
949 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
951 doc
: /* Return the unibyte equivalent of STRING.
952 Multibyte character codes are converted to unibyte according to
953 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
954 If the lookup in the translation table fails, this function takes just
955 the low 8 bits of each character. */)
958 CHECK_STRING (string
);
960 return string_make_unibyte (string
);
963 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
965 doc
: /* Return a unibyte string with the same individual bytes as STRING.
966 If STRING is unibyte, the result is STRING itself.
967 Otherwise it is a newly created string, with no text properties.
968 If STRING is multibyte and contains a character of charset
969 `eight-bit', it is converted to the corresponding single byte. */)
972 CHECK_STRING (string
);
974 if (STRING_MULTIBYTE (string
))
976 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
977 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
979 string
= make_unibyte_string ((char *) str
, bytes
);
985 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
987 doc
: /* Return a multibyte string with the same individual bytes as STRING.
988 If STRING is multibyte, the result is STRING itself.
989 Otherwise it is a newly created string, with no text properties.
991 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
992 part of a correct utf-8 sequence), it is converted to the corresponding
993 multibyte character of charset `eight-bit'.
994 See also `string-to-multibyte'.
996 Beware, this often doesn't really do what you think it does.
997 It is similar to (decode-coding-string STRING 'utf-8-emacs).
998 If you're not sure, whether to use `string-as-multibyte' or
999 `string-to-multibyte', use `string-to-multibyte'. */)
1000 (Lisp_Object string
)
1002 CHECK_STRING (string
);
1004 if (! STRING_MULTIBYTE (string
))
1006 Lisp_Object new_string
;
1007 ptrdiff_t nchars
, nbytes
;
1009 parse_str_as_multibyte (SDATA (string
),
1012 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1013 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1014 if (nbytes
!= SBYTES (string
))
1015 str_as_multibyte (SDATA (new_string
), nbytes
,
1016 SBYTES (string
), NULL
);
1017 string
= new_string
;
1018 set_string_intervals (string
, NULL
);
1023 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1025 doc
: /* Return a multibyte string with the same individual chars as STRING.
1026 If STRING is multibyte, the result is STRING itself.
1027 Otherwise it is a newly created string, with no text properties.
1029 If STRING is unibyte and contains an 8-bit byte, it is converted to
1030 the corresponding multibyte character of charset `eight-bit'.
1032 This differs from `string-as-multibyte' by converting each byte of a correct
1033 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1034 correct sequence. */)
1035 (Lisp_Object string
)
1037 CHECK_STRING (string
);
1039 return string_to_multibyte (string
);
1042 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1044 doc
: /* Return a unibyte string with the same individual chars as STRING.
1045 If STRING is unibyte, the result is STRING itself.
1046 Otherwise it is a newly created string, with no text properties,
1047 where each `eight-bit' character is converted to the corresponding byte.
1048 If STRING contains a non-ASCII, non-`eight-bit' character,
1049 an error is signaled. */)
1050 (Lisp_Object string
)
1052 CHECK_STRING (string
);
1054 if (STRING_MULTIBYTE (string
))
1056 ptrdiff_t chars
= SCHARS (string
);
1057 unsigned char *str
= xmalloc (chars
);
1058 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1060 if (converted
< chars
)
1061 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1062 string
= make_unibyte_string ((char *) str
, chars
);
1069 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1070 doc
: /* Return a copy of ALIST.
1071 This is an alist which represents the same mapping from objects to objects,
1072 but does not share the alist structure with ALIST.
1073 The objects mapped (cars and cdrs of elements of the alist)
1074 are shared, however.
1075 Elements of ALIST that are not conses are also shared. */)
1078 register Lisp_Object tem
;
1083 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1084 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1086 register Lisp_Object car
;
1090 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1095 /* Check that ARRAY can have a valid subarray [FROM..TO),
1096 given that its size is SIZE.
1097 If FROM is nil, use 0; if TO is nil, use SIZE.
1098 Count negative values backwards from the end.
1099 Set *IFROM and *ITO to the two indexes used. */
1102 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1103 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1107 if (INTEGERP (from
))
1113 else if (NILP (from
))
1116 wrong_type_argument (Qintegerp
, from
);
1127 wrong_type_argument (Qintegerp
, to
);
1129 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1130 args_out_of_range_3 (array
, from
, to
);
1136 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1137 doc
: /* Return a new string whose contents are a substring of STRING.
1138 The returned string consists of the characters between index FROM
1139 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1140 zero-indexed: 0 means the first character of STRING. Negative values
1141 are counted from the end of STRING. If TO is nil, the substring runs
1142 to the end of STRING.
1144 The STRING argument may also be a vector. In that case, the return
1145 value is a new vector that contains the elements between index FROM
1146 \(inclusive) and index TO (exclusive) of that vector argument.
1148 With one argument, just copy STRING (with properties, if any). */)
1149 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1152 ptrdiff_t size
, ifrom
, ito
;
1154 size
= CHECK_VECTOR_OR_STRING (string
);
1155 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1157 if (STRINGP (string
))
1160 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1162 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1163 res
= make_specified_string (SSDATA (string
) + from_byte
,
1164 ito
- ifrom
, to_byte
- from_byte
,
1165 STRING_MULTIBYTE (string
));
1166 copy_text_properties (make_number (ifrom
), make_number (ito
),
1167 string
, make_number (0), res
, Qnil
);
1170 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1176 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1177 doc
: /* Return a substring of STRING, without text properties.
1178 It starts at index FROM and ends before TO.
1179 TO may be nil or omitted; then the substring runs to the end of STRING.
1180 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1181 If FROM or TO is negative, it counts from the end.
1183 With one argument, just copy STRING without its properties. */)
1184 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1186 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1188 CHECK_STRING (string
);
1190 size
= SCHARS (string
);
1191 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1193 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1195 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1196 return make_specified_string (SSDATA (string
) + from_byte
,
1197 to_char
- from_char
, to_byte
- from_byte
,
1198 STRING_MULTIBYTE (string
));
1201 /* Extract a substring of STRING, giving start and end positions
1202 both in characters and in bytes. */
1205 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1206 ptrdiff_t to
, ptrdiff_t to_byte
)
1209 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1211 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1212 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1214 if (STRINGP (string
))
1216 res
= make_specified_string (SSDATA (string
) + from_byte
,
1217 to
- from
, to_byte
- from_byte
,
1218 STRING_MULTIBYTE (string
));
1219 copy_text_properties (make_number (from
), make_number (to
),
1220 string
, make_number (0), res
, Qnil
);
1223 res
= Fvector (to
- from
, aref_addr (string
, from
));
1228 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1229 doc
: /* Take cdr N times on LIST, return the result. */)
1230 (Lisp_Object n
, Lisp_Object list
)
1235 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1238 CHECK_LIST_CONS (list
, list
);
1244 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1245 doc
: /* Return the Nth element of LIST.
1246 N counts from zero. If LIST is not that long, nil is returned. */)
1247 (Lisp_Object n
, Lisp_Object list
)
1249 return Fcar (Fnthcdr (n
, list
));
1252 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1253 doc
: /* Return element of SEQUENCE at index N. */)
1254 (register Lisp_Object sequence
, Lisp_Object n
)
1257 if (CONSP (sequence
) || NILP (sequence
))
1258 return Fcar (Fnthcdr (n
, sequence
));
1260 /* Faref signals a "not array" error, so check here. */
1261 CHECK_ARRAY (sequence
, Qsequencep
);
1262 return Faref (sequence
, n
);
1265 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1266 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1267 The value is actually the tail of LIST whose car is ELT. */)
1268 (register Lisp_Object elt
, Lisp_Object list
)
1270 register Lisp_Object tail
;
1271 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1273 register Lisp_Object tem
;
1274 CHECK_LIST_CONS (tail
, list
);
1276 if (! NILP (Fequal (elt
, tem
)))
1283 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1284 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1285 The value is actually the tail of LIST whose car is ELT. */)
1286 (register Lisp_Object elt
, Lisp_Object list
)
1290 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1294 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1298 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1309 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1310 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1311 The value is actually the tail of LIST whose car is ELT. */)
1312 (register Lisp_Object elt
, Lisp_Object list
)
1314 register Lisp_Object tail
;
1317 return Fmemq (elt
, list
);
1319 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1321 register Lisp_Object tem
;
1322 CHECK_LIST_CONS (tail
, list
);
1324 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1331 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1332 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1333 The value is actually the first element of LIST whose car is KEY.
1334 Elements of LIST that are not conses are ignored. */)
1335 (Lisp_Object key
, Lisp_Object list
)
1340 || (CONSP (XCAR (list
))
1341 && EQ (XCAR (XCAR (list
)), key
)))
1346 || (CONSP (XCAR (list
))
1347 && EQ (XCAR (XCAR (list
)), key
)))
1352 || (CONSP (XCAR (list
))
1353 && EQ (XCAR (XCAR (list
)), key
)))
1363 /* Like Fassq but never report an error and do not allow quits.
1364 Use only on lists known never to be circular. */
1367 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1370 && (!CONSP (XCAR (list
))
1371 || !EQ (XCAR (XCAR (list
)), key
)))
1374 return CAR_SAFE (list
);
1377 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1378 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1379 The value is actually the first element of LIST whose car equals KEY. */)
1380 (Lisp_Object key
, Lisp_Object list
)
1387 || (CONSP (XCAR (list
))
1388 && (car
= XCAR (XCAR (list
)),
1389 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1394 || (CONSP (XCAR (list
))
1395 && (car
= XCAR (XCAR (list
)),
1396 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1401 || (CONSP (XCAR (list
))
1402 && (car
= XCAR (XCAR (list
)),
1403 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1413 /* Like Fassoc but never report an error and do not allow quits.
1414 Use only on lists known never to be circular. */
1417 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1420 && (!CONSP (XCAR (list
))
1421 || (!EQ (XCAR (XCAR (list
)), key
)
1422 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1425 return CONSP (list
) ? XCAR (list
) : Qnil
;
1428 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1429 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1430 The value is actually the first element of LIST whose cdr is KEY. */)
1431 (register Lisp_Object key
, Lisp_Object list
)
1436 || (CONSP (XCAR (list
))
1437 && EQ (XCDR (XCAR (list
)), key
)))
1442 || (CONSP (XCAR (list
))
1443 && EQ (XCDR (XCAR (list
)), key
)))
1448 || (CONSP (XCAR (list
))
1449 && EQ (XCDR (XCAR (list
)), key
)))
1459 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1460 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1461 The value is actually the first element of LIST whose cdr equals KEY. */)
1462 (Lisp_Object key
, Lisp_Object list
)
1469 || (CONSP (XCAR (list
))
1470 && (cdr
= XCDR (XCAR (list
)),
1471 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1476 || (CONSP (XCAR (list
))
1477 && (cdr
= XCDR (XCAR (list
)),
1478 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1483 || (CONSP (XCAR (list
))
1484 && (cdr
= XCDR (XCAR (list
)),
1485 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1495 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1496 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1497 More precisely, this function skips any members `eq' to ELT at the
1498 front of LIST, then removes members `eq' to ELT from the remaining
1499 sublist by modifying its list structure, then returns the resulting
1502 Write `(setq foo (delq element foo))' to be sure of correctly changing
1503 the value of a list `foo'. */)
1504 (register Lisp_Object elt
, Lisp_Object list
)
1506 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1509 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1511 Lisp_Object tem
= XCAR (tail
);
1517 Fsetcdr (prev
, XCDR (tail
));
1525 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1526 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1527 SEQ must be a sequence (i.e. a list, a vector, or a string).
1528 The return value is a sequence of the same type.
1530 If SEQ is a list, this behaves like `delq', except that it compares
1531 with `equal' instead of `eq'. In particular, it may remove elements
1532 by altering the list structure.
1534 If SEQ is not a list, deletion is never performed destructively;
1535 instead this function creates and returns a new vector or string.
1537 Write `(setq foo (delete element foo))' to be sure of correctly
1538 changing the value of a sequence `foo'. */)
1539 (Lisp_Object elt
, Lisp_Object seq
)
1545 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1546 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1549 if (n
!= ASIZE (seq
))
1551 struct Lisp_Vector
*p
= allocate_vector (n
);
1553 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1554 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1555 p
->contents
[n
++] = AREF (seq
, i
);
1557 XSETVECTOR (seq
, p
);
1560 else if (STRINGP (seq
))
1562 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1565 for (i
= nchars
= nbytes
= ibyte
= 0;
1567 ++i
, ibyte
+= cbytes
)
1569 if (STRING_MULTIBYTE (seq
))
1571 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1572 cbytes
= CHAR_BYTES (c
);
1580 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1587 if (nchars
!= SCHARS (seq
))
1591 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1592 if (!STRING_MULTIBYTE (seq
))
1593 STRING_SET_UNIBYTE (tem
);
1595 for (i
= nchars
= nbytes
= ibyte
= 0;
1597 ++i
, ibyte
+= cbytes
)
1599 if (STRING_MULTIBYTE (seq
))
1601 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1602 cbytes
= CHAR_BYTES (c
);
1610 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1612 unsigned char *from
= SDATA (seq
) + ibyte
;
1613 unsigned char *to
= SDATA (tem
) + nbytes
;
1619 for (n
= cbytes
; n
--; )
1629 Lisp_Object tail
, prev
;
1631 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1633 CHECK_LIST_CONS (tail
, seq
);
1635 if (!NILP (Fequal (elt
, XCAR (tail
))))
1640 Fsetcdr (prev
, XCDR (tail
));
1651 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1652 doc
: /* Reverse order of items in a list, vector or string SEQ.
1653 If SEQ is a list, it should be nil-terminated.
1654 This function may destructively modify SEQ to produce the value. */)
1659 else if (STRINGP (seq
))
1660 return Freverse (seq
);
1661 else if (CONSP (seq
))
1663 Lisp_Object prev
, tail
, next
;
1665 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1668 CHECK_LIST_CONS (tail
, tail
);
1670 Fsetcdr (tail
, prev
);
1675 else if (VECTORP (seq
))
1677 ptrdiff_t i
, size
= ASIZE (seq
);
1679 for (i
= 0; i
< size
/ 2; i
++)
1681 Lisp_Object tem
= AREF (seq
, i
);
1682 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1683 ASET (seq
, size
- i
- 1, tem
);
1686 else if (BOOL_VECTOR_P (seq
))
1688 ptrdiff_t i
, size
= bool_vector_size (seq
);
1690 for (i
= 0; i
< size
/ 2; i
++)
1692 bool tem
= bool_vector_bitref (seq
, i
);
1693 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1694 bool_vector_set (seq
, size
- i
- 1, tem
);
1698 wrong_type_argument (Qarrayp
, seq
);
1702 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1703 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1704 See also the function `nreverse', which is used more often. */)
1711 else if (CONSP (seq
))
1713 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1716 new = Fcons (XCAR (seq
), new);
1718 CHECK_LIST_END (seq
, seq
);
1720 else if (VECTORP (seq
))
1722 ptrdiff_t i
, size
= ASIZE (seq
);
1724 new = make_uninit_vector (size
);
1725 for (i
= 0; i
< size
; i
++)
1726 ASET (new, i
, AREF (seq
, size
- i
- 1));
1728 else if (BOOL_VECTOR_P (seq
))
1731 EMACS_INT nbits
= bool_vector_size (seq
);
1733 new = make_uninit_bool_vector (nbits
);
1734 for (i
= 0; i
< nbits
; i
++)
1735 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1737 else if (STRINGP (seq
))
1739 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1745 new = make_uninit_string (size
);
1746 for (i
= 0; i
< size
; i
++)
1747 SSET (new, i
, SREF (seq
, size
- i
- 1));
1751 unsigned char *p
, *q
;
1753 new = make_uninit_multibyte_string (size
, bytes
);
1754 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1755 while (q
> SDATA (new))
1759 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1761 CHAR_STRING (ch
, q
);
1766 wrong_type_argument (Qsequencep
, seq
);
1770 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1771 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1772 Returns the sorted list. LIST is modified by side effects.
1773 PREDICATE is called with two elements of LIST, and should return non-nil
1774 if the first element should sort before the second. */)
1775 (Lisp_Object list
, Lisp_Object predicate
)
1777 Lisp_Object front
, back
;
1778 register Lisp_Object len
, tem
;
1779 struct gcpro gcpro1
, gcpro2
;
1783 len
= Flength (list
);
1784 length
= XINT (len
);
1788 XSETINT (len
, (length
/ 2) - 1);
1789 tem
= Fnthcdr (len
, list
);
1791 Fsetcdr (tem
, Qnil
);
1793 GCPRO2 (front
, back
);
1794 front
= Fsort (front
, predicate
);
1795 back
= Fsort (back
, predicate
);
1797 return merge (front
, back
, predicate
);
1801 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1804 register Lisp_Object tail
;
1806 register Lisp_Object l1
, l2
;
1807 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1814 /* It is sufficient to protect org_l1 and org_l2.
1815 When l1 and l2 are updated, we copy the new values
1816 back into the org_ vars. */
1817 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1837 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1853 Fsetcdr (tail
, tem
);
1859 /* This does not check for quits. That is safe since it must terminate. */
1861 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1862 doc
: /* Extract a value from a property list.
1863 PLIST is a property list, which is a list of the form
1864 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1865 corresponding to the given PROP, or nil if PROP is not one of the
1866 properties on the list. This function never signals an error. */)
1867 (Lisp_Object plist
, Lisp_Object prop
)
1869 Lisp_Object tail
, halftail
;
1871 /* halftail is used to detect circular lists. */
1872 tail
= halftail
= plist
;
1873 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1875 if (EQ (prop
, XCAR (tail
)))
1876 return XCAR (XCDR (tail
));
1878 tail
= XCDR (XCDR (tail
));
1879 halftail
= XCDR (halftail
);
1880 if (EQ (tail
, halftail
))
1887 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1888 doc
: /* Return the value of SYMBOL's PROPNAME property.
1889 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1890 (Lisp_Object symbol
, Lisp_Object propname
)
1892 CHECK_SYMBOL (symbol
);
1893 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1896 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1897 doc
: /* Change value in PLIST of PROP to VAL.
1898 PLIST is a property list, which is a list of the form
1899 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1900 If PROP is already a property on the list, its value is set to VAL,
1901 otherwise the new PROP VAL pair is added. The new plist is returned;
1902 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1903 The PLIST is modified by side effects. */)
1904 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1906 register Lisp_Object tail
, prev
;
1907 Lisp_Object newcell
;
1909 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1910 tail
= XCDR (XCDR (tail
)))
1912 if (EQ (prop
, XCAR (tail
)))
1914 Fsetcar (XCDR (tail
), val
);
1921 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1925 Fsetcdr (XCDR (prev
), newcell
);
1929 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1930 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1931 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1932 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1934 CHECK_SYMBOL (symbol
);
1936 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1940 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1941 doc
: /* Extract a value from a property list, comparing with `equal'.
1942 PLIST is a property list, which is a list of the form
1943 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1944 corresponding to the given PROP, or nil if PROP is not
1945 one of the properties on the list. */)
1946 (Lisp_Object plist
, Lisp_Object prop
)
1951 CONSP (tail
) && CONSP (XCDR (tail
));
1952 tail
= XCDR (XCDR (tail
)))
1954 if (! NILP (Fequal (prop
, XCAR (tail
))))
1955 return XCAR (XCDR (tail
));
1960 CHECK_LIST_END (tail
, prop
);
1965 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1966 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1967 PLIST is a property list, which is a list of the form
1968 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1969 If PROP is already a property on the list, its value is set to VAL,
1970 otherwise the new PROP VAL pair is added. The new plist is returned;
1971 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1972 The PLIST is modified by side effects. */)
1973 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1975 register Lisp_Object tail
, prev
;
1976 Lisp_Object newcell
;
1978 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1979 tail
= XCDR (XCDR (tail
)))
1981 if (! NILP (Fequal (prop
, XCAR (tail
))))
1983 Fsetcar (XCDR (tail
), val
);
1990 newcell
= list2 (prop
, val
);
1994 Fsetcdr (XCDR (prev
), newcell
);
1998 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1999 doc
: /* Return t if the two args are the same Lisp object.
2000 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2001 (Lisp_Object obj1
, Lisp_Object obj2
)
2004 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2006 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2009 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2010 doc
: /* Return t if two Lisp objects have similar structure and contents.
2011 They must have the same data type.
2012 Conses are compared by comparing the cars and the cdrs.
2013 Vectors and strings are compared element by element.
2014 Numbers are compared by value, but integers cannot equal floats.
2015 (Use `=' if you want integers and floats to be able to be equal.)
2016 Symbols must match exactly. */)
2017 (register Lisp_Object o1
, Lisp_Object o2
)
2019 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2022 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2023 doc
: /* Return t if two Lisp objects have similar structure and contents.
2024 This is like `equal' except that it compares the text properties
2025 of strings. (`equal' ignores text properties.) */)
2026 (register Lisp_Object o1
, Lisp_Object o2
)
2028 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2031 /* DEPTH is current depth of recursion. Signal an error if it
2033 PROPS means compare string text properties too. */
2036 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2042 error ("Stack overflow in equal");
2045 Lisp_Object args
[2];
2048 ht
= Fmake_hash_table (2, args
);
2052 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2054 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2056 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2058 { /* `o1' was seen already. */
2059 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2060 if (!NILP (Fmemq (o2
, o2s
)))
2063 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2066 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2076 if (XTYPE (o1
) != XTYPE (o2
))
2085 d1
= extract_float (o1
);
2086 d2
= extract_float (o2
);
2087 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2088 though they are not =. */
2089 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2093 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2097 /* FIXME: This inf-loops in a circular list! */
2101 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2105 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2106 depth
+ 1, props
, ht
)
2107 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2108 depth
+ 1, props
, ht
))
2110 o1
= XOVERLAY (o1
)->plist
;
2111 o2
= XOVERLAY (o2
)->plist
;
2116 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2117 && (XMARKER (o1
)->buffer
== 0
2118 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2122 case Lisp_Vectorlike
:
2125 ptrdiff_t size
= ASIZE (o1
);
2126 /* Pseudovectors have the type encoded in the size field, so this test
2127 actually checks that the objects have the same type as well as the
2129 if (ASIZE (o2
) != size
)
2131 /* Boolvectors are compared much like strings. */
2132 if (BOOL_VECTOR_P (o1
))
2134 EMACS_INT size
= bool_vector_size (o1
);
2135 if (size
!= bool_vector_size (o2
))
2137 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2138 bool_vector_bytes (size
)))
2142 if (WINDOW_CONFIGURATIONP (o1
))
2143 return compare_window_configurations (o1
, o2
, 0);
2145 /* Aside from them, only true vectors, char-tables, compiled
2146 functions, and fonts (font-spec, font-entity, font-object)
2147 are sensible to compare, so eliminate the others now. */
2148 if (size
& PSEUDOVECTOR_FLAG
)
2150 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2153 size
&= PSEUDOVECTOR_SIZE_MASK
;
2155 for (i
= 0; i
< size
; i
++)
2160 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2168 if (SCHARS (o1
) != SCHARS (o2
))
2170 if (SBYTES (o1
) != SBYTES (o2
))
2172 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2174 if (props
&& !compare_string_intervals (o1
, o2
))
2186 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2187 doc
: /* Store each element of ARRAY with ITEM.
2188 ARRAY is a vector, string, char-table, or bool-vector. */)
2189 (Lisp_Object array
, Lisp_Object item
)
2191 register ptrdiff_t size
, idx
;
2193 if (VECTORP (array
))
2194 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2195 ASET (array
, idx
, item
);
2196 else if (CHAR_TABLE_P (array
))
2200 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2201 set_char_table_contents (array
, i
, item
);
2202 set_char_table_defalt (array
, item
);
2204 else if (STRINGP (array
))
2206 register unsigned char *p
= SDATA (array
);
2208 CHECK_CHARACTER (item
);
2209 charval
= XFASTINT (item
);
2210 size
= SCHARS (array
);
2211 if (STRING_MULTIBYTE (array
))
2213 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2214 int len
= CHAR_STRING (charval
, str
);
2215 ptrdiff_t size_byte
= SBYTES (array
);
2217 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2218 || SCHARS (array
) * len
!= size_byte
)
2219 error ("Attempt to change byte length of a string");
2220 for (idx
= 0; idx
< size_byte
; idx
++)
2221 *p
++ = str
[idx
% len
];
2224 for (idx
= 0; idx
< size
; idx
++)
2227 else if (BOOL_VECTOR_P (array
))
2228 return bool_vector_fill (array
, item
);
2230 wrong_type_argument (Qarrayp
, array
);
2234 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2236 doc
: /* Clear the contents of STRING.
2237 This makes STRING unibyte and may change its length. */)
2238 (Lisp_Object string
)
2241 CHECK_STRING (string
);
2242 len
= SBYTES (string
);
2243 memset (SDATA (string
), 0, len
);
2244 STRING_SET_CHARS (string
, len
);
2245 STRING_SET_UNIBYTE (string
);
2251 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2253 Lisp_Object args
[2];
2256 return Fnconc (2, args
);
2259 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2260 doc
: /* Concatenate any number of lists by altering them.
2261 Only the last argument is not altered, and need not be a list.
2262 usage: (nconc &rest LISTS) */)
2263 (ptrdiff_t nargs
, Lisp_Object
*args
)
2266 register Lisp_Object tail
, tem
, val
;
2270 for (argnum
= 0; argnum
< nargs
; argnum
++)
2273 if (NILP (tem
)) continue;
2278 if (argnum
+ 1 == nargs
) break;
2280 CHECK_LIST_CONS (tem
, tem
);
2289 tem
= args
[argnum
+ 1];
2290 Fsetcdr (tail
, tem
);
2292 args
[argnum
+ 1] = tail
;
2298 /* This is the guts of all mapping functions.
2299 Apply FN to each element of SEQ, one by one,
2300 storing the results into elements of VALS, a C vector of Lisp_Objects.
2301 LENI is the length of VALS, which should also be the length of SEQ. */
2304 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2306 register Lisp_Object tail
;
2308 register EMACS_INT i
;
2309 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2313 /* Don't let vals contain any garbage when GC happens. */
2314 for (i
= 0; i
< leni
; i
++)
2317 GCPRO3 (dummy
, fn
, seq
);
2319 gcpro1
.nvars
= leni
;
2323 /* We need not explicitly protect `tail' because it is used only on lists, and
2324 1) lists are not relocated and 2) the list is marked via `seq' so will not
2327 if (VECTORP (seq
) || COMPILEDP (seq
))
2329 for (i
= 0; i
< leni
; i
++)
2331 dummy
= call1 (fn
, AREF (seq
, i
));
2336 else if (BOOL_VECTOR_P (seq
))
2338 for (i
= 0; i
< leni
; i
++)
2340 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2345 else if (STRINGP (seq
))
2349 for (i
= 0, i_byte
= 0; i
< leni
;)
2352 ptrdiff_t i_before
= i
;
2354 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2355 XSETFASTINT (dummy
, c
);
2356 dummy
= call1 (fn
, dummy
);
2358 vals
[i_before
] = dummy
;
2361 else /* Must be a list, since Flength did not get an error */
2364 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2366 dummy
= call1 (fn
, XCAR (tail
));
2376 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2377 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2378 In between each pair of results, stick in SEPARATOR. Thus, " " as
2379 SEPARATOR results in spaces between the values returned by FUNCTION.
2380 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2381 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2384 register EMACS_INT leni
;
2387 register Lisp_Object
*args
;
2388 struct gcpro gcpro1
;
2392 len
= Flength (sequence
);
2393 if (CHAR_TABLE_P (sequence
))
2394 wrong_type_argument (Qlistp
, sequence
);
2396 nargs
= leni
+ leni
- 1;
2397 if (nargs
< 0) return empty_unibyte_string
;
2399 SAFE_ALLOCA_LISP (args
, nargs
);
2402 mapcar1 (leni
, args
, function
, sequence
);
2405 for (i
= leni
- 1; i
> 0; i
--)
2406 args
[i
+ i
] = args
[i
];
2408 for (i
= 1; i
< nargs
; i
+= 2)
2409 args
[i
] = separator
;
2411 ret
= Fconcat (nargs
, args
);
2417 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2418 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2419 The result is a list just as long as SEQUENCE.
2420 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2421 (Lisp_Object function
, Lisp_Object sequence
)
2423 register Lisp_Object len
;
2424 register EMACS_INT leni
;
2425 register Lisp_Object
*args
;
2429 len
= Flength (sequence
);
2430 if (CHAR_TABLE_P (sequence
))
2431 wrong_type_argument (Qlistp
, sequence
);
2432 leni
= XFASTINT (len
);
2434 SAFE_ALLOCA_LISP (args
, leni
);
2436 mapcar1 (leni
, args
, function
, sequence
);
2438 ret
= Flist (leni
, args
);
2444 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2445 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2446 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2447 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2448 (Lisp_Object function
, Lisp_Object sequence
)
2450 register EMACS_INT leni
;
2452 leni
= XFASTINT (Flength (sequence
));
2453 if (CHAR_TABLE_P (sequence
))
2454 wrong_type_argument (Qlistp
, sequence
);
2455 mapcar1 (leni
, 0, function
, sequence
);
2460 /* This is how C code calls `yes-or-no-p' and allows the user
2463 Anything that calls this function must protect from GC! */
2466 do_yes_or_no_p (Lisp_Object prompt
)
2468 return call1 (intern ("yes-or-no-p"), prompt
);
2471 /* Anything that calls this function must protect from GC! */
2473 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2474 doc
: /* Ask user a yes-or-no question.
2475 Return t if answer is yes, and nil if the answer is no.
2476 PROMPT is the string to display to ask the question. It should end in
2477 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2479 The user must confirm the answer with RET, and can edit it until it
2482 If dialog boxes are supported, a dialog box will be used
2483 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2484 (Lisp_Object prompt
)
2486 register Lisp_Object ans
;
2487 Lisp_Object args
[2];
2488 struct gcpro gcpro1
;
2490 CHECK_STRING (prompt
);
2492 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2495 Lisp_Object pane
, menu
, obj
;
2496 redisplay_preserve_echo_area (4);
2497 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2498 Fcons (build_string ("No"), Qnil
));
2500 menu
= Fcons (prompt
, pane
);
2501 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2507 args
[1] = build_string ("(yes or no) ");
2508 prompt
= Fconcat (2, args
);
2514 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2515 Qyes_or_no_p_history
, Qnil
,
2517 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2522 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2530 message1 ("Please answer yes or no.");
2531 Fsleep_for (make_number (2), Qnil
);
2535 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2536 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2538 Each of the three load averages is multiplied by 100, then converted
2541 When USE-FLOATS is non-nil, floats will be used instead of integers.
2542 These floats are not multiplied by 100.
2544 If the 5-minute or 15-minute load averages are not available, return a
2545 shortened list, containing only those averages which are available.
2547 An error is thrown if the load average can't be obtained. In some
2548 cases making it work would require Emacs being installed setuid or
2549 setgid so that it can read kernel information, and that usually isn't
2551 (Lisp_Object use_floats
)
2554 int loads
= getloadavg (load_ave
, 3);
2555 Lisp_Object ret
= Qnil
;
2558 error ("load-average not implemented for this operating system");
2562 Lisp_Object load
= (NILP (use_floats
)
2563 ? make_number (100.0 * load_ave
[loads
])
2564 : make_float (load_ave
[loads
]));
2565 ret
= Fcons (load
, ret
);
2571 static Lisp_Object Qsubfeatures
;
2573 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2574 doc
: /* Return t if FEATURE is present in this Emacs.
2576 Use this to conditionalize execution of lisp code based on the
2577 presence or absence of Emacs or environment extensions.
2578 Use `provide' to declare that a feature is available. This function
2579 looks at the value of the variable `features'. The optional argument
2580 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2581 (Lisp_Object feature
, Lisp_Object subfeature
)
2583 register Lisp_Object tem
;
2584 CHECK_SYMBOL (feature
);
2585 tem
= Fmemq (feature
, Vfeatures
);
2586 if (!NILP (tem
) && !NILP (subfeature
))
2587 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2588 return (NILP (tem
)) ? Qnil
: Qt
;
2591 static Lisp_Object Qfuncall
;
2593 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2594 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2595 The optional argument SUBFEATURES should be a list of symbols listing
2596 particular subfeatures supported in this version of FEATURE. */)
2597 (Lisp_Object feature
, Lisp_Object subfeatures
)
2599 register Lisp_Object tem
;
2600 CHECK_SYMBOL (feature
);
2601 CHECK_LIST (subfeatures
);
2602 if (!NILP (Vautoload_queue
))
2603 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2605 tem
= Fmemq (feature
, Vfeatures
);
2607 Vfeatures
= Fcons (feature
, Vfeatures
);
2608 if (!NILP (subfeatures
))
2609 Fput (feature
, Qsubfeatures
, subfeatures
);
2610 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2612 /* Run any load-hooks for this file. */
2613 tem
= Fassq (feature
, Vafter_load_alist
);
2615 Fmapc (Qfuncall
, XCDR (tem
));
2620 /* `require' and its subroutines. */
2622 /* List of features currently being require'd, innermost first. */
2624 static Lisp_Object require_nesting_list
;
2627 require_unwind (Lisp_Object old_value
)
2629 require_nesting_list
= old_value
;
2632 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2633 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2634 If FEATURE is not a member of the list `features', then the feature
2635 is not loaded; so load the file FILENAME.
2636 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2637 and `load' will try to load this name appended with the suffix `.elc' or
2638 `.el', in that order. The name without appended suffix will not be used.
2639 See `get-load-suffixes' for the complete list of suffixes.
2640 If the optional third argument NOERROR is non-nil,
2641 then return nil if the file is not found instead of signaling an error.
2642 Normally the return value is FEATURE.
2643 The normal messages at start and end of loading FILENAME are suppressed. */)
2644 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2647 struct gcpro gcpro1
, gcpro2
;
2648 bool from_file
= load_in_progress
;
2650 CHECK_SYMBOL (feature
);
2652 /* Record the presence of `require' in this file
2653 even if the feature specified is already loaded.
2654 But not more than once in any file,
2655 and not when we aren't loading or reading from a file. */
2657 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2658 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2663 tem
= Fcons (Qrequire
, feature
);
2664 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2665 LOADHIST_ATTACH (tem
);
2667 tem
= Fmemq (feature
, Vfeatures
);
2671 ptrdiff_t count
= SPECPDL_INDEX ();
2674 /* This is to make sure that loadup.el gives a clear picture
2675 of what files are preloaded and when. */
2676 if (! NILP (Vpurify_flag
))
2677 error ("(require %s) while preparing to dump",
2678 SDATA (SYMBOL_NAME (feature
)));
2680 /* A certain amount of recursive `require' is legitimate,
2681 but if we require the same feature recursively 3 times,
2683 tem
= require_nesting_list
;
2684 while (! NILP (tem
))
2686 if (! NILP (Fequal (feature
, XCAR (tem
))))
2691 error ("Recursive `require' for feature `%s'",
2692 SDATA (SYMBOL_NAME (feature
)));
2694 /* Update the list for any nested `require's that occur. */
2695 record_unwind_protect (require_unwind
, require_nesting_list
);
2696 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2698 /* Value saved here is to be restored into Vautoload_queue */
2699 record_unwind_protect (un_autoload
, Vautoload_queue
);
2700 Vautoload_queue
= Qt
;
2702 /* Load the file. */
2703 GCPRO2 (feature
, filename
);
2704 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2705 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2708 /* If load failed entirely, return nil. */
2710 return unbind_to (count
, Qnil
);
2712 tem
= Fmemq (feature
, Vfeatures
);
2714 error ("Required feature `%s' was not provided",
2715 SDATA (SYMBOL_NAME (feature
)));
2717 /* Once loading finishes, don't undo it. */
2718 Vautoload_queue
= Qt
;
2719 feature
= unbind_to (count
, feature
);
2725 /* Primitives for work of the "widget" library.
2726 In an ideal world, this section would not have been necessary.
2727 However, lisp function calls being as slow as they are, it turns
2728 out that some functions in the widget library (wid-edit.el) are the
2729 bottleneck of Widget operation. Here is their translation to C,
2730 for the sole reason of efficiency. */
2732 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2733 doc
: /* Return non-nil if PLIST has the property PROP.
2734 PLIST is a property list, which is a list of the form
2735 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2736 Unlike `plist-get', this allows you to distinguish between a missing
2737 property and a property with the value nil.
2738 The value is actually the tail of PLIST whose car is PROP. */)
2739 (Lisp_Object plist
, Lisp_Object prop
)
2741 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2744 plist
= XCDR (plist
);
2745 plist
= CDR (plist
);
2750 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2751 doc
: /* In WIDGET, set PROPERTY to VALUE.
2752 The value can later be retrieved with `widget-get'. */)
2753 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2755 CHECK_CONS (widget
);
2756 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2760 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2761 doc
: /* In WIDGET, get the value of PROPERTY.
2762 The value could either be specified when the widget was created, or
2763 later with `widget-put'. */)
2764 (Lisp_Object widget
, Lisp_Object property
)
2772 CHECK_CONS (widget
);
2773 tmp
= Fplist_member (XCDR (widget
), property
);
2779 tmp
= XCAR (widget
);
2782 widget
= Fget (tmp
, Qwidget_type
);
2786 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2787 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2788 ARGS are passed as extra arguments to the function.
2789 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2790 (ptrdiff_t nargs
, Lisp_Object
*args
)
2792 /* This function can GC. */
2793 Lisp_Object newargs
[3];
2794 struct gcpro gcpro1
, gcpro2
;
2797 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2798 newargs
[1] = args
[0];
2799 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2800 GCPRO2 (newargs
[0], newargs
[2]);
2801 result
= Fapply (3, newargs
);
2806 #ifdef HAVE_LANGINFO_CODESET
2807 #include <langinfo.h>
2810 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2811 doc
: /* Access locale data ITEM for the current C locale, if available.
2812 ITEM should be one of the following:
2814 `codeset', returning the character set as a string (locale item CODESET);
2816 `days', returning a 7-element vector of day names (locale items DAY_n);
2818 `months', returning a 12-element vector of month names (locale items MON_n);
2820 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2821 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2823 If the system can't provide such information through a call to
2824 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2826 See also Info node `(libc)Locales'.
2828 The data read from the system are decoded using `locale-coding-system'. */)
2832 #ifdef HAVE_LANGINFO_CODESET
2834 if (EQ (item
, Qcodeset
))
2836 str
= nl_langinfo (CODESET
);
2837 return build_string (str
);
2840 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2842 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2843 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2845 struct gcpro gcpro1
;
2847 synchronize_system_time_locale ();
2848 for (i
= 0; i
< 7; i
++)
2850 str
= nl_langinfo (days
[i
]);
2851 val
= build_unibyte_string (str
);
2852 /* Fixme: Is this coding system necessarily right, even if
2853 it is consistent with CODESET? If not, what to do? */
2854 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2862 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2864 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2865 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2866 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2868 struct gcpro gcpro1
;
2870 synchronize_system_time_locale ();
2871 for (i
= 0; i
< 12; i
++)
2873 str
= nl_langinfo (months
[i
]);
2874 val
= build_unibyte_string (str
);
2875 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2882 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2883 but is in the locale files. This could be used by ps-print. */
2885 else if (EQ (item
, Qpaper
))
2886 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2887 #endif /* PAPER_WIDTH */
2888 #endif /* HAVE_LANGINFO_CODESET*/
2892 /* base64 encode/decode functions (RFC 2045).
2893 Based on code from GNU recode. */
2895 #define MIME_LINE_LENGTH 76
2897 #define IS_ASCII(Character) \
2899 #define IS_BASE64(Character) \
2900 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2901 #define IS_BASE64_IGNORABLE(Character) \
2902 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2903 || (Character) == '\f' || (Character) == '\r')
2905 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2906 character or return retval if there are no characters left to
2908 #define READ_QUADRUPLET_BYTE(retval) \
2913 if (nchars_return) \
2914 *nchars_return = nchars; \
2919 while (IS_BASE64_IGNORABLE (c))
2921 /* Table of characters coding the 64 values. */
2922 static const char base64_value_to_char
[64] =
2924 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2925 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2926 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2927 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2928 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2929 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2930 '8', '9', '+', '/' /* 60-63 */
2933 /* Table of base64 values for first 128 characters. */
2934 static const short base64_char_to_value
[128] =
2936 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2937 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2938 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2939 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2940 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2941 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2942 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2943 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2944 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2945 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2946 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2947 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2948 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2951 /* The following diagram shows the logical steps by which three octets
2952 get transformed into four base64 characters.
2954 .--------. .--------. .--------.
2955 |aaaaaabb| |bbbbcccc| |ccdddddd|
2956 `--------' `--------' `--------'
2958 .--------+--------+--------+--------.
2959 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2960 `--------+--------+--------+--------'
2962 .--------+--------+--------+--------.
2963 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2964 `--------+--------+--------+--------'
2966 The octets are divided into 6 bit chunks, which are then encoded into
2967 base64 characters. */
2970 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2971 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2974 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2976 doc
: /* Base64-encode the region between BEG and END.
2977 Return the length of the encoded text.
2978 Optional third argument NO-LINE-BREAK means do not break long lines
2979 into shorter lines. */)
2980 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2983 ptrdiff_t allength
, length
;
2984 ptrdiff_t ibeg
, iend
, encoded_length
;
2985 ptrdiff_t old_pos
= PT
;
2988 validate_region (&beg
, &end
);
2990 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2991 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2992 move_gap_both (XFASTINT (beg
), ibeg
);
2994 /* We need to allocate enough room for encoding the text.
2995 We need 33 1/3% more space, plus a newline every 76
2996 characters, and then we round up. */
2997 length
= iend
- ibeg
;
2998 allength
= length
+ length
/3 + 1;
2999 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3001 encoded
= SAFE_ALLOCA (allength
);
3002 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3003 encoded
, length
, NILP (no_line_break
),
3004 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3005 if (encoded_length
> allength
)
3008 if (encoded_length
< 0)
3010 /* The encoding wasn't possible. */
3012 error ("Multibyte character in data for base64 encoding");
3015 /* Now we have encoded the region, so we insert the new contents
3016 and delete the old. (Insert first in order to preserve markers.) */
3017 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3018 insert (encoded
, encoded_length
);
3020 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3022 /* If point was outside of the region, restore it exactly; else just
3023 move to the beginning of the region. */
3024 if (old_pos
>= XFASTINT (end
))
3025 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3026 else if (old_pos
> XFASTINT (beg
))
3027 old_pos
= XFASTINT (beg
);
3030 /* We return the length of the encoded text. */
3031 return make_number (encoded_length
);
3034 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3036 doc
: /* Base64-encode STRING and return the result.
3037 Optional second argument NO-LINE-BREAK means do not break long lines
3038 into shorter lines. */)
3039 (Lisp_Object string
, Lisp_Object no_line_break
)
3041 ptrdiff_t allength
, length
, encoded_length
;
3043 Lisp_Object encoded_string
;
3046 CHECK_STRING (string
);
3048 /* We need to allocate enough room for encoding the text.
3049 We need 33 1/3% more space, plus a newline every 76
3050 characters, and then we round up. */
3051 length
= SBYTES (string
);
3052 allength
= length
+ length
/3 + 1;
3053 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3055 /* We need to allocate enough room for decoding the text. */
3056 encoded
= SAFE_ALLOCA (allength
);
3058 encoded_length
= base64_encode_1 (SSDATA (string
),
3059 encoded
, length
, NILP (no_line_break
),
3060 STRING_MULTIBYTE (string
));
3061 if (encoded_length
> allength
)
3064 if (encoded_length
< 0)
3066 /* The encoding wasn't possible. */
3068 error ("Multibyte character in data for base64 encoding");
3071 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3074 return encoded_string
;
3078 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3079 bool line_break
, bool multibyte
)
3092 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3093 if (CHAR_BYTE8_P (c
))
3094 c
= CHAR_TO_BYTE8 (c
);
3102 /* Wrap line every 76 characters. */
3106 if (counter
< MIME_LINE_LENGTH
/ 4)
3115 /* Process first byte of a triplet. */
3117 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3118 value
= (0x03 & c
) << 4;
3120 /* Process second byte of a triplet. */
3124 *e
++ = base64_value_to_char
[value
];
3132 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3133 if (CHAR_BYTE8_P (c
))
3134 c
= CHAR_TO_BYTE8 (c
);
3142 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3143 value
= (0x0f & c
) << 2;
3145 /* Process third byte of a triplet. */
3149 *e
++ = base64_value_to_char
[value
];
3156 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3157 if (CHAR_BYTE8_P (c
))
3158 c
= CHAR_TO_BYTE8 (c
);
3166 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3167 *e
++ = base64_value_to_char
[0x3f & c
];
3174 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3176 doc
: /* Base64-decode the region between BEG and END.
3177 Return the length of the decoded text.
3178 If the region can't be decoded, signal an error and don't modify the buffer. */)
3179 (Lisp_Object beg
, Lisp_Object end
)
3181 ptrdiff_t ibeg
, iend
, length
, allength
;
3183 ptrdiff_t old_pos
= PT
;
3184 ptrdiff_t decoded_length
;
3185 ptrdiff_t inserted_chars
;
3186 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3189 validate_region (&beg
, &end
);
3191 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3192 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3194 length
= iend
- ibeg
;
3196 /* We need to allocate enough room for decoding the text. If we are
3197 working on a multibyte buffer, each decoded code may occupy at
3199 allength
= multibyte
? length
* 2 : length
;
3200 decoded
= SAFE_ALLOCA (allength
);
3202 move_gap_both (XFASTINT (beg
), ibeg
);
3203 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3205 multibyte
, &inserted_chars
);
3206 if (decoded_length
> allength
)
3209 if (decoded_length
< 0)
3211 /* The decoding wasn't possible. */
3213 error ("Invalid base64 data");
3216 /* Now we have decoded the region, so we insert the new contents
3217 and delete the old. (Insert first in order to preserve markers.) */
3218 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3219 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3222 /* Delete the original text. */
3223 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3224 iend
+ decoded_length
, 1);
3226 /* If point was outside of the region, restore it exactly; else just
3227 move to the beginning of the region. */
3228 if (old_pos
>= XFASTINT (end
))
3229 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3230 else if (old_pos
> XFASTINT (beg
))
3231 old_pos
= XFASTINT (beg
);
3232 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3234 return make_number (inserted_chars
);
3237 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3239 doc
: /* Base64-decode STRING and return the result. */)
3240 (Lisp_Object string
)
3243 ptrdiff_t length
, decoded_length
;
3244 Lisp_Object decoded_string
;
3247 CHECK_STRING (string
);
3249 length
= SBYTES (string
);
3250 /* We need to allocate enough room for decoding the text. */
3251 decoded
= SAFE_ALLOCA (length
);
3253 /* The decoded result should be unibyte. */
3254 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3256 if (decoded_length
> length
)
3258 else if (decoded_length
>= 0)
3259 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3261 decoded_string
= Qnil
;
3264 if (!STRINGP (decoded_string
))
3265 error ("Invalid base64 data");
3267 return decoded_string
;
3270 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3271 MULTIBYTE, the decoded result should be in multibyte
3272 form. If NCHARS_RETURN is not NULL, store the number of produced
3273 characters in *NCHARS_RETURN. */
3276 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3277 bool multibyte
, ptrdiff_t *nchars_return
)
3279 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3282 unsigned long value
;
3283 ptrdiff_t nchars
= 0;
3287 /* Process first byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (e
-to
);
3293 value
= base64_char_to_value
[c
] << 18;
3295 /* Process second byte of a quadruplet. */
3297 READ_QUADRUPLET_BYTE (-1);
3301 value
|= base64_char_to_value
[c
] << 12;
3303 c
= (unsigned char) (value
>> 16);
3304 if (multibyte
&& c
>= 128)
3305 e
+= BYTE8_STRING (c
, e
);
3310 /* Process third byte of a quadruplet. */
3312 READ_QUADRUPLET_BYTE (-1);
3316 READ_QUADRUPLET_BYTE (-1);
3325 value
|= base64_char_to_value
[c
] << 6;
3327 c
= (unsigned char) (0xff & value
>> 8);
3328 if (multibyte
&& c
>= 128)
3329 e
+= BYTE8_STRING (c
, e
);
3334 /* Process fourth byte of a quadruplet. */
3336 READ_QUADRUPLET_BYTE (-1);
3343 value
|= base64_char_to_value
[c
];
3345 c
= (unsigned char) (0xff & value
);
3346 if (multibyte
&& c
>= 128)
3347 e
+= BYTE8_STRING (c
, e
);
3356 /***********************************************************************
3358 ***** Hash Tables *****
3360 ***********************************************************************/
3362 /* Implemented by gerd@gnu.org. This hash table implementation was
3363 inspired by CMUCL hash tables. */
3367 1. For small tables, association lists are probably faster than
3368 hash tables because they have lower overhead.
3370 For uses of hash tables where the O(1) behavior of table
3371 operations is not a requirement, it might therefore be a good idea
3372 not to hash. Instead, we could just do a linear search in the
3373 key_and_value vector of the hash table. This could be done
3374 if a `:linear-search t' argument is given to make-hash-table. */
3377 /* The list of all weak hash tables. Don't staticpro this one. */
3379 static struct Lisp_Hash_Table
*weak_hash_tables
;
3381 /* Various symbols. */
3383 static Lisp_Object Qhash_table_p
;
3384 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3385 Lisp_Object Qeq
, Qequal
;
3386 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3387 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3390 /***********************************************************************
3392 ***********************************************************************/
3395 CHECK_HASH_TABLE (Lisp_Object x
)
3397 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3401 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3403 h
->key_and_value
= key_and_value
;
3406 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3411 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3413 gc_aset (h
->next
, idx
, val
);
3416 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3421 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3423 gc_aset (h
->hash
, idx
, val
);
3426 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3431 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3433 gc_aset (h
->index
, idx
, val
);
3436 /* If OBJ is a Lisp hash table, return a pointer to its struct
3437 Lisp_Hash_Table. Otherwise, signal an error. */
3439 static struct Lisp_Hash_Table
*
3440 check_hash_table (Lisp_Object obj
)
3442 CHECK_HASH_TABLE (obj
);
3443 return XHASH_TABLE (obj
);
3447 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3448 number. A number is "almost" a prime number if it is not divisible
3449 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3452 next_almost_prime (EMACS_INT n
)
3454 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3455 for (n
|= 1; ; n
+= 2)
3456 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3461 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3462 which USED[I] is non-zero. If found at index I in ARGS, set
3463 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3464 0. This function is used to extract a keyword/argument pair from
3465 a DEFUN parameter list. */
3468 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3472 for (i
= 1; i
< nargs
; i
++)
3473 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3484 /* Return a Lisp vector which has the same contents as VEC but has
3485 at least INCR_MIN more entries, where INCR_MIN is positive.
3486 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3487 than NITEMS_MAX. Entries in the resulting
3488 vector that are not copied from VEC are set to nil. */
3491 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3493 struct Lisp_Vector
*v
;
3494 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3495 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3496 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3497 ? nitems_max
: C_language_max
);
3498 eassert (VECTORP (vec
));
3499 eassert (0 < incr_min
&& -1 <= nitems_max
);
3500 old_size
= ASIZE (vec
);
3501 incr_max
= n_max
- old_size
;
3502 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3503 if (incr_max
< incr
)
3504 memory_full (SIZE_MAX
);
3505 new_size
= old_size
+ incr
;
3506 v
= allocate_vector (new_size
);
3507 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3508 for (i
= old_size
; i
< new_size
; ++i
)
3509 v
->contents
[i
] = Qnil
;
3510 XSETVECTOR (vec
, v
);
3515 /***********************************************************************
3517 ***********************************************************************/
3519 static struct hash_table_test hashtest_eq
;
3520 struct hash_table_test hashtest_eql
, hashtest_equal
;
3522 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3523 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3524 KEY2 are the same. */
3527 cmpfn_eql (struct hash_table_test
*ht
,
3531 return (FLOATP (key1
)
3533 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3537 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3538 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3539 KEY2 are the same. */
3542 cmpfn_equal (struct hash_table_test
*ht
,
3546 return !NILP (Fequal (key1
, key2
));
3550 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3551 HASH2 in hash table H using H->user_cmp_function. Value is true
3552 if KEY1 and KEY2 are the same. */
3555 cmpfn_user_defined (struct hash_table_test
*ht
,
3559 Lisp_Object args
[3];
3561 args
[0] = ht
->user_cmp_function
;
3564 return !NILP (Ffuncall (3, args
));
3568 /* Value is a hash code for KEY for use in hash table H which uses
3569 `eq' to compare keys. The hash code returned is guaranteed to fit
3570 in a Lisp integer. */
3573 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3575 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3579 /* Value is a hash code for KEY for use in hash table H which uses
3580 `eql' to compare keys. The hash code returned is guaranteed to fit
3581 in a Lisp integer. */
3584 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3588 hash
= sxhash (key
, 0);
3590 hash
= XHASH (key
) ^ XTYPE (key
);
3594 /* Value is a hash code for KEY for use in hash table H which uses
3595 `equal' to compare keys. The hash code returned is guaranteed to fit
3596 in a Lisp integer. */
3599 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3601 EMACS_UINT hash
= sxhash (key
, 0);
3605 /* Value is a hash code for KEY for use in hash table H which uses as
3606 user-defined function to compare keys. The hash code returned is
3607 guaranteed to fit in a Lisp integer. */
3610 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3612 Lisp_Object args
[2], hash
;
3614 args
[0] = ht
->user_hash_function
;
3616 hash
= Ffuncall (2, args
);
3617 return hashfn_eq (ht
, hash
);
3620 /* An upper bound on the size of a hash table index. It must fit in
3621 ptrdiff_t and be a valid Emacs fixnum. */
3622 #define INDEX_SIZE_BOUND \
3623 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3625 /* Create and initialize a new hash table.
3627 TEST specifies the test the hash table will use to compare keys.
3628 It must be either one of the predefined tests `eq', `eql' or
3629 `equal' or a symbol denoting a user-defined test named TEST with
3630 test and hash functions USER_TEST and USER_HASH.
3632 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3634 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3635 new size when it becomes full is computed by adding REHASH_SIZE to
3636 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3637 table's new size is computed by multiplying its old size with
3640 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3641 be resized when the ratio of (number of entries in the table) /
3642 (table size) is >= REHASH_THRESHOLD.
3644 WEAK specifies the weakness of the table. If non-nil, it must be
3645 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3648 make_hash_table (struct hash_table_test test
,
3649 Lisp_Object size
, Lisp_Object rehash_size
,
3650 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3652 struct Lisp_Hash_Table
*h
;
3654 EMACS_INT index_size
, sz
;
3658 /* Preconditions. */
3659 eassert (SYMBOLP (test
.name
));
3660 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3661 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3662 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3663 eassert (FLOATP (rehash_threshold
)
3664 && 0 < XFLOAT_DATA (rehash_threshold
)
3665 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3667 if (XFASTINT (size
) == 0)
3668 size
= make_number (1);
3670 sz
= XFASTINT (size
);
3671 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3672 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3673 ? next_almost_prime (index_float
)
3674 : INDEX_SIZE_BOUND
+ 1);
3675 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3676 error ("Hash table too large");
3678 /* Allocate a table and initialize it. */
3679 h
= allocate_hash_table ();
3681 /* Initialize hash table slots. */
3684 h
->rehash_threshold
= rehash_threshold
;
3685 h
->rehash_size
= rehash_size
;
3687 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3688 h
->hash
= Fmake_vector (size
, Qnil
);
3689 h
->next
= Fmake_vector (size
, Qnil
);
3690 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3692 /* Set up the free list. */
3693 for (i
= 0; i
< sz
- 1; ++i
)
3694 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3695 h
->next_free
= make_number (0);
3697 XSET_HASH_TABLE (table
, h
);
3698 eassert (HASH_TABLE_P (table
));
3699 eassert (XHASH_TABLE (table
) == h
);
3701 /* Maybe add this hash table to the list of all weak hash tables. */
3703 h
->next_weak
= NULL
;
3706 h
->next_weak
= weak_hash_tables
;
3707 weak_hash_tables
= h
;
3714 /* Return a copy of hash table H1. Keys and values are not copied,
3715 only the table itself is. */
3718 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3721 struct Lisp_Hash_Table
*h2
;
3723 h2
= allocate_hash_table ();
3725 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3726 h2
->hash
= Fcopy_sequence (h1
->hash
);
3727 h2
->next
= Fcopy_sequence (h1
->next
);
3728 h2
->index
= Fcopy_sequence (h1
->index
);
3729 XSET_HASH_TABLE (table
, h2
);
3731 /* Maybe add this hash table to the list of all weak hash tables. */
3732 if (!NILP (h2
->weak
))
3734 h2
->next_weak
= weak_hash_tables
;
3735 weak_hash_tables
= h2
;
3742 /* Resize hash table H if it's too full. If H cannot be resized
3743 because it's already too large, throw an error. */
3746 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3748 if (NILP (h
->next_free
))
3750 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3751 EMACS_INT new_size
, index_size
, nsize
;
3755 if (INTEGERP (h
->rehash_size
))
3756 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3759 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3760 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3762 new_size
= float_new_size
;
3763 if (new_size
<= old_size
)
3764 new_size
= old_size
+ 1;
3767 new_size
= INDEX_SIZE_BOUND
+ 1;
3769 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3770 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3771 ? next_almost_prime (index_float
)
3772 : INDEX_SIZE_BOUND
+ 1);
3773 nsize
= max (index_size
, 2 * new_size
);
3774 if (INDEX_SIZE_BOUND
< nsize
)
3775 error ("Hash table too large to resize");
3777 #ifdef ENABLE_CHECKING
3778 if (HASH_TABLE_P (Vpurify_flag
)
3779 && XHASH_TABLE (Vpurify_flag
) == h
)
3781 Lisp_Object args
[2];
3782 args
[0] = build_string ("Growing hash table to: %d");
3783 args
[1] = make_number (new_size
);
3788 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3789 2 * (new_size
- old_size
), -1));
3790 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3791 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3792 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3794 /* Update the free list. Do it so that new entries are added at
3795 the end of the free list. This makes some operations like
3797 for (i
= old_size
; i
< new_size
- 1; ++i
)
3798 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3800 if (!NILP (h
->next_free
))
3802 Lisp_Object last
, next
;
3804 last
= h
->next_free
;
3805 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3809 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3812 XSETFASTINT (h
->next_free
, old_size
);
3815 for (i
= 0; i
< old_size
; ++i
)
3816 if (!NILP (HASH_HASH (h
, i
)))
3818 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3819 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3820 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3821 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3827 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3828 the hash code of KEY. Value is the index of the entry in H
3829 matching KEY, or -1 if not found. */
3832 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3834 EMACS_UINT hash_code
;
3835 ptrdiff_t start_of_bucket
;
3838 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3839 eassert ((hash_code
& ~INTMASK
) == 0);
3843 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3844 idx
= HASH_INDEX (h
, start_of_bucket
);
3846 /* We need not gcpro idx since it's either an integer or nil. */
3849 ptrdiff_t i
= XFASTINT (idx
);
3850 if (EQ (key
, HASH_KEY (h
, i
))
3852 && hash_code
== XUINT (HASH_HASH (h
, i
))
3853 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3855 idx
= HASH_NEXT (h
, i
);
3858 return NILP (idx
) ? -1 : XFASTINT (idx
);
3862 /* Put an entry into hash table H that associates KEY with VALUE.
3863 HASH is a previously computed hash code of KEY.
3864 Value is the index of the entry in H matching KEY. */
3867 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3870 ptrdiff_t start_of_bucket
, i
;
3872 eassert ((hash
& ~INTMASK
) == 0);
3874 /* Increment count after resizing because resizing may fail. */
3875 maybe_resize_hash_table (h
);
3878 /* Store key/value in the key_and_value vector. */
3879 i
= XFASTINT (h
->next_free
);
3880 h
->next_free
= HASH_NEXT (h
, i
);
3881 set_hash_key_slot (h
, i
, key
);
3882 set_hash_value_slot (h
, i
, value
);
3884 /* Remember its hash code. */
3885 set_hash_hash_slot (h
, i
, make_number (hash
));
3887 /* Add new entry to its collision chain. */
3888 start_of_bucket
= hash
% ASIZE (h
->index
);
3889 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3890 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3895 /* Remove the entry matching KEY from hash table H, if there is one. */
3898 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3900 EMACS_UINT hash_code
;
3901 ptrdiff_t start_of_bucket
;
3902 Lisp_Object idx
, prev
;
3904 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3905 eassert ((hash_code
& ~INTMASK
) == 0);
3906 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3907 idx
= HASH_INDEX (h
, start_of_bucket
);
3910 /* We need not gcpro idx, prev since they're either integers or nil. */
3913 ptrdiff_t i
= XFASTINT (idx
);
3915 if (EQ (key
, HASH_KEY (h
, i
))
3917 && hash_code
== XUINT (HASH_HASH (h
, i
))
3918 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3920 /* Take entry out of collision chain. */
3922 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3924 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3926 /* Clear slots in key_and_value and add the slots to
3928 set_hash_key_slot (h
, i
, Qnil
);
3929 set_hash_value_slot (h
, i
, Qnil
);
3930 set_hash_hash_slot (h
, i
, Qnil
);
3931 set_hash_next_slot (h
, i
, h
->next_free
);
3932 h
->next_free
= make_number (i
);
3934 eassert (h
->count
>= 0);
3940 idx
= HASH_NEXT (h
, i
);
3946 /* Clear hash table H. */
3949 hash_clear (struct Lisp_Hash_Table
*h
)
3953 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3955 for (i
= 0; i
< size
; ++i
)
3957 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3958 set_hash_key_slot (h
, i
, Qnil
);
3959 set_hash_value_slot (h
, i
, Qnil
);
3960 set_hash_hash_slot (h
, i
, Qnil
);
3963 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3964 ASET (h
->index
, i
, Qnil
);
3966 h
->next_free
= make_number (0);
3973 /************************************************************************
3975 ************************************************************************/
3977 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3978 entries from the table that don't survive the current GC.
3979 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3980 true if anything was marked. */
3983 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3985 ptrdiff_t bucket
, n
;
3988 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3991 for (bucket
= 0; bucket
< n
; ++bucket
)
3993 Lisp_Object idx
, next
, prev
;
3995 /* Follow collision chain, removing entries that
3996 don't survive this garbage collection. */
3998 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4000 ptrdiff_t i
= XFASTINT (idx
);
4001 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4002 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4005 if (EQ (h
->weak
, Qkey
))
4006 remove_p
= !key_known_to_survive_p
;
4007 else if (EQ (h
->weak
, Qvalue
))
4008 remove_p
= !value_known_to_survive_p
;
4009 else if (EQ (h
->weak
, Qkey_or_value
))
4010 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4011 else if (EQ (h
->weak
, Qkey_and_value
))
4012 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4016 next
= HASH_NEXT (h
, i
);
4018 if (remove_entries_p
)
4022 /* Take out of collision chain. */
4024 set_hash_index_slot (h
, bucket
, next
);
4026 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4028 /* Add to free list. */
4029 set_hash_next_slot (h
, i
, h
->next_free
);
4032 /* Clear key, value, and hash. */
4033 set_hash_key_slot (h
, i
, Qnil
);
4034 set_hash_value_slot (h
, i
, Qnil
);
4035 set_hash_hash_slot (h
, i
, Qnil
);
4048 /* Make sure key and value survive. */
4049 if (!key_known_to_survive_p
)
4051 mark_object (HASH_KEY (h
, i
));
4055 if (!value_known_to_survive_p
)
4057 mark_object (HASH_VALUE (h
, i
));
4068 /* Remove elements from weak hash tables that don't survive the
4069 current garbage collection. Remove weak tables that don't survive
4070 from Vweak_hash_tables. Called from gc_sweep. */
4072 NO_INLINE
/* For better stack traces */
4074 sweep_weak_hash_tables (void)
4076 struct Lisp_Hash_Table
*h
, *used
, *next
;
4079 /* Mark all keys and values that are in use. Keep on marking until
4080 there is no more change. This is necessary for cases like
4081 value-weak table A containing an entry X -> Y, where Y is used in a
4082 key-weak table B, Z -> Y. If B comes after A in the list of weak
4083 tables, X -> Y might be removed from A, although when looking at B
4084 one finds that it shouldn't. */
4088 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4090 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4091 marked
|= sweep_weak_table (h
, 0);
4096 /* Remove tables and entries that aren't used. */
4097 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4099 next
= h
->next_weak
;
4101 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4103 /* TABLE is marked as used. Sweep its contents. */
4105 sweep_weak_table (h
, 1);
4107 /* Add table to the list of used weak hash tables. */
4108 h
->next_weak
= used
;
4113 weak_hash_tables
= used
;
4118 /***********************************************************************
4119 Hash Code Computation
4120 ***********************************************************************/
4122 /* Maximum depth up to which to dive into Lisp structures. */
4124 #define SXHASH_MAX_DEPTH 3
4126 /* Maximum length up to which to take list and vector elements into
4129 #define SXHASH_MAX_LEN 7
4131 /* Return a hash for string PTR which has length LEN. The hash value
4132 can be any EMACS_UINT value. */
4135 hash_string (char const *ptr
, ptrdiff_t len
)
4137 char const *p
= ptr
;
4138 char const *end
= p
+ len
;
4140 EMACS_UINT hash
= 0;
4145 hash
= sxhash_combine (hash
, c
);
4151 /* Return a hash for string PTR which has length LEN. The hash
4152 code returned is guaranteed to fit in a Lisp integer. */
4155 sxhash_string (char const *ptr
, ptrdiff_t len
)
4157 EMACS_UINT hash
= hash_string (ptr
, len
);
4158 return SXHASH_REDUCE (hash
);
4161 /* Return a hash for the floating point value VAL. */
4164 sxhash_float (double val
)
4166 EMACS_UINT hash
= 0;
4168 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4169 + (sizeof val
% sizeof hash
!= 0))
4173 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4177 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4178 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4179 hash
= sxhash_combine (hash
, u
.word
[i
]);
4180 return SXHASH_REDUCE (hash
);
4183 /* Return a hash for list LIST. DEPTH is the current depth in the
4184 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4187 sxhash_list (Lisp_Object list
, int depth
)
4189 EMACS_UINT hash
= 0;
4192 if (depth
< SXHASH_MAX_DEPTH
)
4194 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4195 list
= XCDR (list
), ++i
)
4197 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4198 hash
= sxhash_combine (hash
, hash2
);
4203 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4204 hash
= sxhash_combine (hash
, hash2
);
4207 return SXHASH_REDUCE (hash
);
4211 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4212 the Lisp structure. */
4215 sxhash_vector (Lisp_Object vec
, int depth
)
4217 EMACS_UINT hash
= ASIZE (vec
);
4220 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4221 for (i
= 0; i
< n
; ++i
)
4223 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4224 hash
= sxhash_combine (hash
, hash2
);
4227 return SXHASH_REDUCE (hash
);
4230 /* Return a hash for bool-vector VECTOR. */
4233 sxhash_bool_vector (Lisp_Object vec
)
4235 EMACS_INT size
= bool_vector_size (vec
);
4236 EMACS_UINT hash
= size
;
4239 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4240 for (i
= 0; i
< n
; ++i
)
4241 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4243 return SXHASH_REDUCE (hash
);
4247 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4248 structure. Value is an unsigned integer clipped to INTMASK. */
4251 sxhash (Lisp_Object obj
, int depth
)
4255 if (depth
> SXHASH_MAX_DEPTH
)
4258 switch (XTYPE (obj
))
4269 obj
= SYMBOL_NAME (obj
);
4273 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4276 /* This can be everything from a vector to an overlay. */
4277 case Lisp_Vectorlike
:
4279 /* According to the CL HyperSpec, two arrays are equal only if
4280 they are `eq', except for strings and bit-vectors. In
4281 Emacs, this works differently. We have to compare element
4283 hash
= sxhash_vector (obj
, depth
);
4284 else if (BOOL_VECTOR_P (obj
))
4285 hash
= sxhash_bool_vector (obj
);
4287 /* Others are `equal' if they are `eq', so let's take their
4293 hash
= sxhash_list (obj
, depth
);
4297 hash
= sxhash_float (XFLOAT_DATA (obj
));
4309 /***********************************************************************
4311 ***********************************************************************/
4314 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4315 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4318 EMACS_UINT hash
= sxhash (obj
, 0);
4319 return make_number (hash
);
4323 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4324 doc
: /* Create and return a new hash table.
4326 Arguments are specified as keyword/argument pairs. The following
4327 arguments are defined:
4329 :test TEST -- TEST must be a symbol that specifies how to compare
4330 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4331 `equal'. User-supplied test and hash functions can be specified via
4332 `define-hash-table-test'.
4334 :size SIZE -- A hint as to how many elements will be put in the table.
4337 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4338 fills up. If REHASH-SIZE is an integer, increase the size by that
4339 amount. If it is a float, it must be > 1.0, and the new size is the
4340 old size multiplied by that factor. Default is 1.5.
4342 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4343 Resize the hash table when the ratio (number of entries / table size)
4344 is greater than or equal to THRESHOLD. Default is 0.8.
4346 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4347 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4348 returned is a weak table. Key/value pairs are removed from a weak
4349 hash table when there are no non-weak references pointing to their
4350 key, value, one of key or value, or both key and value, depending on
4351 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4354 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4355 (ptrdiff_t nargs
, Lisp_Object
*args
)
4357 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4358 struct hash_table_test testdesc
;
4362 /* The vector `used' is used to keep track of arguments that
4363 have been consumed. */
4364 used
= alloca (nargs
* sizeof *used
);
4365 memset (used
, 0, nargs
* sizeof *used
);
4367 /* See if there's a `:test TEST' among the arguments. */
4368 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4369 test
= i
? args
[i
] : Qeql
;
4371 testdesc
= hashtest_eq
;
4372 else if (EQ (test
, Qeql
))
4373 testdesc
= hashtest_eql
;
4374 else if (EQ (test
, Qequal
))
4375 testdesc
= hashtest_equal
;
4378 /* See if it is a user-defined test. */
4381 prop
= Fget (test
, Qhash_table_test
);
4382 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4383 signal_error ("Invalid hash table test", test
);
4384 testdesc
.name
= test
;
4385 testdesc
.user_cmp_function
= XCAR (prop
);
4386 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4387 testdesc
.hashfn
= hashfn_user_defined
;
4388 testdesc
.cmpfn
= cmpfn_user_defined
;
4391 /* See if there's a `:size SIZE' argument. */
4392 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4393 size
= i
? args
[i
] : Qnil
;
4395 size
= make_number (DEFAULT_HASH_SIZE
);
4396 else if (!INTEGERP (size
) || XINT (size
) < 0)
4397 signal_error ("Invalid hash table size", size
);
4399 /* Look for `:rehash-size SIZE'. */
4400 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4401 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4402 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4403 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4404 signal_error ("Invalid hash table rehash size", rehash_size
);
4406 /* Look for `:rehash-threshold THRESHOLD'. */
4407 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4408 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4409 if (! (FLOATP (rehash_threshold
)
4410 && 0 < XFLOAT_DATA (rehash_threshold
)
4411 && XFLOAT_DATA (rehash_threshold
) <= 1))
4412 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4414 /* Look for `:weakness WEAK'. */
4415 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4416 weak
= i
? args
[i
] : Qnil
;
4418 weak
= Qkey_and_value
;
4421 && !EQ (weak
, Qvalue
)
4422 && !EQ (weak
, Qkey_or_value
)
4423 && !EQ (weak
, Qkey_and_value
))
4424 signal_error ("Invalid hash table weakness", weak
);
4426 /* Now, all args should have been used up, or there's a problem. */
4427 for (i
= 0; i
< nargs
; ++i
)
4429 signal_error ("Invalid argument list", args
[i
]);
4431 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4435 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4436 doc
: /* Return a copy of hash table TABLE. */)
4439 return copy_hash_table (check_hash_table (table
));
4443 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4444 doc
: /* Return the number of elements in TABLE. */)
4447 return make_number (check_hash_table (table
)->count
);
4451 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4452 Shash_table_rehash_size
, 1, 1, 0,
4453 doc
: /* Return the current rehash size of TABLE. */)
4456 return check_hash_table (table
)->rehash_size
;
4460 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4461 Shash_table_rehash_threshold
, 1, 1, 0,
4462 doc
: /* Return the current rehash threshold of TABLE. */)
4465 return check_hash_table (table
)->rehash_threshold
;
4469 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4470 doc
: /* Return the size of TABLE.
4471 The size can be used as an argument to `make-hash-table' to create
4472 a hash table than can hold as many elements as TABLE holds
4473 without need for resizing. */)
4476 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4477 return make_number (HASH_TABLE_SIZE (h
));
4481 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4482 doc
: /* Return the test TABLE uses. */)
4485 return check_hash_table (table
)->test
.name
;
4489 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4491 doc
: /* Return the weakness of TABLE. */)
4494 return check_hash_table (table
)->weak
;
4498 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4499 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4502 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4506 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4507 doc
: /* Clear hash table TABLE and return it. */)
4510 hash_clear (check_hash_table (table
));
4511 /* Be compatible with XEmacs. */
4516 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4517 doc
: /* Look up KEY in TABLE and return its associated value.
4518 If KEY is not found, return DFLT which defaults to nil. */)
4519 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4521 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4522 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4523 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4527 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4528 doc
: /* Associate KEY with VALUE in hash table TABLE.
4529 If KEY is already present in table, replace its current value with
4530 VALUE. In any case, return VALUE. */)
4531 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4533 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4537 i
= hash_lookup (h
, key
, &hash
);
4539 set_hash_value_slot (h
, i
, value
);
4541 hash_put (h
, key
, value
, hash
);
4547 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4548 doc
: /* Remove KEY from TABLE. */)
4549 (Lisp_Object key
, Lisp_Object table
)
4551 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4552 hash_remove_from_table (h
, key
);
4557 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4558 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4559 FUNCTION is called with two arguments, KEY and VALUE.
4560 `maphash' always returns nil. */)
4561 (Lisp_Object function
, Lisp_Object table
)
4563 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4564 Lisp_Object args
[3];
4567 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4568 if (!NILP (HASH_HASH (h
, i
)))
4571 args
[1] = HASH_KEY (h
, i
);
4572 args
[2] = HASH_VALUE (h
, i
);
4580 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4581 Sdefine_hash_table_test
, 3, 3, 0,
4582 doc
: /* Define a new hash table test with name NAME, a symbol.
4584 In hash tables created with NAME specified as test, use TEST to
4585 compare keys, and HASH for computing hash codes of keys.
4587 TEST must be a function taking two arguments and returning non-nil if
4588 both arguments are the same. HASH must be a function taking one
4589 argument and returning an object that is the hash code of the argument.
4590 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4591 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4592 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4594 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4599 /************************************************************************
4600 MD5, SHA-1, and SHA-2
4601 ************************************************************************/
4608 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4611 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4612 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4616 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4617 register EMACS_INT b
, e
;
4618 register struct buffer
*bp
;
4621 void *(*hash_func
) (const char *, size_t, void *);
4624 CHECK_SYMBOL (algorithm
);
4626 if (STRINGP (object
))
4628 if (NILP (coding_system
))
4630 /* Decide the coding-system to encode the data with. */
4632 if (STRING_MULTIBYTE (object
))
4633 /* use default, we can't guess correct value */
4634 coding_system
= preferred_coding_system ();
4636 coding_system
= Qraw_text
;
4639 if (NILP (Fcoding_system_p (coding_system
)))
4641 /* Invalid coding system. */
4643 if (!NILP (noerror
))
4644 coding_system
= Qraw_text
;
4646 xsignal1 (Qcoding_system_error
, coding_system
);
4649 if (STRING_MULTIBYTE (object
))
4650 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4652 size
= SCHARS (object
);
4653 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4655 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4656 end_byte
= (end_char
== size
4658 : string_char_to_byte (object
, end_char
));
4662 struct buffer
*prev
= current_buffer
;
4664 record_unwind_current_buffer ();
4666 CHECK_BUFFER (object
);
4668 bp
= XBUFFER (object
);
4669 set_buffer_internal (bp
);
4675 CHECK_NUMBER_COERCE_MARKER (start
);
4683 CHECK_NUMBER_COERCE_MARKER (end
);
4688 temp
= b
, b
= e
, e
= temp
;
4690 if (!(BEGV
<= b
&& e
<= ZV
))
4691 args_out_of_range (start
, end
);
4693 if (NILP (coding_system
))
4695 /* Decide the coding-system to encode the data with.
4696 See fileio.c:Fwrite-region */
4698 if (!NILP (Vcoding_system_for_write
))
4699 coding_system
= Vcoding_system_for_write
;
4702 bool force_raw_text
= 0;
4704 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4705 if (NILP (coding_system
)
4706 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4708 coding_system
= Qnil
;
4709 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4713 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4715 /* Check file-coding-system-alist. */
4716 Lisp_Object args
[4], val
;
4718 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4719 args
[3] = Fbuffer_file_name (object
);
4720 val
= Ffind_operation_coding_system (4, args
);
4721 if (CONSP (val
) && !NILP (XCDR (val
)))
4722 coding_system
= XCDR (val
);
4725 if (NILP (coding_system
)
4726 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4728 /* If we still have not decided a coding system, use the
4729 default value of buffer-file-coding-system. */
4730 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4734 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4735 /* Confirm that VAL can surely encode the current region. */
4736 coding_system
= call4 (Vselect_safe_coding_system_function
,
4737 make_number (b
), make_number (e
),
4738 coding_system
, Qnil
);
4741 coding_system
= Qraw_text
;
4744 if (NILP (Fcoding_system_p (coding_system
)))
4746 /* Invalid coding system. */
4748 if (!NILP (noerror
))
4749 coding_system
= Qraw_text
;
4751 xsignal1 (Qcoding_system_error
, coding_system
);
4755 object
= make_buffer_string (b
, e
, 0);
4756 set_buffer_internal (prev
);
4757 /* Discard the unwind protect for recovering the current
4761 if (STRING_MULTIBYTE (object
))
4762 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4764 end_byte
= SBYTES (object
);
4767 if (EQ (algorithm
, Qmd5
))
4769 digest_size
= MD5_DIGEST_SIZE
;
4770 hash_func
= md5_buffer
;
4772 else if (EQ (algorithm
, Qsha1
))
4774 digest_size
= SHA1_DIGEST_SIZE
;
4775 hash_func
= sha1_buffer
;
4777 else if (EQ (algorithm
, Qsha224
))
4779 digest_size
= SHA224_DIGEST_SIZE
;
4780 hash_func
= sha224_buffer
;
4782 else if (EQ (algorithm
, Qsha256
))
4784 digest_size
= SHA256_DIGEST_SIZE
;
4785 hash_func
= sha256_buffer
;
4787 else if (EQ (algorithm
, Qsha384
))
4789 digest_size
= SHA384_DIGEST_SIZE
;
4790 hash_func
= sha384_buffer
;
4792 else if (EQ (algorithm
, Qsha512
))
4794 digest_size
= SHA512_DIGEST_SIZE
;
4795 hash_func
= sha512_buffer
;
4798 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4800 /* allocate 2 x digest_size so that it can be re-used to hold the
4802 digest
= make_uninit_string (digest_size
* 2);
4804 hash_func (SSDATA (object
) + start_byte
,
4805 end_byte
- start_byte
,
4810 unsigned char *p
= SDATA (digest
);
4811 for (i
= digest_size
- 1; i
>= 0; i
--)
4813 static char const hexdigit
[16] = "0123456789abcdef";
4815 p
[2 * i
] = hexdigit
[p_i
>> 4];
4816 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4821 return make_unibyte_string (SSDATA (digest
), digest_size
);
4824 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4825 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4827 A message digest is a cryptographic checksum of a document, and the
4828 algorithm to calculate it is defined in RFC 1321.
4830 The two optional arguments START and END are character positions
4831 specifying for which part of OBJECT the message digest should be
4832 computed. If nil or omitted, the digest is computed for the whole
4835 The MD5 message digest is computed from the result of encoding the
4836 text in a coding system, not directly from the internal Emacs form of
4837 the text. The optional fourth argument CODING-SYSTEM specifies which
4838 coding system to encode the text with. It should be the same coding
4839 system that you used or will use when actually writing the text into a
4842 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4843 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4844 system would be chosen by default for writing this text into a file.
4846 If OBJECT is a string, the most preferred coding system (see the
4847 command `prefer-coding-system') is used.
4849 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4850 guesswork fails. Normally, an error is signaled in such case. */)
4851 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4853 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4856 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4857 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4858 ALGORITHM is a symbol specifying the hash to use:
4859 md5, sha1, sha224, sha256, sha384 or sha512.
4861 The two optional arguments START and END are positions specifying for
4862 which part of OBJECT to compute the hash. If nil or omitted, uses the
4865 If BINARY is non-nil, returns a string in binary form. */)
4866 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4868 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4874 DEFSYM (Qmd5
, "md5");
4875 DEFSYM (Qsha1
, "sha1");
4876 DEFSYM (Qsha224
, "sha224");
4877 DEFSYM (Qsha256
, "sha256");
4878 DEFSYM (Qsha384
, "sha384");
4879 DEFSYM (Qsha512
, "sha512");
4881 /* Hash table stuff. */
4882 DEFSYM (Qhash_table_p
, "hash-table-p");
4884 DEFSYM (Qeql
, "eql");
4885 DEFSYM (Qequal
, "equal");
4886 DEFSYM (QCtest
, ":test");
4887 DEFSYM (QCsize
, ":size");
4888 DEFSYM (QCrehash_size
, ":rehash-size");
4889 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4890 DEFSYM (QCweakness
, ":weakness");
4891 DEFSYM (Qkey
, "key");
4892 DEFSYM (Qvalue
, "value");
4893 DEFSYM (Qhash_table_test
, "hash-table-test");
4894 DEFSYM (Qkey_or_value
, "key-or-value");
4895 DEFSYM (Qkey_and_value
, "key-and-value");
4898 defsubr (&Smake_hash_table
);
4899 defsubr (&Scopy_hash_table
);
4900 defsubr (&Shash_table_count
);
4901 defsubr (&Shash_table_rehash_size
);
4902 defsubr (&Shash_table_rehash_threshold
);
4903 defsubr (&Shash_table_size
);
4904 defsubr (&Shash_table_test
);
4905 defsubr (&Shash_table_weakness
);
4906 defsubr (&Shash_table_p
);
4907 defsubr (&Sclrhash
);
4908 defsubr (&Sgethash
);
4909 defsubr (&Sputhash
);
4910 defsubr (&Sremhash
);
4911 defsubr (&Smaphash
);
4912 defsubr (&Sdefine_hash_table_test
);
4914 DEFSYM (Qstring_lessp
, "string-lessp");
4915 DEFSYM (Qprovide
, "provide");
4916 DEFSYM (Qrequire
, "require");
4917 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4918 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4919 DEFSYM (Qwidget_type
, "widget-type");
4921 staticpro (&string_char_byte_cache_string
);
4922 string_char_byte_cache_string
= Qnil
;
4924 require_nesting_list
= Qnil
;
4925 staticpro (&require_nesting_list
);
4927 Fset (Qyes_or_no_p_history
, Qnil
);
4929 DEFVAR_LISP ("features", Vfeatures
,
4930 doc
: /* A list of symbols which are the features of the executing Emacs.
4931 Used by `featurep' and `require', and altered by `provide'. */);
4932 Vfeatures
= list1 (intern_c_string ("emacs"));
4933 DEFSYM (Qsubfeatures
, "subfeatures");
4934 DEFSYM (Qfuncall
, "funcall");
4936 #ifdef HAVE_LANGINFO_CODESET
4937 DEFSYM (Qcodeset
, "codeset");
4938 DEFSYM (Qdays
, "days");
4939 DEFSYM (Qmonths
, "months");
4940 DEFSYM (Qpaper
, "paper");
4941 #endif /* HAVE_LANGINFO_CODESET */
4943 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4944 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4945 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4946 invoked by mouse clicks and mouse menu items.
4948 On some platforms, file selection dialogs are also enabled if this is
4952 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4953 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4954 This applies to commands from menus and tool bar buttons even when
4955 they are initiated from the keyboard. If `use-dialog-box' is nil,
4956 that disables the use of a file dialog, regardless of the value of
4958 use_file_dialog
= 1;
4960 defsubr (&Sidentity
);
4963 defsubr (&Ssafe_length
);
4964 defsubr (&Sstring_bytes
);
4965 defsubr (&Sstring_equal
);
4966 defsubr (&Scompare_strings
);
4967 defsubr (&Sstring_lessp
);
4970 defsubr (&Svconcat
);
4971 defsubr (&Scopy_sequence
);
4972 defsubr (&Sstring_make_multibyte
);
4973 defsubr (&Sstring_make_unibyte
);
4974 defsubr (&Sstring_as_multibyte
);
4975 defsubr (&Sstring_as_unibyte
);
4976 defsubr (&Sstring_to_multibyte
);
4977 defsubr (&Sstring_to_unibyte
);
4978 defsubr (&Scopy_alist
);
4979 defsubr (&Ssubstring
);
4980 defsubr (&Ssubstring_no_properties
);
4993 defsubr (&Snreverse
);
4994 defsubr (&Sreverse
);
4996 defsubr (&Splist_get
);
4998 defsubr (&Splist_put
);
5000 defsubr (&Slax_plist_get
);
5001 defsubr (&Slax_plist_put
);
5004 defsubr (&Sequal_including_properties
);
5005 defsubr (&Sfillarray
);
5006 defsubr (&Sclear_string
);
5010 defsubr (&Smapconcat
);
5011 defsubr (&Syes_or_no_p
);
5012 defsubr (&Sload_average
);
5013 defsubr (&Sfeaturep
);
5014 defsubr (&Srequire
);
5015 defsubr (&Sprovide
);
5016 defsubr (&Splist_member
);
5017 defsubr (&Swidget_put
);
5018 defsubr (&Swidget_get
);
5019 defsubr (&Swidget_apply
);
5020 defsubr (&Sbase64_encode_region
);
5021 defsubr (&Sbase64_decode_region
);
5022 defsubr (&Sbase64_encode_string
);
5023 defsubr (&Sbase64_decode_string
);
5025 defsubr (&Ssecure_hash
);
5026 defsubr (&Slocale_info
);
5028 hashtest_eq
.name
= Qeq
;
5029 hashtest_eq
.user_hash_function
= Qnil
;
5030 hashtest_eq
.user_cmp_function
= Qnil
;
5031 hashtest_eq
.cmpfn
= 0;
5032 hashtest_eq
.hashfn
= hashfn_eq
;
5034 hashtest_eql
.name
= Qeql
;
5035 hashtest_eql
.user_hash_function
= Qnil
;
5036 hashtest_eql
.user_cmp_function
= Qnil
;
5037 hashtest_eql
.cmpfn
= cmpfn_eql
;
5038 hashtest_eql
.hashfn
= hashfn_eql
;
5040 hashtest_equal
.name
= Qequal
;
5041 hashtest_equal
.user_hash_function
= Qnil
;
5042 hashtest_equal
.user_cmp_function
= Qnil
;
5043 hashtest_equal
.cmpfn
= cmpfn_equal
;
5044 hashtest_equal
.hashfn
= hashfn_equal
;