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_atomic (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 if (STRINGP (string
))
1155 size
= SCHARS (string
);
1156 else if (VECTORP (string
))
1157 size
= ASIZE (string
);
1159 wrong_type_argument (Qarrayp
, string
);
1161 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1163 if (STRINGP (string
))
1166 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1168 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1169 res
= make_specified_string (SSDATA (string
) + from_byte
,
1170 ito
- ifrom
, to_byte
- from_byte
,
1171 STRING_MULTIBYTE (string
));
1172 copy_text_properties (make_number (ifrom
), make_number (ito
),
1173 string
, make_number (0), res
, Qnil
);
1176 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1182 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1183 doc
: /* Return a substring of STRING, without text properties.
1184 It starts at index FROM and ends before TO.
1185 TO may be nil or omitted; then the substring runs to the end of STRING.
1186 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1187 If FROM or TO is negative, it counts from the end.
1189 With one argument, just copy STRING without its properties. */)
1190 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1192 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1194 CHECK_STRING (string
);
1196 size
= SCHARS (string
);
1197 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1199 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1201 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1202 return make_specified_string (SSDATA (string
) + from_byte
,
1203 to_char
- from_char
, to_byte
- from_byte
,
1204 STRING_MULTIBYTE (string
));
1207 /* Extract a substring of STRING, giving start and end positions
1208 both in characters and in bytes. */
1211 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1212 ptrdiff_t to
, ptrdiff_t to_byte
)
1217 CHECK_VECTOR_OR_STRING (string
);
1219 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1221 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1222 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1224 if (STRINGP (string
))
1226 res
= make_specified_string (SSDATA (string
) + from_byte
,
1227 to
- from
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1229 copy_text_properties (make_number (from
), make_number (to
),
1230 string
, make_number (0), res
, Qnil
);
1233 res
= Fvector (to
- from
, aref_addr (string
, from
));
1238 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1239 doc
: /* Take cdr N times on LIST, return the result. */)
1240 (Lisp_Object n
, Lisp_Object list
)
1245 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1248 CHECK_LIST_CONS (list
, list
);
1254 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1255 doc
: /* Return the Nth element of LIST.
1256 N counts from zero. If LIST is not that long, nil is returned. */)
1257 (Lisp_Object n
, Lisp_Object list
)
1259 return Fcar (Fnthcdr (n
, list
));
1262 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1263 doc
: /* Return element of SEQUENCE at index N. */)
1264 (register Lisp_Object sequence
, Lisp_Object n
)
1267 if (CONSP (sequence
) || NILP (sequence
))
1268 return Fcar (Fnthcdr (n
, sequence
));
1270 /* Faref signals a "not array" error, so check here. */
1271 CHECK_ARRAY (sequence
, Qsequencep
);
1272 return Faref (sequence
, n
);
1275 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1276 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1277 The value is actually the tail of LIST whose car is ELT. */)
1278 (register Lisp_Object elt
, Lisp_Object list
)
1280 register Lisp_Object tail
;
1281 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1283 register Lisp_Object tem
;
1284 CHECK_LIST_CONS (tail
, list
);
1286 if (! NILP (Fequal (elt
, tem
)))
1293 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1294 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1295 The value is actually the tail of LIST whose car is ELT. */)
1296 (register Lisp_Object elt
, Lisp_Object list
)
1300 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1304 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1308 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1319 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1320 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1321 The value is actually the tail of LIST whose car is ELT. */)
1322 (register Lisp_Object elt
, Lisp_Object list
)
1324 register Lisp_Object tail
;
1327 return Fmemq (elt
, list
);
1329 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1331 register Lisp_Object tem
;
1332 CHECK_LIST_CONS (tail
, list
);
1334 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1341 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1342 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1343 The value is actually the first element of LIST whose car is KEY.
1344 Elements of LIST that are not conses are ignored. */)
1345 (Lisp_Object key
, Lisp_Object list
)
1350 || (CONSP (XCAR (list
))
1351 && EQ (XCAR (XCAR (list
)), key
)))
1356 || (CONSP (XCAR (list
))
1357 && EQ (XCAR (XCAR (list
)), key
)))
1362 || (CONSP (XCAR (list
))
1363 && EQ (XCAR (XCAR (list
)), key
)))
1373 /* Like Fassq but never report an error and do not allow quits.
1374 Use only on lists known never to be circular. */
1377 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1380 && (!CONSP (XCAR (list
))
1381 || !EQ (XCAR (XCAR (list
)), key
)))
1384 return CAR_SAFE (list
);
1387 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1388 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1389 The value is actually the first element of LIST whose car equals KEY. */)
1390 (Lisp_Object key
, Lisp_Object list
)
1397 || (CONSP (XCAR (list
))
1398 && (car
= XCAR (XCAR (list
)),
1399 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1404 || (CONSP (XCAR (list
))
1405 && (car
= XCAR (XCAR (list
)),
1406 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1411 || (CONSP (XCAR (list
))
1412 && (car
= XCAR (XCAR (list
)),
1413 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1423 /* Like Fassoc but never report an error and do not allow quits.
1424 Use only on lists known never to be circular. */
1427 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1430 && (!CONSP (XCAR (list
))
1431 || (!EQ (XCAR (XCAR (list
)), key
)
1432 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1435 return CONSP (list
) ? XCAR (list
) : Qnil
;
1438 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1439 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1440 The value is actually the first element of LIST whose cdr is KEY. */)
1441 (register Lisp_Object key
, Lisp_Object list
)
1446 || (CONSP (XCAR (list
))
1447 && EQ (XCDR (XCAR (list
)), key
)))
1452 || (CONSP (XCAR (list
))
1453 && EQ (XCDR (XCAR (list
)), key
)))
1458 || (CONSP (XCAR (list
))
1459 && EQ (XCDR (XCAR (list
)), key
)))
1469 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1470 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1471 The value is actually the first element of LIST whose cdr equals KEY. */)
1472 (Lisp_Object key
, Lisp_Object list
)
1479 || (CONSP (XCAR (list
))
1480 && (cdr
= XCDR (XCAR (list
)),
1481 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1486 || (CONSP (XCAR (list
))
1487 && (cdr
= XCDR (XCAR (list
)),
1488 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1493 || (CONSP (XCAR (list
))
1494 && (cdr
= XCDR (XCAR (list
)),
1495 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1505 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1506 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1507 More precisely, this function skips any members `eq' to ELT at the
1508 front of LIST, then removes members `eq' to ELT from the remaining
1509 sublist by modifying its list structure, then returns the resulting
1512 Write `(setq foo (delq element foo))' to be sure of correctly changing
1513 the value of a list `foo'. */)
1514 (register Lisp_Object elt
, Lisp_Object list
)
1516 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1519 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1521 Lisp_Object tem
= XCAR (tail
);
1527 Fsetcdr (prev
, XCDR (tail
));
1535 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1536 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1537 SEQ must be a sequence (i.e. a list, a vector, or a string).
1538 The return value is a sequence of the same type.
1540 If SEQ is a list, this behaves like `delq', except that it compares
1541 with `equal' instead of `eq'. In particular, it may remove elements
1542 by altering the list structure.
1544 If SEQ is not a list, deletion is never performed destructively;
1545 instead this function creates and returns a new vector or string.
1547 Write `(setq foo (delete element foo))' to be sure of correctly
1548 changing the value of a sequence `foo'. */)
1549 (Lisp_Object elt
, Lisp_Object seq
)
1555 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1556 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1559 if (n
!= ASIZE (seq
))
1561 struct Lisp_Vector
*p
= allocate_vector (n
);
1563 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1564 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1565 p
->contents
[n
++] = AREF (seq
, i
);
1567 XSETVECTOR (seq
, p
);
1570 else if (STRINGP (seq
))
1572 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1575 for (i
= nchars
= nbytes
= ibyte
= 0;
1577 ++i
, ibyte
+= cbytes
)
1579 if (STRING_MULTIBYTE (seq
))
1581 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1582 cbytes
= CHAR_BYTES (c
);
1590 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1597 if (nchars
!= SCHARS (seq
))
1601 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1602 if (!STRING_MULTIBYTE (seq
))
1603 STRING_SET_UNIBYTE (tem
);
1605 for (i
= nchars
= nbytes
= ibyte
= 0;
1607 ++i
, ibyte
+= cbytes
)
1609 if (STRING_MULTIBYTE (seq
))
1611 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1612 cbytes
= CHAR_BYTES (c
);
1620 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1622 unsigned char *from
= SDATA (seq
) + ibyte
;
1623 unsigned char *to
= SDATA (tem
) + nbytes
;
1629 for (n
= cbytes
; n
--; )
1639 Lisp_Object tail
, prev
;
1641 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1643 CHECK_LIST_CONS (tail
, seq
);
1645 if (!NILP (Fequal (elt
, XCAR (tail
))))
1650 Fsetcdr (prev
, XCDR (tail
));
1661 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1662 doc
: /* Reverse order of items in a list, vector or string SEQ.
1663 If SEQ is a list, it should be nil-terminated.
1664 This function may destructively modify SEQ to produce the value. */)
1669 else if (STRINGP (seq
))
1670 return Freverse (seq
);
1671 else if (CONSP (seq
))
1673 Lisp_Object prev
, tail
, next
;
1675 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1678 CHECK_LIST_CONS (tail
, tail
);
1680 Fsetcdr (tail
, prev
);
1685 else if (VECTORP (seq
))
1687 ptrdiff_t i
, size
= ASIZE (seq
);
1689 for (i
= 0; i
< size
/ 2; i
++)
1691 Lisp_Object tem
= AREF (seq
, i
);
1692 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1693 ASET (seq
, size
- i
- 1, tem
);
1696 else if (BOOL_VECTOR_P (seq
))
1698 ptrdiff_t i
, size
= bool_vector_size (seq
);
1700 for (i
= 0; i
< size
/ 2; i
++)
1702 bool tem
= bool_vector_bitref (seq
, i
);
1703 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1704 bool_vector_set (seq
, size
- i
- 1, tem
);
1708 wrong_type_argument (Qarrayp
, seq
);
1712 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1713 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1714 See also the function `nreverse', which is used more often. */)
1721 else if (CONSP (seq
))
1723 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1726 new = Fcons (XCAR (seq
), new);
1728 CHECK_LIST_END (seq
, seq
);
1730 else if (VECTORP (seq
))
1732 ptrdiff_t i
, size
= ASIZE (seq
);
1734 new = make_uninit_vector (size
);
1735 for (i
= 0; i
< size
; i
++)
1736 ASET (new, i
, AREF (seq
, size
- i
- 1));
1738 else if (BOOL_VECTOR_P (seq
))
1741 EMACS_INT nbits
= bool_vector_size (seq
);
1743 new = make_uninit_bool_vector (nbits
);
1744 for (i
= 0; i
< nbits
; i
++)
1745 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1747 else if (STRINGP (seq
))
1749 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1755 new = make_uninit_string (size
);
1756 for (i
= 0; i
< size
; i
++)
1757 SSET (new, i
, SREF (seq
, size
- i
- 1));
1761 unsigned char *p
, *q
;
1763 new = make_uninit_multibyte_string (size
, bytes
);
1764 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1765 while (q
> SDATA (new))
1769 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1771 CHAR_STRING (ch
, q
);
1776 wrong_type_argument (Qsequencep
, seq
);
1780 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1781 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1782 Returns the sorted list. LIST is modified by side effects.
1783 PREDICATE is called with two elements of LIST, and should return non-nil
1784 if the first element should sort before the second. */)
1785 (Lisp_Object list
, Lisp_Object predicate
)
1787 Lisp_Object front
, back
;
1788 register Lisp_Object len
, tem
;
1789 struct gcpro gcpro1
, gcpro2
;
1793 len
= Flength (list
);
1794 length
= XINT (len
);
1798 XSETINT (len
, (length
/ 2) - 1);
1799 tem
= Fnthcdr (len
, list
);
1801 Fsetcdr (tem
, Qnil
);
1803 GCPRO2 (front
, back
);
1804 front
= Fsort (front
, predicate
);
1805 back
= Fsort (back
, predicate
);
1807 return merge (front
, back
, predicate
);
1811 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1814 register Lisp_Object tail
;
1816 register Lisp_Object l1
, l2
;
1817 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1824 /* It is sufficient to protect org_l1 and org_l2.
1825 When l1 and l2 are updated, we copy the new values
1826 back into the org_ vars. */
1827 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1847 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1863 Fsetcdr (tail
, tem
);
1869 /* This does not check for quits. That is safe since it must terminate. */
1871 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1872 doc
: /* Extract a value from a property list.
1873 PLIST is a property list, which is a list of the form
1874 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1875 corresponding to the given PROP, or nil if PROP is not one of the
1876 properties on the list. This function never signals an error. */)
1877 (Lisp_Object plist
, Lisp_Object prop
)
1879 Lisp_Object tail
, halftail
;
1881 /* halftail is used to detect circular lists. */
1882 tail
= halftail
= plist
;
1883 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1885 if (EQ (prop
, XCAR (tail
)))
1886 return XCAR (XCDR (tail
));
1888 tail
= XCDR (XCDR (tail
));
1889 halftail
= XCDR (halftail
);
1890 if (EQ (tail
, halftail
))
1897 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1898 doc
: /* Return the value of SYMBOL's PROPNAME property.
1899 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1900 (Lisp_Object symbol
, Lisp_Object propname
)
1902 CHECK_SYMBOL (symbol
);
1903 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1906 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1907 doc
: /* Change value in PLIST of PROP to VAL.
1908 PLIST is a property list, which is a list of the form
1909 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1910 If PROP is already a property on the list, its value is set to VAL,
1911 otherwise the new PROP VAL pair is added. The new plist is returned;
1912 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1913 The PLIST is modified by side effects. */)
1914 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1916 register Lisp_Object tail
, prev
;
1917 Lisp_Object newcell
;
1919 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1920 tail
= XCDR (XCDR (tail
)))
1922 if (EQ (prop
, XCAR (tail
)))
1924 Fsetcar (XCDR (tail
), val
);
1931 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1935 Fsetcdr (XCDR (prev
), newcell
);
1939 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1940 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1941 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1942 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1944 CHECK_SYMBOL (symbol
);
1946 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1950 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1951 doc
: /* Extract a value from a property list, comparing with `equal'.
1952 PLIST is a property list, which is a list of the form
1953 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1954 corresponding to the given PROP, or nil if PROP is not
1955 one of the properties on the list. */)
1956 (Lisp_Object plist
, Lisp_Object prop
)
1961 CONSP (tail
) && CONSP (XCDR (tail
));
1962 tail
= XCDR (XCDR (tail
)))
1964 if (! NILP (Fequal (prop
, XCAR (tail
))))
1965 return XCAR (XCDR (tail
));
1970 CHECK_LIST_END (tail
, prop
);
1975 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1976 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1977 PLIST is a property list, which is a list of the form
1978 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1979 If PROP is already a property on the list, its value is set to VAL,
1980 otherwise the new PROP VAL pair is added. The new plist is returned;
1981 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1982 The PLIST is modified by side effects. */)
1983 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1985 register Lisp_Object tail
, prev
;
1986 Lisp_Object newcell
;
1988 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1989 tail
= XCDR (XCDR (tail
)))
1991 if (! NILP (Fequal (prop
, XCAR (tail
))))
1993 Fsetcar (XCDR (tail
), val
);
2000 newcell
= list2 (prop
, val
);
2004 Fsetcdr (XCDR (prev
), newcell
);
2008 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2009 doc
: /* Return t if the two args are the same Lisp object.
2010 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2011 (Lisp_Object obj1
, Lisp_Object obj2
)
2014 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2016 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2019 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2020 doc
: /* Return t if two Lisp objects have similar structure and contents.
2021 They must have the same data type.
2022 Conses are compared by comparing the cars and the cdrs.
2023 Vectors and strings are compared element by element.
2024 Numbers are compared by value, but integers cannot equal floats.
2025 (Use `=' if you want integers and floats to be able to be equal.)
2026 Symbols must match exactly. */)
2027 (register Lisp_Object o1
, Lisp_Object o2
)
2029 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2032 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2033 doc
: /* Return t if two Lisp objects have similar structure and contents.
2034 This is like `equal' except that it compares the text properties
2035 of strings. (`equal' ignores text properties.) */)
2036 (register Lisp_Object o1
, Lisp_Object o2
)
2038 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2041 /* DEPTH is current depth of recursion. Signal an error if it
2043 PROPS means compare string text properties too. */
2046 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2052 error ("Stack overflow in equal");
2055 Lisp_Object args
[2];
2058 ht
= Fmake_hash_table (2, args
);
2062 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2064 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2066 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2068 { /* `o1' was seen already. */
2069 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2070 if (!NILP (Fmemq (o2
, o2s
)))
2073 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2076 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2086 if (XTYPE (o1
) != XTYPE (o2
))
2095 d1
= extract_float (o1
);
2096 d2
= extract_float (o2
);
2097 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2098 though they are not =. */
2099 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2103 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2107 /* FIXME: This inf-loops in a circular list! */
2111 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2115 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2116 depth
+ 1, props
, ht
)
2117 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2118 depth
+ 1, props
, ht
))
2120 o1
= XOVERLAY (o1
)->plist
;
2121 o2
= XOVERLAY (o2
)->plist
;
2126 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2127 && (XMARKER (o1
)->buffer
== 0
2128 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2132 case Lisp_Vectorlike
:
2135 ptrdiff_t size
= ASIZE (o1
);
2136 /* Pseudovectors have the type encoded in the size field, so this test
2137 actually checks that the objects have the same type as well as the
2139 if (ASIZE (o2
) != size
)
2141 /* Boolvectors are compared much like strings. */
2142 if (BOOL_VECTOR_P (o1
))
2144 EMACS_INT size
= bool_vector_size (o1
);
2145 if (size
!= bool_vector_size (o2
))
2147 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2148 bool_vector_bytes (size
)))
2152 if (WINDOW_CONFIGURATIONP (o1
))
2153 return compare_window_configurations (o1
, o2
, 0);
2155 /* Aside from them, only true vectors, char-tables, compiled
2156 functions, and fonts (font-spec, font-entity, font-object)
2157 are sensible to compare, so eliminate the others now. */
2158 if (size
& PSEUDOVECTOR_FLAG
)
2160 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2163 size
&= PSEUDOVECTOR_SIZE_MASK
;
2165 for (i
= 0; i
< size
; i
++)
2170 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2178 if (SCHARS (o1
) != SCHARS (o2
))
2180 if (SBYTES (o1
) != SBYTES (o2
))
2182 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2184 if (props
&& !compare_string_intervals (o1
, o2
))
2196 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2197 doc
: /* Store each element of ARRAY with ITEM.
2198 ARRAY is a vector, string, char-table, or bool-vector. */)
2199 (Lisp_Object array
, Lisp_Object item
)
2201 register ptrdiff_t size
, idx
;
2203 if (VECTORP (array
))
2204 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2205 ASET (array
, idx
, item
);
2206 else if (CHAR_TABLE_P (array
))
2210 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2211 set_char_table_contents (array
, i
, item
);
2212 set_char_table_defalt (array
, item
);
2214 else if (STRINGP (array
))
2216 register unsigned char *p
= SDATA (array
);
2218 CHECK_CHARACTER (item
);
2219 charval
= XFASTINT (item
);
2220 size
= SCHARS (array
);
2221 if (STRING_MULTIBYTE (array
))
2223 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2224 int len
= CHAR_STRING (charval
, str
);
2225 ptrdiff_t size_byte
= SBYTES (array
);
2227 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2228 || SCHARS (array
) * len
!= size_byte
)
2229 error ("Attempt to change byte length of a string");
2230 for (idx
= 0; idx
< size_byte
; idx
++)
2231 *p
++ = str
[idx
% len
];
2234 for (idx
= 0; idx
< size
; idx
++)
2237 else if (BOOL_VECTOR_P (array
))
2238 return bool_vector_fill (array
, item
);
2240 wrong_type_argument (Qarrayp
, array
);
2244 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2246 doc
: /* Clear the contents of STRING.
2247 This makes STRING unibyte and may change its length. */)
2248 (Lisp_Object string
)
2251 CHECK_STRING (string
);
2252 len
= SBYTES (string
);
2253 memset (SDATA (string
), 0, len
);
2254 STRING_SET_CHARS (string
, len
);
2255 STRING_SET_UNIBYTE (string
);
2261 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2263 Lisp_Object args
[2];
2266 return Fnconc (2, args
);
2269 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2270 doc
: /* Concatenate any number of lists by altering them.
2271 Only the last argument is not altered, and need not be a list.
2272 usage: (nconc &rest LISTS) */)
2273 (ptrdiff_t nargs
, Lisp_Object
*args
)
2276 register Lisp_Object tail
, tem
, val
;
2280 for (argnum
= 0; argnum
< nargs
; argnum
++)
2283 if (NILP (tem
)) continue;
2288 if (argnum
+ 1 == nargs
) break;
2290 CHECK_LIST_CONS (tem
, tem
);
2299 tem
= args
[argnum
+ 1];
2300 Fsetcdr (tail
, tem
);
2302 args
[argnum
+ 1] = tail
;
2308 /* This is the guts of all mapping functions.
2309 Apply FN to each element of SEQ, one by one,
2310 storing the results into elements of VALS, a C vector of Lisp_Objects.
2311 LENI is the length of VALS, which should also be the length of SEQ. */
2314 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2316 register Lisp_Object tail
;
2318 register EMACS_INT i
;
2319 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2323 /* Don't let vals contain any garbage when GC happens. */
2324 for (i
= 0; i
< leni
; i
++)
2327 GCPRO3 (dummy
, fn
, seq
);
2329 gcpro1
.nvars
= leni
;
2333 /* We need not explicitly protect `tail' because it is used only on lists, and
2334 1) lists are not relocated and 2) the list is marked via `seq' so will not
2337 if (VECTORP (seq
) || COMPILEDP (seq
))
2339 for (i
= 0; i
< leni
; i
++)
2341 dummy
= call1 (fn
, AREF (seq
, i
));
2346 else if (BOOL_VECTOR_P (seq
))
2348 for (i
= 0; i
< leni
; i
++)
2350 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2355 else if (STRINGP (seq
))
2359 for (i
= 0, i_byte
= 0; i
< leni
;)
2362 ptrdiff_t i_before
= i
;
2364 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2365 XSETFASTINT (dummy
, c
);
2366 dummy
= call1 (fn
, dummy
);
2368 vals
[i_before
] = dummy
;
2371 else /* Must be a list, since Flength did not get an error */
2374 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2376 dummy
= call1 (fn
, XCAR (tail
));
2386 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2387 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2388 In between each pair of results, stick in SEPARATOR. Thus, " " as
2389 SEPARATOR results in spaces between the values returned by FUNCTION.
2390 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2391 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2394 register EMACS_INT leni
;
2397 register Lisp_Object
*args
;
2398 struct gcpro gcpro1
;
2402 len
= Flength (sequence
);
2403 if (CHAR_TABLE_P (sequence
))
2404 wrong_type_argument (Qlistp
, sequence
);
2406 nargs
= leni
+ leni
- 1;
2407 if (nargs
< 0) return empty_unibyte_string
;
2409 SAFE_ALLOCA_LISP (args
, nargs
);
2412 mapcar1 (leni
, args
, function
, sequence
);
2415 for (i
= leni
- 1; i
> 0; i
--)
2416 args
[i
+ i
] = args
[i
];
2418 for (i
= 1; i
< nargs
; i
+= 2)
2419 args
[i
] = separator
;
2421 ret
= Fconcat (nargs
, args
);
2427 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2428 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2429 The result is a list just as long as SEQUENCE.
2430 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2431 (Lisp_Object function
, Lisp_Object sequence
)
2433 register Lisp_Object len
;
2434 register EMACS_INT leni
;
2435 register Lisp_Object
*args
;
2439 len
= Flength (sequence
);
2440 if (CHAR_TABLE_P (sequence
))
2441 wrong_type_argument (Qlistp
, sequence
);
2442 leni
= XFASTINT (len
);
2444 SAFE_ALLOCA_LISP (args
, leni
);
2446 mapcar1 (leni
, args
, function
, sequence
);
2448 ret
= Flist (leni
, args
);
2454 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2455 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2456 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2457 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2458 (Lisp_Object function
, Lisp_Object sequence
)
2460 register EMACS_INT leni
;
2462 leni
= XFASTINT (Flength (sequence
));
2463 if (CHAR_TABLE_P (sequence
))
2464 wrong_type_argument (Qlistp
, sequence
);
2465 mapcar1 (leni
, 0, function
, sequence
);
2470 /* This is how C code calls `yes-or-no-p' and allows the user
2473 Anything that calls this function must protect from GC! */
2476 do_yes_or_no_p (Lisp_Object prompt
)
2478 return call1 (intern ("yes-or-no-p"), prompt
);
2481 /* Anything that calls this function must protect from GC! */
2483 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2484 doc
: /* Ask user a yes-or-no question.
2485 Return t if answer is yes, and nil if the answer is no.
2486 PROMPT is the string to display to ask the question. It should end in
2487 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2489 The user must confirm the answer with RET, and can edit it until it
2492 If dialog boxes are supported, a dialog box will be used
2493 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2494 (Lisp_Object prompt
)
2496 register Lisp_Object ans
;
2497 Lisp_Object args
[2];
2498 struct gcpro gcpro1
;
2500 CHECK_STRING (prompt
);
2502 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2505 Lisp_Object pane
, menu
, obj
;
2506 redisplay_preserve_echo_area (4);
2507 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2508 Fcons (build_string ("No"), Qnil
));
2510 menu
= Fcons (prompt
, pane
);
2511 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2517 args
[1] = build_string ("(yes or no) ");
2518 prompt
= Fconcat (2, args
);
2524 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2525 Qyes_or_no_p_history
, Qnil
,
2527 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2532 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2540 message1 ("Please answer yes or no.");
2541 Fsleep_for (make_number (2), Qnil
);
2545 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2546 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2548 Each of the three load averages is multiplied by 100, then converted
2551 When USE-FLOATS is non-nil, floats will be used instead of integers.
2552 These floats are not multiplied by 100.
2554 If the 5-minute or 15-minute load averages are not available, return a
2555 shortened list, containing only those averages which are available.
2557 An error is thrown if the load average can't be obtained. In some
2558 cases making it work would require Emacs being installed setuid or
2559 setgid so that it can read kernel information, and that usually isn't
2561 (Lisp_Object use_floats
)
2564 int loads
= getloadavg (load_ave
, 3);
2565 Lisp_Object ret
= Qnil
;
2568 error ("load-average not implemented for this operating system");
2572 Lisp_Object load
= (NILP (use_floats
)
2573 ? make_number (100.0 * load_ave
[loads
])
2574 : make_float (load_ave
[loads
]));
2575 ret
= Fcons (load
, ret
);
2581 static Lisp_Object Qsubfeatures
;
2583 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2584 doc
: /* Return t if FEATURE is present in this Emacs.
2586 Use this to conditionalize execution of lisp code based on the
2587 presence or absence of Emacs or environment extensions.
2588 Use `provide' to declare that a feature is available. This function
2589 looks at the value of the variable `features'. The optional argument
2590 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2591 (Lisp_Object feature
, Lisp_Object subfeature
)
2593 register Lisp_Object tem
;
2594 CHECK_SYMBOL (feature
);
2595 tem
= Fmemq (feature
, Vfeatures
);
2596 if (!NILP (tem
) && !NILP (subfeature
))
2597 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2598 return (NILP (tem
)) ? Qnil
: Qt
;
2601 static Lisp_Object Qfuncall
;
2603 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2604 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2605 The optional argument SUBFEATURES should be a list of symbols listing
2606 particular subfeatures supported in this version of FEATURE. */)
2607 (Lisp_Object feature
, Lisp_Object subfeatures
)
2609 register Lisp_Object tem
;
2610 CHECK_SYMBOL (feature
);
2611 CHECK_LIST (subfeatures
);
2612 if (!NILP (Vautoload_queue
))
2613 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2615 tem
= Fmemq (feature
, Vfeatures
);
2617 Vfeatures
= Fcons (feature
, Vfeatures
);
2618 if (!NILP (subfeatures
))
2619 Fput (feature
, Qsubfeatures
, subfeatures
);
2620 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2622 /* Run any load-hooks for this file. */
2623 tem
= Fassq (feature
, Vafter_load_alist
);
2625 Fmapc (Qfuncall
, XCDR (tem
));
2630 /* `require' and its subroutines. */
2632 /* List of features currently being require'd, innermost first. */
2634 static Lisp_Object require_nesting_list
;
2637 require_unwind (Lisp_Object old_value
)
2639 require_nesting_list
= old_value
;
2642 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2643 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2644 If FEATURE is not a member of the list `features', then the feature
2645 is not loaded; so load the file FILENAME.
2646 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2647 and `load' will try to load this name appended with the suffix `.elc' or
2648 `.el', in that order. The name without appended suffix will not be used.
2649 See `get-load-suffixes' for the complete list of suffixes.
2650 If the optional third argument NOERROR is non-nil,
2651 then return nil if the file is not found instead of signaling an error.
2652 Normally the return value is FEATURE.
2653 The normal messages at start and end of loading FILENAME are suppressed. */)
2654 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2657 struct gcpro gcpro1
, gcpro2
;
2658 bool from_file
= load_in_progress
;
2660 CHECK_SYMBOL (feature
);
2662 /* Record the presence of `require' in this file
2663 even if the feature specified is already loaded.
2664 But not more than once in any file,
2665 and not when we aren't loading or reading from a file. */
2667 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2668 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2673 tem
= Fcons (Qrequire
, feature
);
2674 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2675 LOADHIST_ATTACH (tem
);
2677 tem
= Fmemq (feature
, Vfeatures
);
2681 ptrdiff_t count
= SPECPDL_INDEX ();
2684 /* This is to make sure that loadup.el gives a clear picture
2685 of what files are preloaded and when. */
2686 if (! NILP (Vpurify_flag
))
2687 error ("(require %s) while preparing to dump",
2688 SDATA (SYMBOL_NAME (feature
)));
2690 /* A certain amount of recursive `require' is legitimate,
2691 but if we require the same feature recursively 3 times,
2693 tem
= require_nesting_list
;
2694 while (! NILP (tem
))
2696 if (! NILP (Fequal (feature
, XCAR (tem
))))
2701 error ("Recursive `require' for feature `%s'",
2702 SDATA (SYMBOL_NAME (feature
)));
2704 /* Update the list for any nested `require's that occur. */
2705 record_unwind_protect (require_unwind
, require_nesting_list
);
2706 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2708 /* Value saved here is to be restored into Vautoload_queue */
2709 record_unwind_protect (un_autoload
, Vautoload_queue
);
2710 Vautoload_queue
= Qt
;
2712 /* Load the file. */
2713 GCPRO2 (feature
, filename
);
2714 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2715 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2718 /* If load failed entirely, return nil. */
2720 return unbind_to (count
, Qnil
);
2722 tem
= Fmemq (feature
, Vfeatures
);
2724 error ("Required feature `%s' was not provided",
2725 SDATA (SYMBOL_NAME (feature
)));
2727 /* Once loading finishes, don't undo it. */
2728 Vautoload_queue
= Qt
;
2729 feature
= unbind_to (count
, feature
);
2735 /* Primitives for work of the "widget" library.
2736 In an ideal world, this section would not have been necessary.
2737 However, lisp function calls being as slow as they are, it turns
2738 out that some functions in the widget library (wid-edit.el) are the
2739 bottleneck of Widget operation. Here is their translation to C,
2740 for the sole reason of efficiency. */
2742 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2743 doc
: /* Return non-nil if PLIST has the property PROP.
2744 PLIST is a property list, which is a list of the form
2745 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2746 Unlike `plist-get', this allows you to distinguish between a missing
2747 property and a property with the value nil.
2748 The value is actually the tail of PLIST whose car is PROP. */)
2749 (Lisp_Object plist
, Lisp_Object prop
)
2751 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2754 plist
= XCDR (plist
);
2755 plist
= CDR (plist
);
2760 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2761 doc
: /* In WIDGET, set PROPERTY to VALUE.
2762 The value can later be retrieved with `widget-get'. */)
2763 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2765 CHECK_CONS (widget
);
2766 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2770 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2771 doc
: /* In WIDGET, get the value of PROPERTY.
2772 The value could either be specified when the widget was created, or
2773 later with `widget-put'. */)
2774 (Lisp_Object widget
, Lisp_Object property
)
2782 CHECK_CONS (widget
);
2783 tmp
= Fplist_member (XCDR (widget
), property
);
2789 tmp
= XCAR (widget
);
2792 widget
= Fget (tmp
, Qwidget_type
);
2796 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2797 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2798 ARGS are passed as extra arguments to the function.
2799 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2800 (ptrdiff_t nargs
, Lisp_Object
*args
)
2802 /* This function can GC. */
2803 Lisp_Object newargs
[3];
2804 struct gcpro gcpro1
, gcpro2
;
2807 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2808 newargs
[1] = args
[0];
2809 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2810 GCPRO2 (newargs
[0], newargs
[2]);
2811 result
= Fapply (3, newargs
);
2816 #ifdef HAVE_LANGINFO_CODESET
2817 #include <langinfo.h>
2820 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2821 doc
: /* Access locale data ITEM for the current C locale, if available.
2822 ITEM should be one of the following:
2824 `codeset', returning the character set as a string (locale item CODESET);
2826 `days', returning a 7-element vector of day names (locale items DAY_n);
2828 `months', returning a 12-element vector of month names (locale items MON_n);
2830 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2831 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2833 If the system can't provide such information through a call to
2834 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2836 See also Info node `(libc)Locales'.
2838 The data read from the system are decoded using `locale-coding-system'. */)
2842 #ifdef HAVE_LANGINFO_CODESET
2844 if (EQ (item
, Qcodeset
))
2846 str
= nl_langinfo (CODESET
);
2847 return build_string (str
);
2850 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2852 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2853 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2855 struct gcpro gcpro1
;
2857 synchronize_system_time_locale ();
2858 for (i
= 0; i
< 7; i
++)
2860 str
= nl_langinfo (days
[i
]);
2861 val
= build_unibyte_string (str
);
2862 /* Fixme: Is this coding system necessarily right, even if
2863 it is consistent with CODESET? If not, what to do? */
2864 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2872 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2874 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2875 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2876 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2878 struct gcpro gcpro1
;
2880 synchronize_system_time_locale ();
2881 for (i
= 0; i
< 12; i
++)
2883 str
= nl_langinfo (months
[i
]);
2884 val
= build_unibyte_string (str
);
2885 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2892 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2893 but is in the locale files. This could be used by ps-print. */
2895 else if (EQ (item
, Qpaper
))
2896 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2897 #endif /* PAPER_WIDTH */
2898 #endif /* HAVE_LANGINFO_CODESET*/
2902 /* base64 encode/decode functions (RFC 2045).
2903 Based on code from GNU recode. */
2905 #define MIME_LINE_LENGTH 76
2907 #define IS_ASCII(Character) \
2909 #define IS_BASE64(Character) \
2910 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2911 #define IS_BASE64_IGNORABLE(Character) \
2912 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2913 || (Character) == '\f' || (Character) == '\r')
2915 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2916 character or return retval if there are no characters left to
2918 #define READ_QUADRUPLET_BYTE(retval) \
2923 if (nchars_return) \
2924 *nchars_return = nchars; \
2929 while (IS_BASE64_IGNORABLE (c))
2931 /* Table of characters coding the 64 values. */
2932 static const char base64_value_to_char
[64] =
2934 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2935 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2936 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2937 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2938 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2939 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2940 '8', '9', '+', '/' /* 60-63 */
2943 /* Table of base64 values for first 128 characters. */
2944 static const short base64_char_to_value
[128] =
2946 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2947 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2948 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2949 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2950 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2951 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2952 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2953 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2954 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2955 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2956 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2957 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2958 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2961 /* The following diagram shows the logical steps by which three octets
2962 get transformed into four base64 characters.
2964 .--------. .--------. .--------.
2965 |aaaaaabb| |bbbbcccc| |ccdddddd|
2966 `--------' `--------' `--------'
2968 .--------+--------+--------+--------.
2969 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2970 `--------+--------+--------+--------'
2972 .--------+--------+--------+--------.
2973 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2974 `--------+--------+--------+--------'
2976 The octets are divided into 6 bit chunks, which are then encoded into
2977 base64 characters. */
2980 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2981 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2984 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2986 doc
: /* Base64-encode the region between BEG and END.
2987 Return the length of the encoded text.
2988 Optional third argument NO-LINE-BREAK means do not break long lines
2989 into shorter lines. */)
2990 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2993 ptrdiff_t allength
, length
;
2994 ptrdiff_t ibeg
, iend
, encoded_length
;
2995 ptrdiff_t old_pos
= PT
;
2998 validate_region (&beg
, &end
);
3000 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3001 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3002 move_gap_both (XFASTINT (beg
), ibeg
);
3004 /* We need to allocate enough room for encoding the text.
3005 We need 33 1/3% more space, plus a newline every 76
3006 characters, and then we round up. */
3007 length
= iend
- ibeg
;
3008 allength
= length
+ length
/3 + 1;
3009 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3011 encoded
= SAFE_ALLOCA (allength
);
3012 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3013 encoded
, length
, NILP (no_line_break
),
3014 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3015 if (encoded_length
> allength
)
3018 if (encoded_length
< 0)
3020 /* The encoding wasn't possible. */
3022 error ("Multibyte character in data for base64 encoding");
3025 /* Now we have encoded the region, so we insert the new contents
3026 and delete the old. (Insert first in order to preserve markers.) */
3027 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3028 insert (encoded
, encoded_length
);
3030 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3032 /* If point was outside of the region, restore it exactly; else just
3033 move to the beginning of the region. */
3034 if (old_pos
>= XFASTINT (end
))
3035 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3036 else if (old_pos
> XFASTINT (beg
))
3037 old_pos
= XFASTINT (beg
);
3040 /* We return the length of the encoded text. */
3041 return make_number (encoded_length
);
3044 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3046 doc
: /* Base64-encode STRING and return the result.
3047 Optional second argument NO-LINE-BREAK means do not break long lines
3048 into shorter lines. */)
3049 (Lisp_Object string
, Lisp_Object no_line_break
)
3051 ptrdiff_t allength
, length
, encoded_length
;
3053 Lisp_Object encoded_string
;
3056 CHECK_STRING (string
);
3058 /* We need to allocate enough room for encoding the text.
3059 We need 33 1/3% more space, plus a newline every 76
3060 characters, and then we round up. */
3061 length
= SBYTES (string
);
3062 allength
= length
+ length
/3 + 1;
3063 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3065 /* We need to allocate enough room for decoding the text. */
3066 encoded
= SAFE_ALLOCA (allength
);
3068 encoded_length
= base64_encode_1 (SSDATA (string
),
3069 encoded
, length
, NILP (no_line_break
),
3070 STRING_MULTIBYTE (string
));
3071 if (encoded_length
> allength
)
3074 if (encoded_length
< 0)
3076 /* The encoding wasn't possible. */
3078 error ("Multibyte character in data for base64 encoding");
3081 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3084 return encoded_string
;
3088 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3089 bool line_break
, bool multibyte
)
3102 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3103 if (CHAR_BYTE8_P (c
))
3104 c
= CHAR_TO_BYTE8 (c
);
3112 /* Wrap line every 76 characters. */
3116 if (counter
< MIME_LINE_LENGTH
/ 4)
3125 /* Process first byte of a triplet. */
3127 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3128 value
= (0x03 & c
) << 4;
3130 /* Process second byte of a triplet. */
3134 *e
++ = base64_value_to_char
[value
];
3142 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3143 if (CHAR_BYTE8_P (c
))
3144 c
= CHAR_TO_BYTE8 (c
);
3152 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3153 value
= (0x0f & c
) << 2;
3155 /* Process third byte of a triplet. */
3159 *e
++ = base64_value_to_char
[value
];
3166 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3167 if (CHAR_BYTE8_P (c
))
3168 c
= CHAR_TO_BYTE8 (c
);
3176 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3177 *e
++ = base64_value_to_char
[0x3f & c
];
3184 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3186 doc
: /* Base64-decode the region between BEG and END.
3187 Return the length of the decoded text.
3188 If the region can't be decoded, signal an error and don't modify the buffer. */)
3189 (Lisp_Object beg
, Lisp_Object end
)
3191 ptrdiff_t ibeg
, iend
, length
, allength
;
3193 ptrdiff_t old_pos
= PT
;
3194 ptrdiff_t decoded_length
;
3195 ptrdiff_t inserted_chars
;
3196 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3199 validate_region (&beg
, &end
);
3201 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3202 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3204 length
= iend
- ibeg
;
3206 /* We need to allocate enough room for decoding the text. If we are
3207 working on a multibyte buffer, each decoded code may occupy at
3209 allength
= multibyte
? length
* 2 : length
;
3210 decoded
= SAFE_ALLOCA (allength
);
3212 move_gap_both (XFASTINT (beg
), ibeg
);
3213 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3215 multibyte
, &inserted_chars
);
3216 if (decoded_length
> allength
)
3219 if (decoded_length
< 0)
3221 /* The decoding wasn't possible. */
3223 error ("Invalid base64 data");
3226 /* Now we have decoded the region, so we insert the new contents
3227 and delete the old. (Insert first in order to preserve markers.) */
3228 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3229 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3232 /* Delete the original text. */
3233 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3234 iend
+ decoded_length
, 1);
3236 /* If point was outside of the region, restore it exactly; else just
3237 move to the beginning of the region. */
3238 if (old_pos
>= XFASTINT (end
))
3239 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3240 else if (old_pos
> XFASTINT (beg
))
3241 old_pos
= XFASTINT (beg
);
3242 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3244 return make_number (inserted_chars
);
3247 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3249 doc
: /* Base64-decode STRING and return the result. */)
3250 (Lisp_Object string
)
3253 ptrdiff_t length
, decoded_length
;
3254 Lisp_Object decoded_string
;
3257 CHECK_STRING (string
);
3259 length
= SBYTES (string
);
3260 /* We need to allocate enough room for decoding the text. */
3261 decoded
= SAFE_ALLOCA (length
);
3263 /* The decoded result should be unibyte. */
3264 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3266 if (decoded_length
> length
)
3268 else if (decoded_length
>= 0)
3269 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3271 decoded_string
= Qnil
;
3274 if (!STRINGP (decoded_string
))
3275 error ("Invalid base64 data");
3277 return decoded_string
;
3280 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3281 MULTIBYTE, the decoded result should be in multibyte
3282 form. If NCHARS_RETURN is not NULL, store the number of produced
3283 characters in *NCHARS_RETURN. */
3286 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3287 bool multibyte
, ptrdiff_t *nchars_return
)
3289 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3292 unsigned long value
;
3293 ptrdiff_t nchars
= 0;
3297 /* Process first byte of a quadruplet. */
3299 READ_QUADRUPLET_BYTE (e
-to
);
3303 value
= base64_char_to_value
[c
] << 18;
3305 /* Process second byte of a quadruplet. */
3307 READ_QUADRUPLET_BYTE (-1);
3311 value
|= base64_char_to_value
[c
] << 12;
3313 c
= (unsigned char) (value
>> 16);
3314 if (multibyte
&& c
>= 128)
3315 e
+= BYTE8_STRING (c
, e
);
3320 /* Process third byte of a quadruplet. */
3322 READ_QUADRUPLET_BYTE (-1);
3326 READ_QUADRUPLET_BYTE (-1);
3335 value
|= base64_char_to_value
[c
] << 6;
3337 c
= (unsigned char) (0xff & value
>> 8);
3338 if (multibyte
&& c
>= 128)
3339 e
+= BYTE8_STRING (c
, e
);
3344 /* Process fourth byte of a quadruplet. */
3346 READ_QUADRUPLET_BYTE (-1);
3353 value
|= base64_char_to_value
[c
];
3355 c
= (unsigned char) (0xff & value
);
3356 if (multibyte
&& c
>= 128)
3357 e
+= BYTE8_STRING (c
, e
);
3366 /***********************************************************************
3368 ***** Hash Tables *****
3370 ***********************************************************************/
3372 /* Implemented by gerd@gnu.org. This hash table implementation was
3373 inspired by CMUCL hash tables. */
3377 1. For small tables, association lists are probably faster than
3378 hash tables because they have lower overhead.
3380 For uses of hash tables where the O(1) behavior of table
3381 operations is not a requirement, it might therefore be a good idea
3382 not to hash. Instead, we could just do a linear search in the
3383 key_and_value vector of the hash table. This could be done
3384 if a `:linear-search t' argument is given to make-hash-table. */
3386 /* Various symbols. */
3388 static Lisp_Object Qhash_table_p
;
3389 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3390 Lisp_Object Qeq
, Qequal
;
3391 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3392 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3395 /***********************************************************************
3397 ***********************************************************************/
3400 CHECK_HASH_TABLE (Lisp_Object x
)
3402 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3406 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3408 h
->key_and_value
= key_and_value
;
3411 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3416 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3418 gc_aset (h
->next
, idx
, val
);
3421 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3426 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3428 gc_aset (h
->hash
, idx
, val
);
3431 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3436 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3438 gc_aset (h
->index
, idx
, val
);
3441 /* If OBJ is a Lisp hash table, return a pointer to its struct
3442 Lisp_Hash_Table. Otherwise, signal an error. */
3444 static struct Lisp_Hash_Table
*
3445 check_hash_table (Lisp_Object obj
)
3447 CHECK_HASH_TABLE (obj
);
3448 return XHASH_TABLE (obj
);
3452 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3453 number. A number is "almost" a prime number if it is not divisible
3454 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3457 next_almost_prime (EMACS_INT n
)
3459 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3460 for (n
|= 1; ; n
+= 2)
3461 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3466 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3467 which USED[I] is non-zero. If found at index I in ARGS, set
3468 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3469 0. This function is used to extract a keyword/argument pair from
3470 a DEFUN parameter list. */
3473 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3477 for (i
= 1; i
< nargs
; i
++)
3478 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3489 /* Return a Lisp vector which has the same contents as VEC but has
3490 at least INCR_MIN more entries, where INCR_MIN is positive.
3491 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3492 than NITEMS_MAX. Entries in the resulting
3493 vector that are not copied from VEC are set to nil. */
3496 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3498 struct Lisp_Vector
*v
;
3499 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3500 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3501 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3502 ? nitems_max
: C_language_max
);
3503 eassert (VECTORP (vec
));
3504 eassert (0 < incr_min
&& -1 <= nitems_max
);
3505 old_size
= ASIZE (vec
);
3506 incr_max
= n_max
- old_size
;
3507 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3508 if (incr_max
< incr
)
3509 memory_full (SIZE_MAX
);
3510 new_size
= old_size
+ incr
;
3511 v
= allocate_vector (new_size
);
3512 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3513 for (i
= old_size
; i
< new_size
; ++i
)
3514 v
->contents
[i
] = Qnil
;
3515 XSETVECTOR (vec
, v
);
3520 /***********************************************************************
3522 ***********************************************************************/
3524 static struct hash_table_test hashtest_eq
;
3525 struct hash_table_test hashtest_eql
, hashtest_equal
;
3527 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3528 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3529 KEY2 are the same. */
3532 cmpfn_eql (struct hash_table_test
*ht
,
3536 return (FLOATP (key1
)
3538 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3542 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3543 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3544 KEY2 are the same. */
3547 cmpfn_equal (struct hash_table_test
*ht
,
3551 return !NILP (Fequal (key1
, key2
));
3555 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3556 HASH2 in hash table H using H->user_cmp_function. Value is true
3557 if KEY1 and KEY2 are the same. */
3560 cmpfn_user_defined (struct hash_table_test
*ht
,
3564 Lisp_Object args
[3];
3566 args
[0] = ht
->user_cmp_function
;
3569 return !NILP (Ffuncall (3, args
));
3573 /* Value is a hash code for KEY for use in hash table H which uses
3574 `eq' to compare keys. The hash code returned is guaranteed to fit
3575 in a Lisp integer. */
3578 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3580 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3584 /* Value is a hash code for KEY for use in hash table H which uses
3585 `eql' to compare keys. The hash code returned is guaranteed to fit
3586 in a Lisp integer. */
3589 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3593 hash
= sxhash (key
, 0);
3595 hash
= XHASH (key
) ^ XTYPE (key
);
3599 /* Value is a hash code for KEY for use in hash table H which uses
3600 `equal' to compare keys. The hash code returned is guaranteed to fit
3601 in a Lisp integer. */
3604 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3606 EMACS_UINT hash
= sxhash (key
, 0);
3610 /* Value is a hash code for KEY for use in hash table H which uses as
3611 user-defined function to compare keys. The hash code returned is
3612 guaranteed to fit in a Lisp integer. */
3615 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3617 Lisp_Object args
[2], hash
;
3619 args
[0] = ht
->user_hash_function
;
3621 hash
= Ffuncall (2, args
);
3622 return hashfn_eq (ht
, hash
);
3625 /* An upper bound on the size of a hash table index. It must fit in
3626 ptrdiff_t and be a valid Emacs fixnum. */
3627 #define INDEX_SIZE_BOUND \
3628 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3630 /* Create and initialize a new hash table.
3632 TEST specifies the test the hash table will use to compare keys.
3633 It must be either one of the predefined tests `eq', `eql' or
3634 `equal' or a symbol denoting a user-defined test named TEST with
3635 test and hash functions USER_TEST and USER_HASH.
3637 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3639 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3640 new size when it becomes full is computed by adding REHASH_SIZE to
3641 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3642 table's new size is computed by multiplying its old size with
3645 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3646 be resized when the ratio of (number of entries in the table) /
3647 (table size) is >= REHASH_THRESHOLD.
3649 WEAK specifies the weakness of the table. If non-nil, it must be
3650 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3653 make_hash_table (struct hash_table_test test
,
3654 Lisp_Object size
, Lisp_Object rehash_size
,
3655 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3657 struct Lisp_Hash_Table
*h
;
3659 EMACS_INT index_size
, sz
;
3663 /* Preconditions. */
3664 eassert (SYMBOLP (test
.name
));
3665 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3666 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3667 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3668 eassert (FLOATP (rehash_threshold
)
3669 && 0 < XFLOAT_DATA (rehash_threshold
)
3670 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3672 if (XFASTINT (size
) == 0)
3673 size
= make_number (1);
3675 sz
= XFASTINT (size
);
3676 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3677 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3678 ? next_almost_prime (index_float
)
3679 : INDEX_SIZE_BOUND
+ 1);
3680 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3681 error ("Hash table too large");
3683 /* Allocate a table and initialize it. */
3684 h
= allocate_hash_table ();
3686 /* Initialize hash table slots. */
3689 h
->rehash_threshold
= rehash_threshold
;
3690 h
->rehash_size
= rehash_size
;
3692 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3693 h
->hash
= Fmake_vector (size
, Qnil
);
3694 h
->next
= Fmake_vector (size
, Qnil
);
3695 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3697 /* Set up the free list. */
3698 for (i
= 0; i
< sz
- 1; ++i
)
3699 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3700 h
->next_free
= make_number (0);
3702 XSET_HASH_TABLE (table
, h
);
3703 eassert (HASH_TABLE_P (table
));
3704 eassert (XHASH_TABLE (table
) == h
);
3710 /* Return a copy of hash table H1. Keys and values are not copied,
3711 only the table itself is. */
3714 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3717 struct Lisp_Hash_Table
*h2
;
3719 h2
= allocate_hash_table ();
3721 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3722 h2
->hash
= Fcopy_sequence (h1
->hash
);
3723 h2
->next
= Fcopy_sequence (h1
->next
);
3724 h2
->index
= Fcopy_sequence (h1
->index
);
3725 XSET_HASH_TABLE (table
, h2
);
3731 /* Resize hash table H if it's too full. If H cannot be resized
3732 because it's already too large, throw an error. */
3735 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3737 if (NILP (h
->next_free
))
3739 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3740 EMACS_INT new_size
, index_size
, nsize
;
3744 if (INTEGERP (h
->rehash_size
))
3745 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3748 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3749 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3751 new_size
= float_new_size
;
3752 if (new_size
<= old_size
)
3753 new_size
= old_size
+ 1;
3756 new_size
= INDEX_SIZE_BOUND
+ 1;
3758 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3759 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3760 ? next_almost_prime (index_float
)
3761 : INDEX_SIZE_BOUND
+ 1);
3762 nsize
= max (index_size
, 2 * new_size
);
3763 if (INDEX_SIZE_BOUND
< nsize
)
3764 error ("Hash table too large to resize");
3766 #ifdef ENABLE_CHECKING
3767 if (HASH_TABLE_P (Vpurify_flag
)
3768 && XHASH_TABLE (Vpurify_flag
) == h
)
3770 Lisp_Object args
[2];
3771 args
[0] = build_string ("Growing hash table to: %d");
3772 args
[1] = make_number (new_size
);
3777 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3778 2 * (new_size
- old_size
), -1));
3779 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3780 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3781 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3783 /* Update the free list. Do it so that new entries are added at
3784 the end of the free list. This makes some operations like
3786 for (i
= old_size
; i
< new_size
- 1; ++i
)
3787 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3789 if (!NILP (h
->next_free
))
3791 Lisp_Object last
, next
;
3793 last
= h
->next_free
;
3794 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3798 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3801 XSETFASTINT (h
->next_free
, old_size
);
3804 for (i
= 0; i
< old_size
; ++i
)
3805 if (!NILP (HASH_HASH (h
, i
)))
3807 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3808 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3809 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3810 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3816 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3817 the hash code of KEY. Value is the index of the entry in H
3818 matching KEY, or -1 if not found. */
3821 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3823 EMACS_UINT hash_code
;
3824 ptrdiff_t start_of_bucket
;
3827 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3828 eassert ((hash_code
& ~INTMASK
) == 0);
3832 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3833 idx
= HASH_INDEX (h
, start_of_bucket
);
3835 /* We need not gcpro idx since it's either an integer or nil. */
3838 ptrdiff_t i
= XFASTINT (idx
);
3839 if (EQ (key
, HASH_KEY (h
, i
))
3841 && hash_code
== XUINT (HASH_HASH (h
, i
))
3842 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3844 idx
= HASH_NEXT (h
, i
);
3847 return NILP (idx
) ? -1 : XFASTINT (idx
);
3851 /* Put an entry into hash table H that associates KEY with VALUE.
3852 HASH is a previously computed hash code of KEY.
3853 Value is the index of the entry in H matching KEY. */
3856 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3859 ptrdiff_t start_of_bucket
, i
;
3861 eassert ((hash
& ~INTMASK
) == 0);
3863 /* Increment count after resizing because resizing may fail. */
3864 maybe_resize_hash_table (h
);
3867 /* Store key/value in the key_and_value vector. */
3868 i
= XFASTINT (h
->next_free
);
3869 h
->next_free
= HASH_NEXT (h
, i
);
3870 set_hash_key_slot (h
, i
, key
);
3871 set_hash_value_slot (h
, i
, value
);
3873 /* Remember its hash code. */
3874 set_hash_hash_slot (h
, i
, make_number (hash
));
3876 /* Add new entry to its collision chain. */
3877 start_of_bucket
= hash
% ASIZE (h
->index
);
3878 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3879 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3884 /* Remove the entry matching KEY from hash table H, if there is one. */
3887 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3889 EMACS_UINT hash_code
;
3890 ptrdiff_t start_of_bucket
;
3891 Lisp_Object idx
, prev
;
3893 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3894 eassert ((hash_code
& ~INTMASK
) == 0);
3895 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3896 idx
= HASH_INDEX (h
, start_of_bucket
);
3899 /* We need not gcpro idx, prev since they're either integers or nil. */
3902 ptrdiff_t i
= XFASTINT (idx
);
3904 if (EQ (key
, HASH_KEY (h
, i
))
3906 && hash_code
== XUINT (HASH_HASH (h
, i
))
3907 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3909 /* Take entry out of collision chain. */
3911 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3913 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3915 /* Clear slots in key_and_value and add the slots to
3917 set_hash_key_slot (h
, i
, Qnil
);
3918 set_hash_value_slot (h
, i
, Qnil
);
3919 set_hash_hash_slot (h
, i
, Qnil
);
3920 set_hash_next_slot (h
, i
, h
->next_free
);
3921 h
->next_free
= make_number (i
);
3923 eassert (h
->count
>= 0);
3929 idx
= HASH_NEXT (h
, i
);
3935 /* Clear hash table H. */
3938 hash_clear (struct Lisp_Hash_Table
*h
)
3942 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3944 for (i
= 0; i
< size
; ++i
)
3946 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3947 set_hash_key_slot (h
, i
, Qnil
);
3948 set_hash_value_slot (h
, i
, Qnil
);
3949 set_hash_hash_slot (h
, i
, Qnil
);
3952 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3953 ASET (h
->index
, i
, Qnil
);
3955 h
->next_free
= make_number (0);
3962 /***********************************************************************
3963 Hash Code Computation
3964 ***********************************************************************/
3966 /* Maximum depth up to which to dive into Lisp structures. */
3968 #define SXHASH_MAX_DEPTH 3
3970 /* Maximum length up to which to take list and vector elements into
3973 #define SXHASH_MAX_LEN 7
3975 /* Return a hash for string PTR which has length LEN. The hash value
3976 can be any EMACS_UINT value. */
3979 hash_string (char const *ptr
, ptrdiff_t len
)
3981 char const *p
= ptr
;
3982 char const *end
= p
+ len
;
3984 EMACS_UINT hash
= 0;
3989 hash
= sxhash_combine (hash
, c
);
3995 /* Return a hash for string PTR which has length LEN. The hash
3996 code returned is guaranteed to fit in a Lisp integer. */
3999 sxhash_string (char const *ptr
, ptrdiff_t len
)
4001 EMACS_UINT hash
= hash_string (ptr
, len
);
4002 return SXHASH_REDUCE (hash
);
4005 /* Return a hash for the floating point value VAL. */
4008 sxhash_float (double val
)
4010 EMACS_UINT hash
= 0;
4012 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4013 + (sizeof val
% sizeof hash
!= 0))
4017 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4021 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4022 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4023 hash
= sxhash_combine (hash
, u
.word
[i
]);
4024 return SXHASH_REDUCE (hash
);
4027 /* Return a hash for list LIST. DEPTH is the current depth in the
4028 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4031 sxhash_list (Lisp_Object list
, int depth
)
4033 EMACS_UINT hash
= 0;
4036 if (depth
< SXHASH_MAX_DEPTH
)
4038 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4039 list
= XCDR (list
), ++i
)
4041 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4042 hash
= sxhash_combine (hash
, hash2
);
4047 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4048 hash
= sxhash_combine (hash
, hash2
);
4051 return SXHASH_REDUCE (hash
);
4055 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4056 the Lisp structure. */
4059 sxhash_vector (Lisp_Object vec
, int depth
)
4061 EMACS_UINT hash
= ASIZE (vec
);
4064 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4065 for (i
= 0; i
< n
; ++i
)
4067 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4068 hash
= sxhash_combine (hash
, hash2
);
4071 return SXHASH_REDUCE (hash
);
4074 /* Return a hash for bool-vector VECTOR. */
4077 sxhash_bool_vector (Lisp_Object vec
)
4079 EMACS_INT size
= bool_vector_size (vec
);
4080 EMACS_UINT hash
= size
;
4083 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4084 for (i
= 0; i
< n
; ++i
)
4085 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4087 return SXHASH_REDUCE (hash
);
4091 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4092 structure. Value is an unsigned integer clipped to INTMASK. */
4095 sxhash (Lisp_Object obj
, int depth
)
4099 if (depth
> SXHASH_MAX_DEPTH
)
4102 switch (XTYPE (obj
))
4113 obj
= SYMBOL_NAME (obj
);
4117 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4120 /* This can be everything from a vector to an overlay. */
4121 case Lisp_Vectorlike
:
4123 /* According to the CL HyperSpec, two arrays are equal only if
4124 they are `eq', except for strings and bit-vectors. In
4125 Emacs, this works differently. We have to compare element
4127 hash
= sxhash_vector (obj
, depth
);
4128 else if (BOOL_VECTOR_P (obj
))
4129 hash
= sxhash_bool_vector (obj
);
4131 /* Others are `equal' if they are `eq', so let's take their
4137 hash
= sxhash_list (obj
, depth
);
4141 hash
= sxhash_float (XFLOAT_DATA (obj
));
4153 /***********************************************************************
4155 ***********************************************************************/
4158 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4159 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4162 EMACS_UINT hash
= sxhash (obj
, 0);
4163 return make_number (hash
);
4167 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4168 doc
: /* Create and return a new hash table.
4170 Arguments are specified as keyword/argument pairs. The following
4171 arguments are defined:
4173 :test TEST -- TEST must be a symbol that specifies how to compare
4174 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4175 `equal'. User-supplied test and hash functions can be specified via
4176 `define-hash-table-test'.
4178 :size SIZE -- A hint as to how many elements will be put in the table.
4181 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4182 fills up. If REHASH-SIZE is an integer, increase the size by that
4183 amount. If it is a float, it must be > 1.0, and the new size is the
4184 old size multiplied by that factor. Default is 1.5.
4186 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4187 Resize the hash table when the ratio (number of entries / table size)
4188 is greater than or equal to THRESHOLD. Default is 0.8.
4190 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4191 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4192 returned is a weak table. Key/value pairs are removed from a weak
4193 hash table when there are no non-weak references pointing to their
4194 key, value, one of key or value, or both key and value, depending on
4195 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4198 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4199 (ptrdiff_t nargs
, Lisp_Object
*args
)
4201 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4202 struct hash_table_test testdesc
;
4206 /* The vector `used' is used to keep track of arguments that
4207 have been consumed. */
4208 used
= alloca (nargs
* sizeof *used
);
4209 memset (used
, 0, nargs
* sizeof *used
);
4211 /* See if there's a `:test TEST' among the arguments. */
4212 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4213 test
= i
? args
[i
] : Qeql
;
4215 testdesc
= hashtest_eq
;
4216 else if (EQ (test
, Qeql
))
4217 testdesc
= hashtest_eql
;
4218 else if (EQ (test
, Qequal
))
4219 testdesc
= hashtest_equal
;
4222 /* See if it is a user-defined test. */
4225 prop
= Fget (test
, Qhash_table_test
);
4226 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4227 signal_error ("Invalid hash table test", test
);
4228 testdesc
.name
= test
;
4229 testdesc
.user_cmp_function
= XCAR (prop
);
4230 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4231 testdesc
.hashfn
= hashfn_user_defined
;
4232 testdesc
.cmpfn
= cmpfn_user_defined
;
4235 /* See if there's a `:size SIZE' argument. */
4236 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4237 size
= i
? args
[i
] : Qnil
;
4239 size
= make_number (DEFAULT_HASH_SIZE
);
4240 else if (!INTEGERP (size
) || XINT (size
) < 0)
4241 signal_error ("Invalid hash table size", size
);
4243 /* Look for `:rehash-size SIZE'. */
4244 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4245 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4246 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4247 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4248 signal_error ("Invalid hash table rehash size", rehash_size
);
4250 /* Look for `:rehash-threshold THRESHOLD'. */
4251 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4252 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4253 if (! (FLOATP (rehash_threshold
)
4254 && 0 < XFLOAT_DATA (rehash_threshold
)
4255 && XFLOAT_DATA (rehash_threshold
) <= 1))
4256 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4258 /* Look for `:weakness WEAK'. */
4259 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4260 weak
= i
? args
[i
] : Qnil
;
4262 weak
= Qkey_and_value
;
4265 && !EQ (weak
, Qvalue
)
4266 && !EQ (weak
, Qkey_or_value
)
4267 && !EQ (weak
, Qkey_and_value
))
4268 signal_error ("Invalid hash table weakness", weak
);
4270 /* Now, all args should have been used up, or there's a problem. */
4271 for (i
= 0; i
< nargs
; ++i
)
4273 signal_error ("Invalid argument list", args
[i
]);
4275 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4279 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4280 doc
: /* Return a copy of hash table TABLE. */)
4283 return copy_hash_table (check_hash_table (table
));
4287 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4288 doc
: /* Return the number of elements in TABLE. */)
4291 return make_number (check_hash_table (table
)->count
);
4295 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4296 Shash_table_rehash_size
, 1, 1, 0,
4297 doc
: /* Return the current rehash size of TABLE. */)
4300 return check_hash_table (table
)->rehash_size
;
4304 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4305 Shash_table_rehash_threshold
, 1, 1, 0,
4306 doc
: /* Return the current rehash threshold of TABLE. */)
4309 return check_hash_table (table
)->rehash_threshold
;
4313 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4314 doc
: /* Return the size of TABLE.
4315 The size can be used as an argument to `make-hash-table' to create
4316 a hash table than can hold as many elements as TABLE holds
4317 without need for resizing. */)
4320 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4321 return make_number (HASH_TABLE_SIZE (h
));
4325 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4326 doc
: /* Return the test TABLE uses. */)
4329 return check_hash_table (table
)->test
.name
;
4333 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4335 doc
: /* Return the weakness of TABLE. */)
4338 return check_hash_table (table
)->weak
;
4342 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4343 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4346 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4350 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4351 doc
: /* Clear hash table TABLE and return it. */)
4354 hash_clear (check_hash_table (table
));
4355 /* Be compatible with XEmacs. */
4360 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4361 doc
: /* Look up KEY in TABLE and return its associated value.
4362 If KEY is not found, return DFLT which defaults to nil. */)
4363 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4365 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4366 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4367 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4371 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4372 doc
: /* Associate KEY with VALUE in hash table TABLE.
4373 If KEY is already present in table, replace its current value with
4374 VALUE. In any case, return VALUE. */)
4375 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4377 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4381 i
= hash_lookup (h
, key
, &hash
);
4383 set_hash_value_slot (h
, i
, value
);
4385 hash_put (h
, key
, value
, hash
);
4391 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4392 doc
: /* Remove KEY from TABLE. */)
4393 (Lisp_Object key
, Lisp_Object table
)
4395 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4396 hash_remove_from_table (h
, key
);
4401 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4402 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4403 FUNCTION is called with two arguments, KEY and VALUE.
4404 `maphash' always returns nil. */)
4405 (Lisp_Object function
, Lisp_Object table
)
4407 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4408 Lisp_Object args
[3];
4411 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4412 if (!NILP (HASH_HASH (h
, i
)))
4415 args
[1] = HASH_KEY (h
, i
);
4416 args
[2] = HASH_VALUE (h
, i
);
4424 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4425 Sdefine_hash_table_test
, 3, 3, 0,
4426 doc
: /* Define a new hash table test with name NAME, a symbol.
4428 In hash tables created with NAME specified as test, use TEST to
4429 compare keys, and HASH for computing hash codes of keys.
4431 TEST must be a function taking two arguments and returning non-nil if
4432 both arguments are the same. HASH must be a function taking one
4433 argument and returning an object that is the hash code of the argument.
4434 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4435 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4436 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4438 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4443 /************************************************************************
4444 MD5, SHA-1, and SHA-2
4445 ************************************************************************/
4452 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4455 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4456 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4460 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4461 register EMACS_INT b
, e
;
4462 register struct buffer
*bp
;
4465 void *(*hash_func
) (const char *, size_t, void *);
4468 CHECK_SYMBOL (algorithm
);
4470 if (STRINGP (object
))
4472 if (NILP (coding_system
))
4474 /* Decide the coding-system to encode the data with. */
4476 if (STRING_MULTIBYTE (object
))
4477 /* use default, we can't guess correct value */
4478 coding_system
= preferred_coding_system ();
4480 coding_system
= Qraw_text
;
4483 if (NILP (Fcoding_system_p (coding_system
)))
4485 /* Invalid coding system. */
4487 if (!NILP (noerror
))
4488 coding_system
= Qraw_text
;
4490 xsignal1 (Qcoding_system_error
, coding_system
);
4493 if (STRING_MULTIBYTE (object
))
4494 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4496 size
= SCHARS (object
);
4497 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4499 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4500 end_byte
= (end_char
== size
4502 : string_char_to_byte (object
, end_char
));
4506 struct buffer
*prev
= current_buffer
;
4508 record_unwind_current_buffer ();
4510 CHECK_BUFFER (object
);
4512 bp
= XBUFFER (object
);
4513 set_buffer_internal (bp
);
4519 CHECK_NUMBER_COERCE_MARKER (start
);
4527 CHECK_NUMBER_COERCE_MARKER (end
);
4532 temp
= b
, b
= e
, e
= temp
;
4534 if (!(BEGV
<= b
&& e
<= ZV
))
4535 args_out_of_range (start
, end
);
4537 if (NILP (coding_system
))
4539 /* Decide the coding-system to encode the data with.
4540 See fileio.c:Fwrite-region */
4542 if (!NILP (Vcoding_system_for_write
))
4543 coding_system
= Vcoding_system_for_write
;
4546 bool force_raw_text
= 0;
4548 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4549 if (NILP (coding_system
)
4550 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4552 coding_system
= Qnil
;
4553 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4557 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4559 /* Check file-coding-system-alist. */
4560 Lisp_Object args
[4], val
;
4562 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4563 args
[3] = Fbuffer_file_name (object
);
4564 val
= Ffind_operation_coding_system (4, args
);
4565 if (CONSP (val
) && !NILP (XCDR (val
)))
4566 coding_system
= XCDR (val
);
4569 if (NILP (coding_system
)
4570 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4572 /* If we still have not decided a coding system, use the
4573 default value of buffer-file-coding-system. */
4574 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4578 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4579 /* Confirm that VAL can surely encode the current region. */
4580 coding_system
= call4 (Vselect_safe_coding_system_function
,
4581 make_number (b
), make_number (e
),
4582 coding_system
, Qnil
);
4585 coding_system
= Qraw_text
;
4588 if (NILP (Fcoding_system_p (coding_system
)))
4590 /* Invalid coding system. */
4592 if (!NILP (noerror
))
4593 coding_system
= Qraw_text
;
4595 xsignal1 (Qcoding_system_error
, coding_system
);
4599 object
= make_buffer_string (b
, e
, 0);
4600 set_buffer_internal (prev
);
4601 /* Discard the unwind protect for recovering the current
4605 if (STRING_MULTIBYTE (object
))
4606 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4608 end_byte
= SBYTES (object
);
4611 if (EQ (algorithm
, Qmd5
))
4613 digest_size
= MD5_DIGEST_SIZE
;
4614 hash_func
= md5_buffer
;
4616 else if (EQ (algorithm
, Qsha1
))
4618 digest_size
= SHA1_DIGEST_SIZE
;
4619 hash_func
= sha1_buffer
;
4621 else if (EQ (algorithm
, Qsha224
))
4623 digest_size
= SHA224_DIGEST_SIZE
;
4624 hash_func
= sha224_buffer
;
4626 else if (EQ (algorithm
, Qsha256
))
4628 digest_size
= SHA256_DIGEST_SIZE
;
4629 hash_func
= sha256_buffer
;
4631 else if (EQ (algorithm
, Qsha384
))
4633 digest_size
= SHA384_DIGEST_SIZE
;
4634 hash_func
= sha384_buffer
;
4636 else if (EQ (algorithm
, Qsha512
))
4638 digest_size
= SHA512_DIGEST_SIZE
;
4639 hash_func
= sha512_buffer
;
4642 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4644 /* allocate 2 x digest_size so that it can be re-used to hold the
4646 digest
= make_uninit_string (digest_size
* 2);
4648 hash_func (SSDATA (object
) + start_byte
,
4649 end_byte
- start_byte
,
4654 unsigned char *p
= SDATA (digest
);
4655 for (i
= digest_size
- 1; i
>= 0; i
--)
4657 static char const hexdigit
[16] = "0123456789abcdef";
4659 p
[2 * i
] = hexdigit
[p_i
>> 4];
4660 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4665 return make_unibyte_string (SSDATA (digest
), digest_size
);
4668 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4669 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4671 A message digest is a cryptographic checksum of a document, and the
4672 algorithm to calculate it is defined in RFC 1321.
4674 The two optional arguments START and END are character positions
4675 specifying for which part of OBJECT the message digest should be
4676 computed. If nil or omitted, the digest is computed for the whole
4679 The MD5 message digest is computed from the result of encoding the
4680 text in a coding system, not directly from the internal Emacs form of
4681 the text. The optional fourth argument CODING-SYSTEM specifies which
4682 coding system to encode the text with. It should be the same coding
4683 system that you used or will use when actually writing the text into a
4686 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4687 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4688 system would be chosen by default for writing this text into a file.
4690 If OBJECT is a string, the most preferred coding system (see the
4691 command `prefer-coding-system') is used.
4693 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4694 guesswork fails. Normally, an error is signaled in such case. */)
4695 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4697 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4700 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4701 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4702 ALGORITHM is a symbol specifying the hash to use:
4703 md5, sha1, sha224, sha256, sha384 or sha512.
4705 The two optional arguments START and END are positions specifying for
4706 which part of OBJECT to compute the hash. If nil or omitted, uses the
4709 If BINARY is non-nil, returns a string in binary form. */)
4710 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4712 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4718 DEFSYM (Qmd5
, "md5");
4719 DEFSYM (Qsha1
, "sha1");
4720 DEFSYM (Qsha224
, "sha224");
4721 DEFSYM (Qsha256
, "sha256");
4722 DEFSYM (Qsha384
, "sha384");
4723 DEFSYM (Qsha512
, "sha512");
4725 /* Hash table stuff. */
4726 DEFSYM (Qhash_table_p
, "hash-table-p");
4728 DEFSYM (Qeql
, "eql");
4729 DEFSYM (Qequal
, "equal");
4730 DEFSYM (QCtest
, ":test");
4731 DEFSYM (QCsize
, ":size");
4732 DEFSYM (QCrehash_size
, ":rehash-size");
4733 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4734 DEFSYM (QCweakness
, ":weakness");
4735 DEFSYM (Qkey
, "key");
4736 DEFSYM (Qvalue
, "value");
4737 DEFSYM (Qhash_table_test
, "hash-table-test");
4738 DEFSYM (Qkey_or_value
, "key-or-value");
4739 DEFSYM (Qkey_and_value
, "key-and-value");
4742 defsubr (&Smake_hash_table
);
4743 defsubr (&Scopy_hash_table
);
4744 defsubr (&Shash_table_count
);
4745 defsubr (&Shash_table_rehash_size
);
4746 defsubr (&Shash_table_rehash_threshold
);
4747 defsubr (&Shash_table_size
);
4748 defsubr (&Shash_table_test
);
4749 defsubr (&Shash_table_weakness
);
4750 defsubr (&Shash_table_p
);
4751 defsubr (&Sclrhash
);
4752 defsubr (&Sgethash
);
4753 defsubr (&Sputhash
);
4754 defsubr (&Sremhash
);
4755 defsubr (&Smaphash
);
4756 defsubr (&Sdefine_hash_table_test
);
4758 DEFSYM (Qstring_lessp
, "string-lessp");
4759 DEFSYM (Qprovide
, "provide");
4760 DEFSYM (Qrequire
, "require");
4761 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4762 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4763 DEFSYM (Qwidget_type
, "widget-type");
4765 staticpro (&string_char_byte_cache_string
);
4766 string_char_byte_cache_string
= Qnil
;
4768 require_nesting_list
= Qnil
;
4769 staticpro (&require_nesting_list
);
4771 Fset (Qyes_or_no_p_history
, Qnil
);
4773 DEFVAR_LISP ("features", Vfeatures
,
4774 doc
: /* A list of symbols which are the features of the executing Emacs.
4775 Used by `featurep' and `require', and altered by `provide'. */);
4776 Vfeatures
= list1 (intern_c_string ("emacs"));
4777 DEFSYM (Qsubfeatures
, "subfeatures");
4778 DEFSYM (Qfuncall
, "funcall");
4780 #ifdef HAVE_LANGINFO_CODESET
4781 DEFSYM (Qcodeset
, "codeset");
4782 DEFSYM (Qdays
, "days");
4783 DEFSYM (Qmonths
, "months");
4784 DEFSYM (Qpaper
, "paper");
4785 #endif /* HAVE_LANGINFO_CODESET */
4787 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4788 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4789 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4790 invoked by mouse clicks and mouse menu items.
4792 On some platforms, file selection dialogs are also enabled if this is
4796 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4797 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4798 This applies to commands from menus and tool bar buttons even when
4799 they are initiated from the keyboard. If `use-dialog-box' is nil,
4800 that disables the use of a file dialog, regardless of the value of
4802 use_file_dialog
= 1;
4804 defsubr (&Sidentity
);
4807 defsubr (&Ssafe_length
);
4808 defsubr (&Sstring_bytes
);
4809 defsubr (&Sstring_equal
);
4810 defsubr (&Scompare_strings
);
4811 defsubr (&Sstring_lessp
);
4814 defsubr (&Svconcat
);
4815 defsubr (&Scopy_sequence
);
4816 defsubr (&Sstring_make_multibyte
);
4817 defsubr (&Sstring_make_unibyte
);
4818 defsubr (&Sstring_as_multibyte
);
4819 defsubr (&Sstring_as_unibyte
);
4820 defsubr (&Sstring_to_multibyte
);
4821 defsubr (&Sstring_to_unibyte
);
4822 defsubr (&Scopy_alist
);
4823 defsubr (&Ssubstring
);
4824 defsubr (&Ssubstring_no_properties
);
4837 defsubr (&Snreverse
);
4838 defsubr (&Sreverse
);
4840 defsubr (&Splist_get
);
4842 defsubr (&Splist_put
);
4844 defsubr (&Slax_plist_get
);
4845 defsubr (&Slax_plist_put
);
4848 defsubr (&Sequal_including_properties
);
4849 defsubr (&Sfillarray
);
4850 defsubr (&Sclear_string
);
4854 defsubr (&Smapconcat
);
4855 defsubr (&Syes_or_no_p
);
4856 defsubr (&Sload_average
);
4857 defsubr (&Sfeaturep
);
4858 defsubr (&Srequire
);
4859 defsubr (&Sprovide
);
4860 defsubr (&Splist_member
);
4861 defsubr (&Swidget_put
);
4862 defsubr (&Swidget_get
);
4863 defsubr (&Swidget_apply
);
4864 defsubr (&Sbase64_encode_region
);
4865 defsubr (&Sbase64_decode_region
);
4866 defsubr (&Sbase64_encode_string
);
4867 defsubr (&Sbase64_decode_string
);
4869 defsubr (&Ssecure_hash
);
4870 defsubr (&Slocale_info
);
4872 hashtest_eq
.name
= Qeq
;
4873 hashtest_eq
.user_hash_function
= Qnil
;
4874 hashtest_eq
.user_cmp_function
= Qnil
;
4875 hashtest_eq
.cmpfn
= 0;
4876 hashtest_eq
.hashfn
= hashfn_eq
;
4878 hashtest_eql
.name
= Qeql
;
4879 hashtest_eql
.user_hash_function
= Qnil
;
4880 hashtest_eql
.user_cmp_function
= Qnil
;
4881 hashtest_eql
.cmpfn
= cmpfn_eql
;
4882 hashtest_eql
.hashfn
= hashfn_eql
;
4884 hashtest_equal
.name
= Qequal
;
4885 hashtest_equal
.user_hash_function
= Qnil
;
4886 hashtest_equal
.user_cmp_function
= Qnil
;
4887 hashtest_equal
.cmpfn
= cmpfn_equal
;
4888 hashtest_equal
.hashfn
= hashfn_equal
;