1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2015 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/>. */
31 #include "character.h"
36 #include "intervals.h"
39 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
44 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
45 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
46 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
48 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
49 doc
: /* Return the argument unchanged. */
56 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
57 doc
: /* Return a pseudo-random number.
58 All integers representable in Lisp, i.e. between `most-negative-fixnum'
59 and `most-positive-fixnum', inclusive, are equally likely.
61 With positive integer LIMIT, return random number in interval [0,LIMIT).
62 With argument t, set the random number seed from the current time and pid.
63 With a string argument, set the seed based on the string's contents.
64 Other values of LIMIT are ignored.
66 See Info node `(elisp)Random Numbers' for more details. */)
73 else if (STRINGP (limit
))
74 seed_random (SSDATA (limit
), SBYTES (limit
));
77 if (INTEGERP (limit
) && 0 < XINT (limit
))
80 /* Return the remainder, except reject the rare case where
81 get_random returns a number so close to INTMASK that the
82 remainder isn't random. */
83 EMACS_INT remainder
= val
% XINT (limit
);
84 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
85 return make_number (remainder
);
88 return make_number (val
);
91 /* Heuristic on how many iterations of a tight loop can be safely done
92 before it's time to do a QUIT. This must be a power of 2. */
93 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
95 /* Random data-structure functions. */
98 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
100 CHECK_TYPE (NILP (x
), Qlistp
, y
);
103 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
104 doc
: /* Return the length of vector, list or string SEQUENCE.
105 A byte-code function object is also allowed.
106 If the string contains multibyte characters, this is not necessarily
107 the number of bytes in the string; it is the number of characters.
108 To get the number of bytes, use `string-bytes'. */)
109 (register Lisp_Object sequence
)
111 register Lisp_Object val
;
113 if (STRINGP (sequence
))
114 XSETFASTINT (val
, SCHARS (sequence
));
115 else if (VECTORP (sequence
))
116 XSETFASTINT (val
, ASIZE (sequence
));
117 else if (CHAR_TABLE_P (sequence
))
118 XSETFASTINT (val
, MAX_CHAR
);
119 else if (BOOL_VECTOR_P (sequence
))
120 XSETFASTINT (val
, bool_vector_size (sequence
));
121 else if (COMPILEDP (sequence
))
122 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
123 else if (CONSP (sequence
))
130 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
132 if (MOST_POSITIVE_FIXNUM
< i
)
133 error ("List too long");
136 sequence
= XCDR (sequence
);
138 while (CONSP (sequence
));
140 CHECK_LIST_END (sequence
, sequence
);
142 val
= make_number (i
);
144 else if (NILP (sequence
))
145 XSETFASTINT (val
, 0);
147 wrong_type_argument (Qsequencep
, sequence
);
152 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
153 doc
: /* Return the length of a list, but avoid error or infinite loop.
154 This function never gets an error. If LIST is not really a list,
155 it returns 0. If LIST is circular, it returns a finite value
156 which is at least the number of distinct elements. */)
159 Lisp_Object tail
, halftail
;
164 return make_number (0);
166 /* halftail is used to detect circular lists. */
167 for (tail
= halftail
= list
; ; )
172 if (EQ (tail
, halftail
))
175 if ((lolen
& 1) == 0)
177 halftail
= XCDR (halftail
);
178 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
182 hilen
+= UINTMAX_MAX
+ 1.0;
187 /* If the length does not fit into a fixnum, return a float.
188 On all known practical machines this returns an upper bound on
190 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
193 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
194 doc
: /* Return the number of bytes in STRING.
195 If STRING is multibyte, this may be greater than the length of STRING. */)
198 CHECK_STRING (string
);
199 return make_number (SBYTES (string
));
202 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
203 doc
: /* Return t if two strings have identical contents.
204 Case is significant, but text properties are ignored.
205 Symbols are also allowed; their print names are used instead. */)
206 (register Lisp_Object s1
, Lisp_Object s2
)
209 s1
= SYMBOL_NAME (s1
);
211 s2
= SYMBOL_NAME (s2
);
215 if (SCHARS (s1
) != SCHARS (s2
)
216 || SBYTES (s1
) != SBYTES (s2
)
217 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
222 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
223 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
224 The arguments START1, END1, START2, and END2, if non-nil, are
225 positions specifying which parts of STR1 or STR2 to compare. In
226 string STR1, compare the part between START1 (inclusive) and END1
227 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
228 the string; if END1 is nil, it defaults to the length of the string.
229 Likewise, in string STR2, compare the part between START2 and END2.
230 Like in `substring', negative values are counted from the end.
232 The strings are compared by the numeric values of their characters.
233 For instance, STR1 is "less than" STR2 if its first differing
234 character has a smaller numeric value. If IGNORE-CASE is non-nil,
235 characters are converted to lower-case before comparing them. Unibyte
236 strings are converted to multibyte for comparison.
238 The value is t if the strings (or specified portions) match.
239 If string STR1 is less, the value is a negative number N;
240 - 1 - N is the number of characters that match at the beginning.
241 If string STR1 is greater, the value is a positive number N;
242 N - 1 is the number of characters that match at the beginning. */)
243 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
244 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
246 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
251 /* For backward compatibility, silently bring too-large positive end
252 values into range. */
253 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
254 end1
= make_number (SCHARS (str1
));
255 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
256 end2
= make_number (SCHARS (str2
));
258 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
259 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
264 i1_byte
= string_char_to_byte (str1
, i1
);
265 i2_byte
= string_char_to_byte (str2
, i2
);
267 while (i1
< to1
&& i2
< to2
)
269 /* When we find a mismatch, we must compare the
270 characters, not just the bytes. */
273 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
274 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
279 if (! NILP (ignore_case
))
281 c1
= XINT (Fupcase (make_number (c1
)));
282 c2
= XINT (Fupcase (make_number (c2
)));
288 /* Note that I1 has already been incremented
289 past the character that we are comparing;
290 hence we don't add or subtract 1 here. */
292 return make_number (- i1
+ from1
);
294 return make_number (i1
- from1
);
298 return make_number (i1
- from1
+ 1);
300 return make_number (- i1
+ from1
- 1);
305 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
306 doc
: /* Return t if first arg string is less than second in lexicographic order.
308 Symbols are also allowed; their print names are used instead. */)
309 (register Lisp_Object s1
, Lisp_Object s2
)
311 register ptrdiff_t end
;
312 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
315 s1
= SYMBOL_NAME (s1
);
317 s2
= SYMBOL_NAME (s2
);
321 i1
= i1_byte
= i2
= i2_byte
= 0;
324 if (end
> SCHARS (s2
))
329 /* When we find a mismatch, we must compare the
330 characters, not just the bytes. */
333 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
334 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
337 return c1
< c2
? Qt
: Qnil
;
339 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
342 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
343 doc
: /* Return t if first arg string is less than second in collation order.
344 Symbols are also allowed; their print names are used instead.
346 This function obeys the conventions for collation order in your
347 locale settings. For example, punctuation and whitespace characters
348 might be considered less significant for sorting:
350 \(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
351 => \("11" "1 1" "1.1" "12" "1 2" "1.2")
353 The optional argument LOCALE, a string, overrides the setting of your
354 current locale identifier for collation. The value is system
355 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
356 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
358 If IGNORE-CASE is non-nil, characters are converted to lower-case
359 before comparing them.
361 To emulate Unicode-compliant collation on MS-Windows systems,
362 bind `w32-collate-ignore-punctuation' to a non-nil value, since
363 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
365 If your system does not support a locale environment, this function
366 behaves like `string-lessp'. */)
367 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
369 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
370 /* Check parameters. */
372 s1
= SYMBOL_NAME (s1
);
374 s2
= SYMBOL_NAME (s2
);
378 CHECK_STRING (locale
);
380 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
382 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
383 return Fstring_lessp (s1
, s2
);
384 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
387 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
388 doc
: /* Return t if two strings have identical contents.
389 Symbols are also allowed; their print names are used instead.
391 This function obeys the conventions for collation order in your locale
392 settings. For example, characters with different coding points but
393 the same meaning might be considered as equal, like different grave
394 accent Unicode characters:
396 \(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
399 The optional argument LOCALE, a string, overrides the setting of your
400 current locale identifier for collation. The value is system
401 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
402 while it would be \"enu_USA.1252\" on MS Windows systems.
404 If IGNORE-CASE is non-nil, characters are converted to lower-case
405 before comparing them.
407 To emulate Unicode-compliant collation on MS-Windows systems,
408 bind `w32-collate-ignore-punctuation' to a non-nil value, since
409 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
411 If your system does not support a locale environment, this function
412 behaves like `string-equal'.
414 Do NOT use this function to compare file names for equality, only
415 for sorting them. */)
416 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
418 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
419 /* Check parameters. */
421 s1
= SYMBOL_NAME (s1
);
423 s2
= SYMBOL_NAME (s2
);
427 CHECK_STRING (locale
);
429 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
431 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
432 return Fstring_equal (s1
, s2
);
433 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
436 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
437 enum Lisp_Type target_type
, bool last_special
);
441 concat2 (Lisp_Object s1
, Lisp_Object s2
)
446 return concat (2, args
, Lisp_String
, 0);
451 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
457 return concat (3, args
, Lisp_String
, 0);
460 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
461 doc
: /* Concatenate all the arguments and make the result a list.
462 The result is a list whose elements are the elements of all the arguments.
463 Each argument may be a list, vector or string.
464 The last argument is not copied, just used as the tail of the new list.
465 usage: (append &rest SEQUENCES) */)
466 (ptrdiff_t nargs
, Lisp_Object
*args
)
468 return concat (nargs
, args
, Lisp_Cons
, 1);
471 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
472 doc
: /* Concatenate all the arguments and make the result a string.
473 The result is a string whose elements are the elements of all the arguments.
474 Each argument may be a string or a list or vector of characters (integers).
475 usage: (concat &rest SEQUENCES) */)
476 (ptrdiff_t nargs
, Lisp_Object
*args
)
478 return concat (nargs
, args
, Lisp_String
, 0);
481 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
482 doc
: /* Concatenate all the arguments and make the result a vector.
483 The result is a vector whose elements are the elements of all the arguments.
484 Each argument may be a list, vector or string.
485 usage: (vconcat &rest SEQUENCES) */)
486 (ptrdiff_t nargs
, Lisp_Object
*args
)
488 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
492 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
493 doc
: /* Return a copy of a list, vector, string or char-table.
494 The elements of a list or vector are not copied; they are shared
495 with the original. */)
498 if (NILP (arg
)) return arg
;
500 if (CHAR_TABLE_P (arg
))
502 return copy_char_table (arg
);
505 if (BOOL_VECTOR_P (arg
))
507 EMACS_INT nbits
= bool_vector_size (arg
);
508 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
509 Lisp_Object val
= make_uninit_bool_vector (nbits
);
510 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
514 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
515 wrong_type_argument (Qsequencep
, arg
);
517 return concat (1, &arg
, XTYPE (arg
), 0);
520 /* This structure holds information of an argument of `concat' that is
521 a string and has text properties to be copied. */
524 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
525 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
526 ptrdiff_t to
; /* refer to VAL (the target string) */
530 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
531 enum Lisp_Type target_type
, bool last_special
)
537 ptrdiff_t toindex_byte
= 0;
538 EMACS_INT result_len
;
539 EMACS_INT result_len_byte
;
541 Lisp_Object last_tail
;
544 /* When we make a multibyte string, we can't copy text properties
545 while concatenating each string because the length of resulting
546 string can't be decided until we finish the whole concatenation.
547 So, we record strings that have text properties to be copied
548 here, and copy the text properties after the concatenation. */
549 struct textprop_rec
*textprops
= NULL
;
550 /* Number of elements in textprops. */
551 ptrdiff_t num_textprops
= 0;
556 /* In append, the last arg isn't treated like the others */
557 if (last_special
&& nargs
> 0)
560 last_tail
= args
[nargs
];
565 /* Check each argument. */
566 for (argnum
= 0; argnum
< nargs
; argnum
++)
569 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
570 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
571 wrong_type_argument (Qsequencep
, this);
574 /* Compute total length in chars of arguments in RESULT_LEN.
575 If desired output is a string, also compute length in bytes
576 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
577 whether the result should be a multibyte string. */
581 for (argnum
= 0; argnum
< nargs
; argnum
++)
585 len
= XFASTINT (Flength (this));
586 if (target_type
== Lisp_String
)
588 /* We must count the number of bytes needed in the string
589 as well as the number of characters. */
593 ptrdiff_t this_len_byte
;
595 if (VECTORP (this) || COMPILEDP (this))
596 for (i
= 0; i
< len
; i
++)
599 CHECK_CHARACTER (ch
);
601 this_len_byte
= CHAR_BYTES (c
);
602 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
604 result_len_byte
+= this_len_byte
;
605 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
608 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
609 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
610 else if (CONSP (this))
611 for (; CONSP (this); this = XCDR (this))
614 CHECK_CHARACTER (ch
);
616 this_len_byte
= CHAR_BYTES (c
);
617 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
619 result_len_byte
+= this_len_byte
;
620 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
623 else if (STRINGP (this))
625 if (STRING_MULTIBYTE (this))
628 this_len_byte
= SBYTES (this);
631 this_len_byte
= count_size_as_multibyte (SDATA (this),
633 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
635 result_len_byte
+= this_len_byte
;
640 if (MOST_POSITIVE_FIXNUM
< result_len
)
641 memory_full (SIZE_MAX
);
644 if (! some_multibyte
)
645 result_len_byte
= result_len
;
647 /* Create the output object. */
648 if (target_type
== Lisp_Cons
)
649 val
= Fmake_list (make_number (result_len
), Qnil
);
650 else if (target_type
== Lisp_Vectorlike
)
651 val
= Fmake_vector (make_number (result_len
), Qnil
);
652 else if (some_multibyte
)
653 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
655 val
= make_uninit_string (result_len
);
657 /* In `append', if all but last arg are nil, return last arg. */
658 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
661 /* Copy the contents of the args into the result. */
663 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
665 toindex
= 0, toindex_byte
= 0;
669 SAFE_NALLOCA (textprops
, 1, nargs
);
671 for (argnum
= 0; argnum
< nargs
; argnum
++)
674 ptrdiff_t thisleni
= 0;
675 register ptrdiff_t thisindex
= 0;
676 register ptrdiff_t thisindex_byte
= 0;
680 thislen
= Flength (this), thisleni
= XINT (thislen
);
682 /* Between strings of the same kind, copy fast. */
683 if (STRINGP (this) && STRINGP (val
)
684 && STRING_MULTIBYTE (this) == some_multibyte
)
686 ptrdiff_t thislen_byte
= SBYTES (this);
688 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
689 if (string_intervals (this))
691 textprops
[num_textprops
].argnum
= argnum
;
692 textprops
[num_textprops
].from
= 0;
693 textprops
[num_textprops
++].to
= toindex
;
695 toindex_byte
+= thislen_byte
;
698 /* Copy a single-byte string to a multibyte string. */
699 else if (STRINGP (this) && STRINGP (val
))
701 if (string_intervals (this))
703 textprops
[num_textprops
].argnum
= argnum
;
704 textprops
[num_textprops
].from
= 0;
705 textprops
[num_textprops
++].to
= toindex
;
707 toindex_byte
+= copy_text (SDATA (this),
708 SDATA (val
) + toindex_byte
,
709 SCHARS (this), 0, 1);
713 /* Copy element by element. */
716 register Lisp_Object elt
;
718 /* Fetch next element of `this' arg into `elt', or break if
719 `this' is exhausted. */
720 if (NILP (this)) break;
722 elt
= XCAR (this), this = XCDR (this);
723 else if (thisindex
>= thisleni
)
725 else if (STRINGP (this))
728 if (STRING_MULTIBYTE (this))
729 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
734 c
= SREF (this, thisindex
); thisindex
++;
735 if (some_multibyte
&& !ASCII_CHAR_P (c
))
736 c
= BYTE8_TO_CHAR (c
);
738 XSETFASTINT (elt
, c
);
740 else if (BOOL_VECTOR_P (this))
742 elt
= bool_vector_ref (this, thisindex
);
747 elt
= AREF (this, thisindex
);
751 /* Store this element into the result. */
758 else if (VECTORP (val
))
760 ASET (val
, toindex
, elt
);
766 CHECK_CHARACTER (elt
);
769 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
771 SSET (val
, toindex_byte
++, c
);
777 XSETCDR (prev
, last_tail
);
779 if (num_textprops
> 0)
782 ptrdiff_t last_to_end
= -1;
784 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
786 this = args
[textprops
[argnum
].argnum
];
787 props
= text_property_list (this,
789 make_number (SCHARS (this)),
791 /* If successive arguments have properties, be sure that the
792 value of `composition' property be the copy. */
793 if (last_to_end
== textprops
[argnum
].to
)
794 make_composition_value_copy (props
);
795 add_text_properties_from_list (val
, props
,
796 make_number (textprops
[argnum
].to
));
797 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
805 static Lisp_Object string_char_byte_cache_string
;
806 static ptrdiff_t string_char_byte_cache_charpos
;
807 static ptrdiff_t string_char_byte_cache_bytepos
;
810 clear_string_char_byte_cache (void)
812 string_char_byte_cache_string
= Qnil
;
815 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
818 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
821 ptrdiff_t best_below
, best_below_byte
;
822 ptrdiff_t best_above
, best_above_byte
;
824 best_below
= best_below_byte
= 0;
825 best_above
= SCHARS (string
);
826 best_above_byte
= SBYTES (string
);
827 if (best_above
== best_above_byte
)
830 if (EQ (string
, string_char_byte_cache_string
))
832 if (string_char_byte_cache_charpos
< char_index
)
834 best_below
= string_char_byte_cache_charpos
;
835 best_below_byte
= string_char_byte_cache_bytepos
;
839 best_above
= string_char_byte_cache_charpos
;
840 best_above_byte
= string_char_byte_cache_bytepos
;
844 if (char_index
- best_below
< best_above
- char_index
)
846 unsigned char *p
= SDATA (string
) + best_below_byte
;
848 while (best_below
< char_index
)
850 p
+= BYTES_BY_CHAR_HEAD (*p
);
853 i_byte
= p
- SDATA (string
);
857 unsigned char *p
= SDATA (string
) + best_above_byte
;
859 while (best_above
> char_index
)
862 while (!CHAR_HEAD_P (*p
)) p
--;
865 i_byte
= p
- SDATA (string
);
868 string_char_byte_cache_bytepos
= i_byte
;
869 string_char_byte_cache_charpos
= char_index
;
870 string_char_byte_cache_string
= string
;
875 /* Return the character index corresponding to BYTE_INDEX in STRING. */
878 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
881 ptrdiff_t best_below
, best_below_byte
;
882 ptrdiff_t best_above
, best_above_byte
;
884 best_below
= best_below_byte
= 0;
885 best_above
= SCHARS (string
);
886 best_above_byte
= SBYTES (string
);
887 if (best_above
== best_above_byte
)
890 if (EQ (string
, string_char_byte_cache_string
))
892 if (string_char_byte_cache_bytepos
< byte_index
)
894 best_below
= string_char_byte_cache_charpos
;
895 best_below_byte
= string_char_byte_cache_bytepos
;
899 best_above
= string_char_byte_cache_charpos
;
900 best_above_byte
= string_char_byte_cache_bytepos
;
904 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
906 unsigned char *p
= SDATA (string
) + best_below_byte
;
907 unsigned char *pend
= SDATA (string
) + byte_index
;
911 p
+= BYTES_BY_CHAR_HEAD (*p
);
915 i_byte
= p
- SDATA (string
);
919 unsigned char *p
= SDATA (string
) + best_above_byte
;
920 unsigned char *pbeg
= SDATA (string
) + byte_index
;
925 while (!CHAR_HEAD_P (*p
)) p
--;
929 i_byte
= p
- SDATA (string
);
932 string_char_byte_cache_bytepos
= i_byte
;
933 string_char_byte_cache_charpos
= i
;
934 string_char_byte_cache_string
= string
;
939 /* Convert STRING to a multibyte string. */
942 string_make_multibyte (Lisp_Object string
)
949 if (STRING_MULTIBYTE (string
))
952 nbytes
= count_size_as_multibyte (SDATA (string
),
954 /* If all the chars are ASCII, they won't need any more bytes
955 once converted. In that case, we can return STRING itself. */
956 if (nbytes
== SBYTES (string
))
959 buf
= SAFE_ALLOCA (nbytes
);
960 copy_text (SDATA (string
), buf
, SBYTES (string
),
963 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
970 /* Convert STRING (if unibyte) to a multibyte string without changing
971 the number of characters. Characters 0200 trough 0237 are
972 converted to eight-bit characters. */
975 string_to_multibyte (Lisp_Object string
)
982 if (STRING_MULTIBYTE (string
))
985 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
986 /* If all the chars are ASCII, they won't need any more bytes once
988 if (nbytes
== SBYTES (string
))
989 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
991 buf
= SAFE_ALLOCA (nbytes
);
992 memcpy (buf
, SDATA (string
), SBYTES (string
));
993 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
995 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1002 /* Convert STRING to a single-byte string. */
1005 string_make_unibyte (Lisp_Object string
)
1012 if (! STRING_MULTIBYTE (string
))
1015 nchars
= SCHARS (string
);
1017 buf
= SAFE_ALLOCA (nchars
);
1018 copy_text (SDATA (string
), buf
, SBYTES (string
),
1021 ret
= make_unibyte_string ((char *) buf
, nchars
);
1027 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1029 doc
: /* Return the multibyte equivalent of STRING.
1030 If STRING is unibyte and contains non-ASCII characters, the function
1031 `unibyte-char-to-multibyte' is used to convert each unibyte character
1032 to a multibyte character. In this case, the returned string is a
1033 newly created string with no text properties. If STRING is multibyte
1034 or entirely ASCII, it is returned unchanged. In particular, when
1035 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1036 \(When the characters are all ASCII, Emacs primitives will treat the
1037 string the same way whether it is unibyte or multibyte.) */)
1038 (Lisp_Object string
)
1040 CHECK_STRING (string
);
1042 return string_make_multibyte (string
);
1045 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1047 doc
: /* Return the unibyte equivalent of STRING.
1048 Multibyte character codes are converted to unibyte according to
1049 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1050 If the lookup in the translation table fails, this function takes just
1051 the low 8 bits of each character. */)
1052 (Lisp_Object string
)
1054 CHECK_STRING (string
);
1056 return string_make_unibyte (string
);
1059 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1061 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1062 If STRING is unibyte, the result is STRING itself.
1063 Otherwise it is a newly created string, with no text properties.
1064 If STRING is multibyte and contains a character of charset
1065 `eight-bit', it is converted to the corresponding single byte. */)
1066 (Lisp_Object string
)
1068 CHECK_STRING (string
);
1070 if (STRING_MULTIBYTE (string
))
1072 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1073 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1075 string
= make_unibyte_string ((char *) str
, bytes
);
1081 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1083 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1084 If STRING is multibyte, the result is STRING itself.
1085 Otherwise it is a newly created string, with no text properties.
1087 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1088 part of a correct utf-8 sequence), it is converted to the corresponding
1089 multibyte character of charset `eight-bit'.
1090 See also `string-to-multibyte'.
1092 Beware, this often doesn't really do what you think it does.
1093 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1094 If you're not sure, whether to use `string-as-multibyte' or
1095 `string-to-multibyte', use `string-to-multibyte'. */)
1096 (Lisp_Object string
)
1098 CHECK_STRING (string
);
1100 if (! STRING_MULTIBYTE (string
))
1102 Lisp_Object new_string
;
1103 ptrdiff_t nchars
, nbytes
;
1105 parse_str_as_multibyte (SDATA (string
),
1108 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1109 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1110 if (nbytes
!= SBYTES (string
))
1111 str_as_multibyte (SDATA (new_string
), nbytes
,
1112 SBYTES (string
), NULL
);
1113 string
= new_string
;
1114 set_string_intervals (string
, NULL
);
1119 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1121 doc
: /* Return a multibyte string with the same individual chars as STRING.
1122 If STRING is multibyte, the result is STRING itself.
1123 Otherwise it is a newly created string, with no text properties.
1125 If STRING is unibyte and contains an 8-bit byte, it is converted to
1126 the corresponding multibyte character of charset `eight-bit'.
1128 This differs from `string-as-multibyte' by converting each byte of a correct
1129 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1130 correct sequence. */)
1131 (Lisp_Object string
)
1133 CHECK_STRING (string
);
1135 return string_to_multibyte (string
);
1138 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1140 doc
: /* Return a unibyte string with the same individual chars as STRING.
1141 If STRING is unibyte, the result is STRING itself.
1142 Otherwise it is a newly created string, with no text properties,
1143 where each `eight-bit' character is converted to the corresponding byte.
1144 If STRING contains a non-ASCII, non-`eight-bit' character,
1145 an error is signaled. */)
1146 (Lisp_Object string
)
1148 CHECK_STRING (string
);
1150 if (STRING_MULTIBYTE (string
))
1152 ptrdiff_t chars
= SCHARS (string
);
1153 unsigned char *str
= xmalloc (chars
);
1154 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1156 if (converted
< chars
)
1157 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1158 string
= make_unibyte_string ((char *) str
, chars
);
1165 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1166 doc
: /* Return a copy of ALIST.
1167 This is an alist which represents the same mapping from objects to objects,
1168 but does not share the alist structure with ALIST.
1169 The objects mapped (cars and cdrs of elements of the alist)
1170 are shared, however.
1171 Elements of ALIST that are not conses are also shared. */)
1174 register Lisp_Object tem
;
1179 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1180 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1182 register Lisp_Object car
;
1186 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1191 /* Check that ARRAY can have a valid subarray [FROM..TO),
1192 given that its size is SIZE.
1193 If FROM is nil, use 0; if TO is nil, use SIZE.
1194 Count negative values backwards from the end.
1195 Set *IFROM and *ITO to the two indexes used. */
1198 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1199 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1203 if (INTEGERP (from
))
1209 else if (NILP (from
))
1212 wrong_type_argument (Qintegerp
, from
);
1223 wrong_type_argument (Qintegerp
, to
);
1225 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1226 args_out_of_range_3 (array
, from
, to
);
1232 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1233 doc
: /* Return a new string whose contents are a substring of STRING.
1234 The returned string consists of the characters between index FROM
1235 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1236 zero-indexed: 0 means the first character of STRING. Negative values
1237 are counted from the end of STRING. If TO is nil, the substring runs
1238 to the end of STRING.
1240 The STRING argument may also be a vector. In that case, the return
1241 value is a new vector that contains the elements between index FROM
1242 \(inclusive) and index TO (exclusive) of that vector argument.
1244 With one argument, just copy STRING (with properties, if any). */)
1245 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1248 ptrdiff_t size
, ifrom
, ito
;
1250 size
= CHECK_VECTOR_OR_STRING (string
);
1251 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1253 if (STRINGP (string
))
1256 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1258 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1259 res
= make_specified_string (SSDATA (string
) + from_byte
,
1260 ito
- ifrom
, to_byte
- from_byte
,
1261 STRING_MULTIBYTE (string
));
1262 copy_text_properties (make_number (ifrom
), make_number (ito
),
1263 string
, make_number (0), res
, Qnil
);
1266 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1272 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1273 doc
: /* Return a substring of STRING, without text properties.
1274 It starts at index FROM and ends before TO.
1275 TO may be nil or omitted; then the substring runs to the end of STRING.
1276 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1277 If FROM or TO is negative, it counts from the end.
1279 With one argument, just copy STRING without its properties. */)
1280 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1282 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1284 CHECK_STRING (string
);
1286 size
= SCHARS (string
);
1287 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1289 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1291 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1292 return make_specified_string (SSDATA (string
) + from_byte
,
1293 to_char
- from_char
, to_byte
- from_byte
,
1294 STRING_MULTIBYTE (string
));
1297 /* Extract a substring of STRING, giving start and end positions
1298 both in characters and in bytes. */
1301 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1302 ptrdiff_t to
, ptrdiff_t to_byte
)
1305 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1307 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1308 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1310 if (STRINGP (string
))
1312 res
= make_specified_string (SSDATA (string
) + from_byte
,
1313 to
- from
, to_byte
- from_byte
,
1314 STRING_MULTIBYTE (string
));
1315 copy_text_properties (make_number (from
), make_number (to
),
1316 string
, make_number (0), res
, Qnil
);
1319 res
= Fvector (to
- from
, aref_addr (string
, from
));
1324 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1325 doc
: /* Take cdr N times on LIST, return the result. */)
1326 (Lisp_Object n
, Lisp_Object list
)
1331 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1334 CHECK_LIST_CONS (list
, list
);
1340 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1341 doc
: /* Return the Nth element of LIST.
1342 N counts from zero. If LIST is not that long, nil is returned. */)
1343 (Lisp_Object n
, Lisp_Object list
)
1345 return Fcar (Fnthcdr (n
, list
));
1348 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1349 doc
: /* Return element of SEQUENCE at index N. */)
1350 (register Lisp_Object sequence
, Lisp_Object n
)
1353 if (CONSP (sequence
) || NILP (sequence
))
1354 return Fcar (Fnthcdr (n
, sequence
));
1356 /* Faref signals a "not array" error, so check here. */
1357 CHECK_ARRAY (sequence
, Qsequencep
);
1358 return Faref (sequence
, n
);
1361 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1362 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1363 The value is actually the tail of LIST whose car is ELT. */)
1364 (register Lisp_Object elt
, Lisp_Object list
)
1366 register Lisp_Object tail
;
1367 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1369 register Lisp_Object tem
;
1370 CHECK_LIST_CONS (tail
, list
);
1372 if (! NILP (Fequal (elt
, tem
)))
1379 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1380 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1381 The value is actually the tail of LIST whose car is ELT. */)
1382 (register Lisp_Object elt
, Lisp_Object list
)
1386 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1390 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1394 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1405 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1406 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1407 The value is actually the tail of LIST whose car is ELT. */)
1408 (register Lisp_Object elt
, Lisp_Object list
)
1410 register Lisp_Object tail
;
1413 return Fmemq (elt
, list
);
1415 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1417 register Lisp_Object tem
;
1418 CHECK_LIST_CONS (tail
, list
);
1420 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1427 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1428 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1429 The value is actually the first element of LIST whose car is KEY.
1430 Elements of LIST that are not conses are ignored. */)
1431 (Lisp_Object key
, Lisp_Object list
)
1436 || (CONSP (XCAR (list
))
1437 && EQ (XCAR (XCAR (list
)), key
)))
1442 || (CONSP (XCAR (list
))
1443 && EQ (XCAR (XCAR (list
)), key
)))
1448 || (CONSP (XCAR (list
))
1449 && EQ (XCAR (XCAR (list
)), key
)))
1459 /* Like Fassq but never report an error and do not allow quits.
1460 Use only on lists known never to be circular. */
1463 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1466 && (!CONSP (XCAR (list
))
1467 || !EQ (XCAR (XCAR (list
)), key
)))
1470 return CAR_SAFE (list
);
1473 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1474 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1475 The value is actually the first element of LIST whose car equals KEY. */)
1476 (Lisp_Object key
, Lisp_Object list
)
1483 || (CONSP (XCAR (list
))
1484 && (car
= XCAR (XCAR (list
)),
1485 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1490 || (CONSP (XCAR (list
))
1491 && (car
= XCAR (XCAR (list
)),
1492 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1497 || (CONSP (XCAR (list
))
1498 && (car
= XCAR (XCAR (list
)),
1499 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1509 /* Like Fassoc but never report an error and do not allow quits.
1510 Use only on lists known never to be circular. */
1513 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1516 && (!CONSP (XCAR (list
))
1517 || (!EQ (XCAR (XCAR (list
)), key
)
1518 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1521 return CONSP (list
) ? XCAR (list
) : Qnil
;
1524 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1525 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1526 The value is actually the first element of LIST whose cdr is KEY. */)
1527 (register Lisp_Object key
, Lisp_Object list
)
1532 || (CONSP (XCAR (list
))
1533 && EQ (XCDR (XCAR (list
)), key
)))
1538 || (CONSP (XCAR (list
))
1539 && EQ (XCDR (XCAR (list
)), key
)))
1544 || (CONSP (XCAR (list
))
1545 && EQ (XCDR (XCAR (list
)), key
)))
1555 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1556 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1557 The value is actually the first element of LIST whose cdr equals KEY. */)
1558 (Lisp_Object key
, Lisp_Object list
)
1565 || (CONSP (XCAR (list
))
1566 && (cdr
= XCDR (XCAR (list
)),
1567 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1572 || (CONSP (XCAR (list
))
1573 && (cdr
= XCDR (XCAR (list
)),
1574 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1579 || (CONSP (XCAR (list
))
1580 && (cdr
= XCDR (XCAR (list
)),
1581 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1591 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1592 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1593 More precisely, this function skips any members `eq' to ELT at the
1594 front of LIST, then removes members `eq' to ELT from the remaining
1595 sublist by modifying its list structure, then returns the resulting
1598 Write `(setq foo (delq element foo))' to be sure of correctly changing
1599 the value of a list `foo'. */)
1600 (register Lisp_Object elt
, Lisp_Object list
)
1602 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1605 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1607 Lisp_Object tem
= XCAR (tail
);
1613 Fsetcdr (prev
, XCDR (tail
));
1621 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1622 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1623 SEQ must be a sequence (i.e. a list, a vector, or a string).
1624 The return value is a sequence of the same type.
1626 If SEQ is a list, this behaves like `delq', except that it compares
1627 with `equal' instead of `eq'. In particular, it may remove elements
1628 by altering the list structure.
1630 If SEQ is not a list, deletion is never performed destructively;
1631 instead this function creates and returns a new vector or string.
1633 Write `(setq foo (delete element foo))' to be sure of correctly
1634 changing the value of a sequence `foo'. */)
1635 (Lisp_Object elt
, Lisp_Object seq
)
1641 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1642 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1645 if (n
!= ASIZE (seq
))
1647 struct Lisp_Vector
*p
= allocate_vector (n
);
1649 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1650 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1651 p
->contents
[n
++] = AREF (seq
, i
);
1653 XSETVECTOR (seq
, p
);
1656 else if (STRINGP (seq
))
1658 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1661 for (i
= nchars
= nbytes
= ibyte
= 0;
1663 ++i
, ibyte
+= cbytes
)
1665 if (STRING_MULTIBYTE (seq
))
1667 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1668 cbytes
= CHAR_BYTES (c
);
1676 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1683 if (nchars
!= SCHARS (seq
))
1687 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1688 if (!STRING_MULTIBYTE (seq
))
1689 STRING_SET_UNIBYTE (tem
);
1691 for (i
= nchars
= nbytes
= ibyte
= 0;
1693 ++i
, ibyte
+= cbytes
)
1695 if (STRING_MULTIBYTE (seq
))
1697 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1698 cbytes
= CHAR_BYTES (c
);
1706 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1708 unsigned char *from
= SDATA (seq
) + ibyte
;
1709 unsigned char *to
= SDATA (tem
) + nbytes
;
1715 for (n
= cbytes
; n
--; )
1725 Lisp_Object tail
, prev
;
1727 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1729 CHECK_LIST_CONS (tail
, seq
);
1731 if (!NILP (Fequal (elt
, XCAR (tail
))))
1736 Fsetcdr (prev
, XCDR (tail
));
1747 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1748 doc
: /* Reverse order of items in a list, vector or string SEQ.
1749 If SEQ is a list, it should be nil-terminated.
1750 This function may destructively modify SEQ to produce the value. */)
1755 else if (STRINGP (seq
))
1756 return Freverse (seq
);
1757 else if (CONSP (seq
))
1759 Lisp_Object prev
, tail
, next
;
1761 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1764 CHECK_LIST_CONS (tail
, tail
);
1766 Fsetcdr (tail
, prev
);
1771 else if (VECTORP (seq
))
1773 ptrdiff_t i
, size
= ASIZE (seq
);
1775 for (i
= 0; i
< size
/ 2; i
++)
1777 Lisp_Object tem
= AREF (seq
, i
);
1778 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1779 ASET (seq
, size
- i
- 1, tem
);
1782 else if (BOOL_VECTOR_P (seq
))
1784 ptrdiff_t i
, size
= bool_vector_size (seq
);
1786 for (i
= 0; i
< size
/ 2; i
++)
1788 bool tem
= bool_vector_bitref (seq
, i
);
1789 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1790 bool_vector_set (seq
, size
- i
- 1, tem
);
1794 wrong_type_argument (Qarrayp
, seq
);
1798 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1799 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1800 See also the function `nreverse', which is used more often. */)
1807 else if (CONSP (seq
))
1809 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1812 new = Fcons (XCAR (seq
), new);
1814 CHECK_LIST_END (seq
, seq
);
1816 else if (VECTORP (seq
))
1818 ptrdiff_t i
, size
= ASIZE (seq
);
1820 new = make_uninit_vector (size
);
1821 for (i
= 0; i
< size
; i
++)
1822 ASET (new, i
, AREF (seq
, size
- i
- 1));
1824 else if (BOOL_VECTOR_P (seq
))
1827 EMACS_INT nbits
= bool_vector_size (seq
);
1829 new = make_uninit_bool_vector (nbits
);
1830 for (i
= 0; i
< nbits
; i
++)
1831 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1833 else if (STRINGP (seq
))
1835 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1841 new = make_uninit_string (size
);
1842 for (i
= 0; i
< size
; i
++)
1843 SSET (new, i
, SREF (seq
, size
- i
- 1));
1847 unsigned char *p
, *q
;
1849 new = make_uninit_multibyte_string (size
, bytes
);
1850 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1851 while (q
> SDATA (new))
1855 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1857 CHAR_STRING (ch
, q
);
1862 wrong_type_argument (Qsequencep
, seq
);
1866 /* Sort LIST using PREDICATE, preserving original order of elements
1867 considered as equal. */
1870 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1872 Lisp_Object front
, back
;
1873 register Lisp_Object len
, tem
;
1874 struct gcpro gcpro1
, gcpro2
;
1878 len
= Flength (list
);
1879 length
= XINT (len
);
1883 XSETINT (len
, (length
/ 2) - 1);
1884 tem
= Fnthcdr (len
, list
);
1886 Fsetcdr (tem
, Qnil
);
1888 GCPRO2 (front
, back
);
1889 front
= Fsort (front
, predicate
);
1890 back
= Fsort (back
, predicate
);
1892 return merge (front
, back
, predicate
);
1895 /* Using PRED to compare, return whether A and B are in order.
1896 Compare stably when A appeared before B in the input. */
1898 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1900 return NILP (call2 (pred
, b
, a
));
1903 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1904 into DEST. Argument arrays must be nonempty and must not overlap,
1905 except that B might be the last part of DEST. */
1907 merge_vectors (Lisp_Object pred
,
1908 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1909 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1910 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1912 eassume (0 < alen
&& 0 < blen
);
1913 Lisp_Object
const *alim
= a
+ alen
;
1914 Lisp_Object
const *blim
= b
+ blen
;
1918 if (inorder (pred
, a
[0], b
[0]))
1924 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1933 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1940 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1941 temporary storage. LEN must be at least 2. */
1943 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1944 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1945 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1948 ptrdiff_t halflen
= len
>> 1;
1949 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1950 if (1 < len
- halflen
)
1951 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1952 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1955 /* Using PRED to compare, sort from LEN-length SRC into DST.
1956 Len must be positive. */
1958 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1959 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1960 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1963 ptrdiff_t halflen
= len
>> 1;
1969 sort_vector_inplace (pred
, halflen
, src
, dest
);
1970 if (1 < len
- halflen
)
1971 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1972 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1976 /* Sort VECTOR in place using PREDICATE, preserving original order of
1977 elements considered as equal. */
1980 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1982 ptrdiff_t len
= ASIZE (vector
);
1985 ptrdiff_t halflen
= len
>> 1;
1987 struct gcpro gcpro1
, gcpro2
;
1988 GCPRO2 (vector
, predicate
);
1990 SAFE_ALLOCA_LISP (tmp
, halflen
);
1991 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1992 tmp
[i
] = make_number (0);
1993 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1998 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1999 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2000 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2001 modified by side effects. PREDICATE is called with two elements of
2002 SEQ, and should return non-nil if the first element should sort before
2004 (Lisp_Object seq
, Lisp_Object predicate
)
2007 seq
= sort_list (seq
, predicate
);
2008 else if (VECTORP (seq
))
2009 sort_vector (seq
, predicate
);
2010 else if (!NILP (seq
))
2011 wrong_type_argument (Qsequencep
, seq
);
2016 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2019 register Lisp_Object tail
;
2021 register Lisp_Object l1
, l2
;
2022 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2029 /* It is sufficient to protect org_l1 and org_l2.
2030 When l1 and l2 are updated, we copy the new values
2031 back into the org_ vars. */
2032 GCPRO4 (org_l1
, org_l2
, pred
, value
);
2052 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2067 Fsetcdr (tail
, tem
);
2073 /* This does not check for quits. That is safe since it must terminate. */
2075 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2076 doc
: /* Extract a value from a property list.
2077 PLIST is a property list, which is a list of the form
2078 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2079 corresponding to the given PROP, or nil if PROP is not one of the
2080 properties on the list. This function never signals an error. */)
2081 (Lisp_Object plist
, Lisp_Object prop
)
2083 Lisp_Object tail
, halftail
;
2085 /* halftail is used to detect circular lists. */
2086 tail
= halftail
= plist
;
2087 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2089 if (EQ (prop
, XCAR (tail
)))
2090 return XCAR (XCDR (tail
));
2092 tail
= XCDR (XCDR (tail
));
2093 halftail
= XCDR (halftail
);
2094 if (EQ (tail
, halftail
))
2101 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2102 doc
: /* Return the value of SYMBOL's PROPNAME property.
2103 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2104 (Lisp_Object symbol
, Lisp_Object propname
)
2106 CHECK_SYMBOL (symbol
);
2107 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2110 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2111 doc
: /* Change value in PLIST of PROP to VAL.
2112 PLIST is a property list, which is a list of the form
2113 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2114 If PROP is already a property on the list, its value is set to VAL,
2115 otherwise the new PROP VAL pair is added. The new plist is returned;
2116 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2117 The PLIST is modified by side effects. */)
2118 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2120 register Lisp_Object tail
, prev
;
2121 Lisp_Object newcell
;
2123 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2124 tail
= XCDR (XCDR (tail
)))
2126 if (EQ (prop
, XCAR (tail
)))
2128 Fsetcar (XCDR (tail
), val
);
2135 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2139 Fsetcdr (XCDR (prev
), newcell
);
2143 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2144 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2145 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2146 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2148 CHECK_SYMBOL (symbol
);
2150 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2154 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2155 doc
: /* Extract a value from a property list, comparing with `equal'.
2156 PLIST is a property list, which is a list of the form
2157 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2158 corresponding to the given PROP, or nil if PROP is not
2159 one of the properties on the list. */)
2160 (Lisp_Object plist
, Lisp_Object prop
)
2165 CONSP (tail
) && CONSP (XCDR (tail
));
2166 tail
= XCDR (XCDR (tail
)))
2168 if (! NILP (Fequal (prop
, XCAR (tail
))))
2169 return XCAR (XCDR (tail
));
2174 CHECK_LIST_END (tail
, prop
);
2179 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2180 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2181 PLIST is a property list, which is a list of the form
2182 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2183 If PROP is already a property on the list, its value is set to VAL,
2184 otherwise the new PROP VAL pair is added. The new plist is returned;
2185 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2186 The PLIST is modified by side effects. */)
2187 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2189 register Lisp_Object tail
, prev
;
2190 Lisp_Object newcell
;
2192 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2193 tail
= XCDR (XCDR (tail
)))
2195 if (! NILP (Fequal (prop
, XCAR (tail
))))
2197 Fsetcar (XCDR (tail
), val
);
2204 newcell
= list2 (prop
, val
);
2208 Fsetcdr (XCDR (prev
), newcell
);
2212 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2213 doc
: /* Return t if the two args are the same Lisp object.
2214 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2215 (Lisp_Object obj1
, Lisp_Object obj2
)
2218 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2220 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2223 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2224 doc
: /* Return t if two Lisp objects have similar structure and contents.
2225 They must have the same data type.
2226 Conses are compared by comparing the cars and the cdrs.
2227 Vectors and strings are compared element by element.
2228 Numbers are compared by value, but integers cannot equal floats.
2229 (Use `=' if you want integers and floats to be able to be equal.)
2230 Symbols must match exactly. */)
2231 (register Lisp_Object o1
, Lisp_Object o2
)
2233 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2236 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2237 doc
: /* Return t if two Lisp objects have similar structure and contents.
2238 This is like `equal' except that it compares the text properties
2239 of strings. (`equal' ignores text properties.) */)
2240 (register Lisp_Object o1
, Lisp_Object o2
)
2242 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2245 /* DEPTH is current depth of recursion. Signal an error if it
2247 PROPS means compare string text properties too. */
2250 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2256 error ("Stack overflow in equal");
2259 Lisp_Object args
[2];
2262 ht
= Fmake_hash_table (2, args
);
2266 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2268 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2270 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2272 { /* `o1' was seen already. */
2273 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2274 if (!NILP (Fmemq (o2
, o2s
)))
2277 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2280 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2290 if (XTYPE (o1
) != XTYPE (o2
))
2299 d1
= extract_float (o1
);
2300 d2
= extract_float (o2
);
2301 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2302 though they are not =. */
2303 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2307 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2311 /* FIXME: This inf-loops in a circular list! */
2315 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2319 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2320 depth
+ 1, props
, ht
)
2321 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2322 depth
+ 1, props
, ht
))
2324 o1
= XOVERLAY (o1
)->plist
;
2325 o2
= XOVERLAY (o2
)->plist
;
2330 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2331 && (XMARKER (o1
)->buffer
== 0
2332 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2336 case Lisp_Vectorlike
:
2339 ptrdiff_t size
= ASIZE (o1
);
2340 /* Pseudovectors have the type encoded in the size field, so this test
2341 actually checks that the objects have the same type as well as the
2343 if (ASIZE (o2
) != size
)
2345 /* Boolvectors are compared much like strings. */
2346 if (BOOL_VECTOR_P (o1
))
2348 EMACS_INT size
= bool_vector_size (o1
);
2349 if (size
!= bool_vector_size (o2
))
2351 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2352 bool_vector_bytes (size
)))
2356 if (WINDOW_CONFIGURATIONP (o1
))
2357 return compare_window_configurations (o1
, o2
, 0);
2359 /* Aside from them, only true vectors, char-tables, compiled
2360 functions, and fonts (font-spec, font-entity, font-object)
2361 are sensible to compare, so eliminate the others now. */
2362 if (size
& PSEUDOVECTOR_FLAG
)
2364 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2367 size
&= PSEUDOVECTOR_SIZE_MASK
;
2369 for (i
= 0; i
< size
; i
++)
2374 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2382 if (SCHARS (o1
) != SCHARS (o2
))
2384 if (SBYTES (o1
) != SBYTES (o2
))
2386 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2388 if (props
&& !compare_string_intervals (o1
, o2
))
2400 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2401 doc
: /* Store each element of ARRAY with ITEM.
2402 ARRAY is a vector, string, char-table, or bool-vector. */)
2403 (Lisp_Object array
, Lisp_Object item
)
2405 register ptrdiff_t size
, idx
;
2407 if (VECTORP (array
))
2408 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2409 ASET (array
, idx
, item
);
2410 else if (CHAR_TABLE_P (array
))
2414 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2415 set_char_table_contents (array
, i
, item
);
2416 set_char_table_defalt (array
, item
);
2418 else if (STRINGP (array
))
2420 register unsigned char *p
= SDATA (array
);
2422 CHECK_CHARACTER (item
);
2423 charval
= XFASTINT (item
);
2424 size
= SCHARS (array
);
2425 if (STRING_MULTIBYTE (array
))
2427 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2428 int len
= CHAR_STRING (charval
, str
);
2429 ptrdiff_t size_byte
= SBYTES (array
);
2431 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2432 || SCHARS (array
) * len
!= size_byte
)
2433 error ("Attempt to change byte length of a string");
2434 for (idx
= 0; idx
< size_byte
; idx
++)
2435 *p
++ = str
[idx
% len
];
2438 for (idx
= 0; idx
< size
; idx
++)
2441 else if (BOOL_VECTOR_P (array
))
2442 return bool_vector_fill (array
, item
);
2444 wrong_type_argument (Qarrayp
, array
);
2448 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2450 doc
: /* Clear the contents of STRING.
2451 This makes STRING unibyte and may change its length. */)
2452 (Lisp_Object string
)
2455 CHECK_STRING (string
);
2456 len
= SBYTES (string
);
2457 memset (SDATA (string
), 0, len
);
2458 STRING_SET_CHARS (string
, len
);
2459 STRING_SET_UNIBYTE (string
);
2465 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2467 Lisp_Object args
[2];
2470 return Fnconc (2, args
);
2473 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2474 doc
: /* Concatenate any number of lists by altering them.
2475 Only the last argument is not altered, and need not be a list.
2476 usage: (nconc &rest LISTS) */)
2477 (ptrdiff_t nargs
, Lisp_Object
*args
)
2480 register Lisp_Object tail
, tem
, val
;
2484 for (argnum
= 0; argnum
< nargs
; argnum
++)
2487 if (NILP (tem
)) continue;
2492 if (argnum
+ 1 == nargs
) break;
2494 CHECK_LIST_CONS (tem
, tem
);
2503 tem
= args
[argnum
+ 1];
2504 Fsetcdr (tail
, tem
);
2506 args
[argnum
+ 1] = tail
;
2512 /* This is the guts of all mapping functions.
2513 Apply FN to each element of SEQ, one by one,
2514 storing the results into elements of VALS, a C vector of Lisp_Objects.
2515 LENI is the length of VALS, which should also be the length of SEQ. */
2518 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2520 Lisp_Object tail
, dummy
;
2522 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2526 /* Don't let vals contain any garbage when GC happens. */
2527 memsetnil (vals
, leni
);
2529 GCPRO3 (dummy
, fn
, seq
);
2531 gcpro1
.nvars
= leni
;
2535 /* We need not explicitly protect `tail' because it is used only on lists, and
2536 1) lists are not relocated and 2) the list is marked via `seq' so will not
2539 if (VECTORP (seq
) || COMPILEDP (seq
))
2541 for (i
= 0; i
< leni
; i
++)
2543 dummy
= call1 (fn
, AREF (seq
, i
));
2548 else if (BOOL_VECTOR_P (seq
))
2550 for (i
= 0; i
< leni
; i
++)
2552 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2557 else if (STRINGP (seq
))
2561 for (i
= 0, i_byte
= 0; i
< leni
;)
2564 ptrdiff_t i_before
= i
;
2566 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2567 XSETFASTINT (dummy
, c
);
2568 dummy
= call1 (fn
, dummy
);
2570 vals
[i_before
] = dummy
;
2573 else /* Must be a list, since Flength did not get an error */
2576 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2578 dummy
= call1 (fn
, XCAR (tail
));
2588 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2589 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2590 In between each pair of results, stick in SEPARATOR. Thus, " " as
2591 SEPARATOR results in spaces between the values returned by FUNCTION.
2592 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2593 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2596 register EMACS_INT leni
;
2599 register Lisp_Object
*args
;
2600 struct gcpro gcpro1
;
2604 len
= Flength (sequence
);
2605 if (CHAR_TABLE_P (sequence
))
2606 wrong_type_argument (Qlistp
, sequence
);
2608 nargs
= leni
+ leni
- 1;
2609 if (nargs
< 0) return empty_unibyte_string
;
2611 SAFE_ALLOCA_LISP (args
, nargs
);
2614 mapcar1 (leni
, args
, function
, sequence
);
2617 for (i
= leni
- 1; i
> 0; i
--)
2618 args
[i
+ i
] = args
[i
];
2620 for (i
= 1; i
< nargs
; i
+= 2)
2621 args
[i
] = separator
;
2623 ret
= Fconcat (nargs
, args
);
2629 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2630 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2631 The result is a list just as long as SEQUENCE.
2632 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2633 (Lisp_Object function
, Lisp_Object sequence
)
2635 register Lisp_Object len
;
2636 register EMACS_INT leni
;
2637 register Lisp_Object
*args
;
2641 len
= Flength (sequence
);
2642 if (CHAR_TABLE_P (sequence
))
2643 wrong_type_argument (Qlistp
, sequence
);
2644 leni
= XFASTINT (len
);
2646 SAFE_ALLOCA_LISP (args
, leni
);
2648 mapcar1 (leni
, args
, function
, sequence
);
2650 ret
= Flist (leni
, args
);
2656 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2657 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2658 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2659 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2660 (Lisp_Object function
, Lisp_Object sequence
)
2662 register EMACS_INT leni
;
2664 leni
= XFASTINT (Flength (sequence
));
2665 if (CHAR_TABLE_P (sequence
))
2666 wrong_type_argument (Qlistp
, sequence
);
2667 mapcar1 (leni
, 0, function
, sequence
);
2672 /* This is how C code calls `yes-or-no-p' and allows the user
2675 Anything that calls this function must protect from GC! */
2678 do_yes_or_no_p (Lisp_Object prompt
)
2680 return call1 (intern ("yes-or-no-p"), prompt
);
2683 /* Anything that calls this function must protect from GC! */
2685 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2686 doc
: /* Ask user a yes-or-no question.
2687 Return t if answer is yes, and nil if the answer is no.
2688 PROMPT is the string to display to ask the question. It should end in
2689 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2691 The user must confirm the answer with RET, and can edit it until it
2694 If dialog boxes are supported, a dialog box will be used
2695 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2696 (Lisp_Object prompt
)
2699 struct gcpro gcpro1
;
2701 CHECK_STRING (prompt
);
2703 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2706 Lisp_Object pane
, menu
, obj
;
2707 redisplay_preserve_echo_area (4);
2708 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2709 Fcons (build_string ("No"), Qnil
));
2711 menu
= Fcons (prompt
, pane
);
2712 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2717 AUTO_STRING (yes_or_no
, "(yes or no) ");
2718 prompt
= Fconcat (2, (Lisp_Object
[]) {prompt
, yes_or_no
});
2723 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2724 Qyes_or_no_p_history
, Qnil
,
2726 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2731 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2739 message1 ("Please answer yes or no.");
2740 Fsleep_for (make_number (2), Qnil
);
2744 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2745 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2747 Each of the three load averages is multiplied by 100, then converted
2750 When USE-FLOATS is non-nil, floats will be used instead of integers.
2751 These floats are not multiplied by 100.
2753 If the 5-minute or 15-minute load averages are not available, return a
2754 shortened list, containing only those averages which are available.
2756 An error is thrown if the load average can't be obtained. In some
2757 cases making it work would require Emacs being installed setuid or
2758 setgid so that it can read kernel information, and that usually isn't
2760 (Lisp_Object use_floats
)
2763 int loads
= getloadavg (load_ave
, 3);
2764 Lisp_Object ret
= Qnil
;
2767 error ("load-average not implemented for this operating system");
2771 Lisp_Object load
= (NILP (use_floats
)
2772 ? make_number (100.0 * load_ave
[loads
])
2773 : make_float (load_ave
[loads
]));
2774 ret
= Fcons (load
, ret
);
2780 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2781 doc
: /* Return t if FEATURE is present in this Emacs.
2783 Use this to conditionalize execution of lisp code based on the
2784 presence or absence of Emacs or environment extensions.
2785 Use `provide' to declare that a feature is available. This function
2786 looks at the value of the variable `features'. The optional argument
2787 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2788 (Lisp_Object feature
, Lisp_Object subfeature
)
2790 register Lisp_Object tem
;
2791 CHECK_SYMBOL (feature
);
2792 tem
= Fmemq (feature
, Vfeatures
);
2793 if (!NILP (tem
) && !NILP (subfeature
))
2794 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2795 return (NILP (tem
)) ? Qnil
: Qt
;
2798 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2799 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2800 The optional argument SUBFEATURES should be a list of symbols listing
2801 particular subfeatures supported in this version of FEATURE. */)
2802 (Lisp_Object feature
, Lisp_Object subfeatures
)
2804 register Lisp_Object tem
;
2805 CHECK_SYMBOL (feature
);
2806 CHECK_LIST (subfeatures
);
2807 if (!NILP (Vautoload_queue
))
2808 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2810 tem
= Fmemq (feature
, Vfeatures
);
2812 Vfeatures
= Fcons (feature
, Vfeatures
);
2813 if (!NILP (subfeatures
))
2814 Fput (feature
, Qsubfeatures
, subfeatures
);
2815 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2817 /* Run any load-hooks for this file. */
2818 tem
= Fassq (feature
, Vafter_load_alist
);
2820 Fmapc (Qfuncall
, XCDR (tem
));
2825 /* `require' and its subroutines. */
2827 /* List of features currently being require'd, innermost first. */
2829 static Lisp_Object require_nesting_list
;
2832 require_unwind (Lisp_Object old_value
)
2834 require_nesting_list
= old_value
;
2837 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2838 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2839 If FEATURE is not a member of the list `features', then the feature
2840 is not loaded; so load the file FILENAME.
2841 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2842 and `load' will try to load this name appended with the suffix `.elc' or
2843 `.el', in that order. The name without appended suffix will not be used.
2844 See `get-load-suffixes' for the complete list of suffixes.
2845 If the optional third argument NOERROR is non-nil,
2846 then return nil if the file is not found instead of signaling an error.
2847 Normally the return value is FEATURE.
2848 The normal messages at start and end of loading FILENAME are suppressed. */)
2849 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2852 struct gcpro gcpro1
, gcpro2
;
2853 bool from_file
= load_in_progress
;
2855 CHECK_SYMBOL (feature
);
2857 /* Record the presence of `require' in this file
2858 even if the feature specified is already loaded.
2859 But not more than once in any file,
2860 and not when we aren't loading or reading from a file. */
2862 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2863 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2868 tem
= Fcons (Qrequire
, feature
);
2869 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2870 LOADHIST_ATTACH (tem
);
2872 tem
= Fmemq (feature
, Vfeatures
);
2876 ptrdiff_t count
= SPECPDL_INDEX ();
2879 /* This is to make sure that loadup.el gives a clear picture
2880 of what files are preloaded and when. */
2881 if (! NILP (Vpurify_flag
))
2882 error ("(require %s) while preparing to dump",
2883 SDATA (SYMBOL_NAME (feature
)));
2885 /* A certain amount of recursive `require' is legitimate,
2886 but if we require the same feature recursively 3 times,
2888 tem
= require_nesting_list
;
2889 while (! NILP (tem
))
2891 if (! NILP (Fequal (feature
, XCAR (tem
))))
2896 error ("Recursive `require' for feature `%s'",
2897 SDATA (SYMBOL_NAME (feature
)));
2899 /* Update the list for any nested `require's that occur. */
2900 record_unwind_protect (require_unwind
, require_nesting_list
);
2901 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2903 /* Value saved here is to be restored into Vautoload_queue */
2904 record_unwind_protect (un_autoload
, Vautoload_queue
);
2905 Vautoload_queue
= Qt
;
2907 /* Load the file. */
2908 GCPRO2 (feature
, filename
);
2909 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2910 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2913 /* If load failed entirely, return nil. */
2915 return unbind_to (count
, Qnil
);
2917 tem
= Fmemq (feature
, Vfeatures
);
2919 error ("Required feature `%s' was not provided",
2920 SDATA (SYMBOL_NAME (feature
)));
2922 /* Once loading finishes, don't undo it. */
2923 Vautoload_queue
= Qt
;
2924 feature
= unbind_to (count
, feature
);
2930 /* Primitives for work of the "widget" library.
2931 In an ideal world, this section would not have been necessary.
2932 However, lisp function calls being as slow as they are, it turns
2933 out that some functions in the widget library (wid-edit.el) are the
2934 bottleneck of Widget operation. Here is their translation to C,
2935 for the sole reason of efficiency. */
2937 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2938 doc
: /* Return non-nil if PLIST has the property PROP.
2939 PLIST is a property list, which is a list of the form
2940 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2941 Unlike `plist-get', this allows you to distinguish between a missing
2942 property and a property with the value nil.
2943 The value is actually the tail of PLIST whose car is PROP. */)
2944 (Lisp_Object plist
, Lisp_Object prop
)
2946 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2949 plist
= XCDR (plist
);
2950 plist
= CDR (plist
);
2955 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2956 doc
: /* In WIDGET, set PROPERTY to VALUE.
2957 The value can later be retrieved with `widget-get'. */)
2958 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2960 CHECK_CONS (widget
);
2961 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2965 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2966 doc
: /* In WIDGET, get the value of PROPERTY.
2967 The value could either be specified when the widget was created, or
2968 later with `widget-put'. */)
2969 (Lisp_Object widget
, Lisp_Object property
)
2977 CHECK_CONS (widget
);
2978 tmp
= Fplist_member (XCDR (widget
), property
);
2984 tmp
= XCAR (widget
);
2987 widget
= Fget (tmp
, Qwidget_type
);
2991 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2992 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2993 ARGS are passed as extra arguments to the function.
2994 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2995 (ptrdiff_t nargs
, Lisp_Object
*args
)
2997 /* This function can GC. */
2998 Lisp_Object newargs
[3];
2999 struct gcpro gcpro1
, gcpro2
;
3002 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3003 newargs
[1] = args
[0];
3004 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3005 GCPRO2 (newargs
[0], newargs
[2]);
3006 result
= Fapply (3, newargs
);
3011 #ifdef HAVE_LANGINFO_CODESET
3012 #include <langinfo.h>
3015 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3016 doc
: /* Access locale data ITEM for the current C locale, if available.
3017 ITEM should be one of the following:
3019 `codeset', returning the character set as a string (locale item CODESET);
3021 `days', returning a 7-element vector of day names (locale items DAY_n);
3023 `months', returning a 12-element vector of month names (locale items MON_n);
3025 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3026 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3028 If the system can't provide such information through a call to
3029 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3031 See also Info node `(libc)Locales'.
3033 The data read from the system are decoded using `locale-coding-system'. */)
3037 #ifdef HAVE_LANGINFO_CODESET
3039 if (EQ (item
, Qcodeset
))
3041 str
= nl_langinfo (CODESET
);
3042 return build_string (str
);
3045 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3047 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3048 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3050 struct gcpro gcpro1
;
3052 synchronize_system_time_locale ();
3053 for (i
= 0; i
< 7; i
++)
3055 str
= nl_langinfo (days
[i
]);
3056 val
= build_unibyte_string (str
);
3057 /* Fixme: Is this coding system necessarily right, even if
3058 it is consistent with CODESET? If not, what to do? */
3059 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3067 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3069 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3070 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3071 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3073 struct gcpro gcpro1
;
3075 synchronize_system_time_locale ();
3076 for (i
= 0; i
< 12; i
++)
3078 str
= nl_langinfo (months
[i
]);
3079 val
= build_unibyte_string (str
);
3080 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3087 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3088 but is in the locale files. This could be used by ps-print. */
3090 else if (EQ (item
, Qpaper
))
3091 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3092 #endif /* PAPER_WIDTH */
3093 #endif /* HAVE_LANGINFO_CODESET*/
3097 /* base64 encode/decode functions (RFC 2045).
3098 Based on code from GNU recode. */
3100 #define MIME_LINE_LENGTH 76
3102 #define IS_ASCII(Character) \
3104 #define IS_BASE64(Character) \
3105 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3106 #define IS_BASE64_IGNORABLE(Character) \
3107 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3108 || (Character) == '\f' || (Character) == '\r')
3110 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3111 character or return retval if there are no characters left to
3113 #define READ_QUADRUPLET_BYTE(retval) \
3118 if (nchars_return) \
3119 *nchars_return = nchars; \
3124 while (IS_BASE64_IGNORABLE (c))
3126 /* Table of characters coding the 64 values. */
3127 static const char base64_value_to_char
[64] =
3129 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3130 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3131 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3132 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3133 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3134 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3135 '8', '9', '+', '/' /* 60-63 */
3138 /* Table of base64 values for first 128 characters. */
3139 static const short base64_char_to_value
[128] =
3141 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3142 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3143 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3144 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3145 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3146 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3147 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3148 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3149 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3150 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3151 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3152 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3153 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3156 /* The following diagram shows the logical steps by which three octets
3157 get transformed into four base64 characters.
3159 .--------. .--------. .--------.
3160 |aaaaaabb| |bbbbcccc| |ccdddddd|
3161 `--------' `--------' `--------'
3163 .--------+--------+--------+--------.
3164 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3165 `--------+--------+--------+--------'
3167 .--------+--------+--------+--------.
3168 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3169 `--------+--------+--------+--------'
3171 The octets are divided into 6 bit chunks, which are then encoded into
3172 base64 characters. */
3175 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3176 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3179 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3181 doc
: /* Base64-encode the region between BEG and END.
3182 Return the length of the encoded text.
3183 Optional third argument NO-LINE-BREAK means do not break long lines
3184 into shorter lines. */)
3185 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3188 ptrdiff_t allength
, length
;
3189 ptrdiff_t ibeg
, iend
, encoded_length
;
3190 ptrdiff_t old_pos
= PT
;
3193 validate_region (&beg
, &end
);
3195 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3196 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3197 move_gap_both (XFASTINT (beg
), ibeg
);
3199 /* We need to allocate enough room for encoding the text.
3200 We need 33 1/3% more space, plus a newline every 76
3201 characters, and then we round up. */
3202 length
= iend
- ibeg
;
3203 allength
= length
+ length
/3 + 1;
3204 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3206 encoded
= SAFE_ALLOCA (allength
);
3207 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3208 encoded
, length
, NILP (no_line_break
),
3209 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3210 if (encoded_length
> allength
)
3213 if (encoded_length
< 0)
3215 /* The encoding wasn't possible. */
3217 error ("Multibyte character in data for base64 encoding");
3220 /* Now we have encoded the region, so we insert the new contents
3221 and delete the old. (Insert first in order to preserve markers.) */
3222 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3223 insert (encoded
, encoded_length
);
3225 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3227 /* If point was outside of the region, restore it exactly; else just
3228 move to the beginning of the region. */
3229 if (old_pos
>= XFASTINT (end
))
3230 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3231 else if (old_pos
> XFASTINT (beg
))
3232 old_pos
= XFASTINT (beg
);
3235 /* We return the length of the encoded text. */
3236 return make_number (encoded_length
);
3239 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3241 doc
: /* Base64-encode STRING and return the result.
3242 Optional second argument NO-LINE-BREAK means do not break long lines
3243 into shorter lines. */)
3244 (Lisp_Object string
, Lisp_Object no_line_break
)
3246 ptrdiff_t allength
, length
, encoded_length
;
3248 Lisp_Object encoded_string
;
3251 CHECK_STRING (string
);
3253 /* We need to allocate enough room for encoding the text.
3254 We need 33 1/3% more space, plus a newline every 76
3255 characters, and then we round up. */
3256 length
= SBYTES (string
);
3257 allength
= length
+ length
/3 + 1;
3258 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3260 /* We need to allocate enough room for decoding the text. */
3261 encoded
= SAFE_ALLOCA (allength
);
3263 encoded_length
= base64_encode_1 (SSDATA (string
),
3264 encoded
, length
, NILP (no_line_break
),
3265 STRING_MULTIBYTE (string
));
3266 if (encoded_length
> allength
)
3269 if (encoded_length
< 0)
3271 /* The encoding wasn't possible. */
3272 error ("Multibyte character in data for base64 encoding");
3275 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3278 return encoded_string
;
3282 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3283 bool line_break
, bool multibyte
)
3296 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3297 if (CHAR_BYTE8_P (c
))
3298 c
= CHAR_TO_BYTE8 (c
);
3306 /* Wrap line every 76 characters. */
3310 if (counter
< MIME_LINE_LENGTH
/ 4)
3319 /* Process first byte of a triplet. */
3321 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3322 value
= (0x03 & c
) << 4;
3324 /* Process second byte of a triplet. */
3328 *e
++ = base64_value_to_char
[value
];
3336 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3337 if (CHAR_BYTE8_P (c
))
3338 c
= CHAR_TO_BYTE8 (c
);
3346 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3347 value
= (0x0f & c
) << 2;
3349 /* Process third byte of a triplet. */
3353 *e
++ = base64_value_to_char
[value
];
3360 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3361 if (CHAR_BYTE8_P (c
))
3362 c
= CHAR_TO_BYTE8 (c
);
3370 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3371 *e
++ = base64_value_to_char
[0x3f & c
];
3378 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3380 doc
: /* Base64-decode the region between BEG and END.
3381 Return the length of the decoded text.
3382 If the region can't be decoded, signal an error and don't modify the buffer. */)
3383 (Lisp_Object beg
, Lisp_Object end
)
3385 ptrdiff_t ibeg
, iend
, length
, allength
;
3387 ptrdiff_t old_pos
= PT
;
3388 ptrdiff_t decoded_length
;
3389 ptrdiff_t inserted_chars
;
3390 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3393 validate_region (&beg
, &end
);
3395 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3396 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3398 length
= iend
- ibeg
;
3400 /* We need to allocate enough room for decoding the text. If we are
3401 working on a multibyte buffer, each decoded code may occupy at
3403 allength
= multibyte
? length
* 2 : length
;
3404 decoded
= SAFE_ALLOCA (allength
);
3406 move_gap_both (XFASTINT (beg
), ibeg
);
3407 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3409 multibyte
, &inserted_chars
);
3410 if (decoded_length
> allength
)
3413 if (decoded_length
< 0)
3415 /* The decoding wasn't possible. */
3416 error ("Invalid base64 data");
3419 /* Now we have decoded the region, so we insert the new contents
3420 and delete the old. (Insert first in order to preserve markers.) */
3421 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3422 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3425 /* Delete the original text. */
3426 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3427 iend
+ decoded_length
, 1);
3429 /* If point was outside of the region, restore it exactly; else just
3430 move to the beginning of the region. */
3431 if (old_pos
>= XFASTINT (end
))
3432 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3433 else if (old_pos
> XFASTINT (beg
))
3434 old_pos
= XFASTINT (beg
);
3435 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3437 return make_number (inserted_chars
);
3440 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3442 doc
: /* Base64-decode STRING and return the result. */)
3443 (Lisp_Object string
)
3446 ptrdiff_t length
, decoded_length
;
3447 Lisp_Object decoded_string
;
3450 CHECK_STRING (string
);
3452 length
= SBYTES (string
);
3453 /* We need to allocate enough room for decoding the text. */
3454 decoded
= SAFE_ALLOCA (length
);
3456 /* The decoded result should be unibyte. */
3457 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3459 if (decoded_length
> length
)
3461 else if (decoded_length
>= 0)
3462 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3464 decoded_string
= Qnil
;
3467 if (!STRINGP (decoded_string
))
3468 error ("Invalid base64 data");
3470 return decoded_string
;
3473 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3474 MULTIBYTE, the decoded result should be in multibyte
3475 form. If NCHARS_RETURN is not NULL, store the number of produced
3476 characters in *NCHARS_RETURN. */
3479 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3480 bool multibyte
, ptrdiff_t *nchars_return
)
3482 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3485 unsigned long value
;
3486 ptrdiff_t nchars
= 0;
3490 /* Process first byte of a quadruplet. */
3492 READ_QUADRUPLET_BYTE (e
-to
);
3496 value
= base64_char_to_value
[c
] << 18;
3498 /* Process second byte of a quadruplet. */
3500 READ_QUADRUPLET_BYTE (-1);
3504 value
|= base64_char_to_value
[c
] << 12;
3506 c
= (unsigned char) (value
>> 16);
3507 if (multibyte
&& c
>= 128)
3508 e
+= BYTE8_STRING (c
, e
);
3513 /* Process third byte of a quadruplet. */
3515 READ_QUADRUPLET_BYTE (-1);
3519 READ_QUADRUPLET_BYTE (-1);
3528 value
|= base64_char_to_value
[c
] << 6;
3530 c
= (unsigned char) (0xff & value
>> 8);
3531 if (multibyte
&& c
>= 128)
3532 e
+= BYTE8_STRING (c
, e
);
3537 /* Process fourth byte of a quadruplet. */
3539 READ_QUADRUPLET_BYTE (-1);
3546 value
|= base64_char_to_value
[c
];
3548 c
= (unsigned char) (0xff & value
);
3549 if (multibyte
&& c
>= 128)
3550 e
+= BYTE8_STRING (c
, e
);
3559 /***********************************************************************
3561 ***** Hash Tables *****
3563 ***********************************************************************/
3565 /* Implemented by gerd@gnu.org. This hash table implementation was
3566 inspired by CMUCL hash tables. */
3570 1. For small tables, association lists are probably faster than
3571 hash tables because they have lower overhead.
3573 For uses of hash tables where the O(1) behavior of table
3574 operations is not a requirement, it might therefore be a good idea
3575 not to hash. Instead, we could just do a linear search in the
3576 key_and_value vector of the hash table. This could be done
3577 if a `:linear-search t' argument is given to make-hash-table. */
3580 /* The list of all weak hash tables. Don't staticpro this one. */
3582 static struct Lisp_Hash_Table
*weak_hash_tables
;
3585 /***********************************************************************
3587 ***********************************************************************/
3590 CHECK_HASH_TABLE (Lisp_Object x
)
3592 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3596 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3598 h
->key_and_value
= key_and_value
;
3601 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3606 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3608 gc_aset (h
->next
, idx
, val
);
3611 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3616 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3618 gc_aset (h
->hash
, idx
, val
);
3621 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3626 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3628 gc_aset (h
->index
, idx
, val
);
3631 /* If OBJ is a Lisp hash table, return a pointer to its struct
3632 Lisp_Hash_Table. Otherwise, signal an error. */
3634 static struct Lisp_Hash_Table
*
3635 check_hash_table (Lisp_Object obj
)
3637 CHECK_HASH_TABLE (obj
);
3638 return XHASH_TABLE (obj
);
3642 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3643 number. A number is "almost" a prime number if it is not divisible
3644 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3647 next_almost_prime (EMACS_INT n
)
3649 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3650 for (n
|= 1; ; n
+= 2)
3651 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3656 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3657 which USED[I] is non-zero. If found at index I in ARGS, set
3658 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3659 0. This function is used to extract a keyword/argument pair from
3660 a DEFUN parameter list. */
3663 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3667 for (i
= 1; i
< nargs
; i
++)
3668 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3679 /* Return a Lisp vector which has the same contents as VEC but has
3680 at least INCR_MIN more entries, where INCR_MIN is positive.
3681 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3682 than NITEMS_MAX. Entries in the resulting
3683 vector that are not copied from VEC are set to nil. */
3686 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3688 struct Lisp_Vector
*v
;
3689 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3690 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3691 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3692 ? nitems_max
: C_language_max
);
3693 eassert (VECTORP (vec
));
3694 eassert (0 < incr_min
&& -1 <= nitems_max
);
3695 old_size
= ASIZE (vec
);
3696 incr_max
= n_max
- old_size
;
3697 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3698 if (incr_max
< incr
)
3699 memory_full (SIZE_MAX
);
3700 new_size
= old_size
+ incr
;
3701 v
= allocate_vector (new_size
);
3702 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3703 memsetnil (v
->contents
+ old_size
, new_size
- old_size
);
3704 XSETVECTOR (vec
, v
);
3709 /***********************************************************************
3711 ***********************************************************************/
3713 static struct hash_table_test hashtest_eq
;
3714 struct hash_table_test hashtest_eql
, hashtest_equal
;
3716 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3717 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3718 KEY2 are the same. */
3721 cmpfn_eql (struct hash_table_test
*ht
,
3725 return (FLOATP (key1
)
3727 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3731 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3732 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3733 KEY2 are the same. */
3736 cmpfn_equal (struct hash_table_test
*ht
,
3740 return !NILP (Fequal (key1
, key2
));
3744 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3745 HASH2 in hash table H using H->user_cmp_function. Value is true
3746 if KEY1 and KEY2 are the same. */
3749 cmpfn_user_defined (struct hash_table_test
*ht
,
3753 Lisp_Object args
[3];
3755 args
[0] = ht
->user_cmp_function
;
3758 return !NILP (Ffuncall (3, args
));
3762 /* Value is a hash code for KEY for use in hash table H which uses
3763 `eq' to compare keys. The hash code returned is guaranteed to fit
3764 in a Lisp integer. */
3767 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3769 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3773 /* Value is a hash code for KEY for use in hash table H which uses
3774 `eql' to compare keys. The hash code returned is guaranteed to fit
3775 in a Lisp integer. */
3778 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3782 hash
= sxhash (key
, 0);
3784 hash
= XHASH (key
) ^ XTYPE (key
);
3788 /* Value is a hash code for KEY for use in hash table H which uses
3789 `equal' to compare keys. The hash code returned is guaranteed to fit
3790 in a Lisp integer. */
3793 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3795 EMACS_UINT hash
= sxhash (key
, 0);
3799 /* Value is a hash code for KEY for use in hash table H which uses as
3800 user-defined function to compare keys. The hash code returned is
3801 guaranteed to fit in a Lisp integer. */
3804 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3806 Lisp_Object args
[2], hash
;
3808 args
[0] = ht
->user_hash_function
;
3810 hash
= Ffuncall (2, args
);
3811 return hashfn_eq (ht
, hash
);
3814 /* Allocate basically initialized hash table. */
3816 static struct Lisp_Hash_Table
*
3817 allocate_hash_table (void)
3819 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3820 count
, PVEC_HASH_TABLE
);
3823 /* An upper bound on the size of a hash table index. It must fit in
3824 ptrdiff_t and be a valid Emacs fixnum. */
3825 #define INDEX_SIZE_BOUND \
3826 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3828 /* Create and initialize a new hash table.
3830 TEST specifies the test the hash table will use to compare keys.
3831 It must be either one of the predefined tests `eq', `eql' or
3832 `equal' or a symbol denoting a user-defined test named TEST with
3833 test and hash functions USER_TEST and USER_HASH.
3835 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3837 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3838 new size when it becomes full is computed by adding REHASH_SIZE to
3839 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3840 table's new size is computed by multiplying its old size with
3843 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3844 be resized when the ratio of (number of entries in the table) /
3845 (table size) is >= REHASH_THRESHOLD.
3847 WEAK specifies the weakness of the table. If non-nil, it must be
3848 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3851 make_hash_table (struct hash_table_test test
,
3852 Lisp_Object size
, Lisp_Object rehash_size
,
3853 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3855 struct Lisp_Hash_Table
*h
;
3857 EMACS_INT index_size
, sz
;
3861 /* Preconditions. */
3862 eassert (SYMBOLP (test
.name
));
3863 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3864 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3865 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3866 eassert (FLOATP (rehash_threshold
)
3867 && 0 < XFLOAT_DATA (rehash_threshold
)
3868 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3870 if (XFASTINT (size
) == 0)
3871 size
= make_number (1);
3873 sz
= XFASTINT (size
);
3874 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3875 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3876 ? next_almost_prime (index_float
)
3877 : INDEX_SIZE_BOUND
+ 1);
3878 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3879 error ("Hash table too large");
3881 /* Allocate a table and initialize it. */
3882 h
= allocate_hash_table ();
3884 /* Initialize hash table slots. */
3887 h
->rehash_threshold
= rehash_threshold
;
3888 h
->rehash_size
= rehash_size
;
3890 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3891 h
->hash
= Fmake_vector (size
, Qnil
);
3892 h
->next
= Fmake_vector (size
, Qnil
);
3893 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3895 /* Set up the free list. */
3896 for (i
= 0; i
< sz
- 1; ++i
)
3897 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3898 h
->next_free
= make_number (0);
3900 XSET_HASH_TABLE (table
, h
);
3901 eassert (HASH_TABLE_P (table
));
3902 eassert (XHASH_TABLE (table
) == h
);
3904 /* Maybe add this hash table to the list of all weak hash tables. */
3906 h
->next_weak
= NULL
;
3909 h
->next_weak
= weak_hash_tables
;
3910 weak_hash_tables
= h
;
3917 /* Return a copy of hash table H1. Keys and values are not copied,
3918 only the table itself is. */
3921 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3924 struct Lisp_Hash_Table
*h2
;
3926 h2
= allocate_hash_table ();
3928 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3929 h2
->hash
= Fcopy_sequence (h1
->hash
);
3930 h2
->next
= Fcopy_sequence (h1
->next
);
3931 h2
->index
= Fcopy_sequence (h1
->index
);
3932 XSET_HASH_TABLE (table
, h2
);
3934 /* Maybe add this hash table to the list of all weak hash tables. */
3935 if (!NILP (h2
->weak
))
3937 h2
->next_weak
= weak_hash_tables
;
3938 weak_hash_tables
= h2
;
3945 /* Resize hash table H if it's too full. If H cannot be resized
3946 because it's already too large, throw an error. */
3949 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3951 if (NILP (h
->next_free
))
3953 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3954 EMACS_INT new_size
, index_size
, nsize
;
3958 if (INTEGERP (h
->rehash_size
))
3959 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3962 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3963 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3965 new_size
= float_new_size
;
3966 if (new_size
<= old_size
)
3967 new_size
= old_size
+ 1;
3970 new_size
= INDEX_SIZE_BOUND
+ 1;
3972 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3973 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3974 ? next_almost_prime (index_float
)
3975 : INDEX_SIZE_BOUND
+ 1);
3976 nsize
= max (index_size
, 2 * new_size
);
3977 if (INDEX_SIZE_BOUND
< nsize
)
3978 error ("Hash table too large to resize");
3980 #ifdef ENABLE_CHECKING
3981 if (HASH_TABLE_P (Vpurify_flag
)
3982 && XHASH_TABLE (Vpurify_flag
) == h
)
3983 Fmessage (2, ((Lisp_Object
[])
3984 { build_string ("Growing hash table to: %d"),
3985 make_number (new_size
) }));
3988 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3989 2 * (new_size
- old_size
), -1));
3990 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3991 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3992 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3994 /* Update the free list. Do it so that new entries are added at
3995 the end of the free list. This makes some operations like
3997 for (i
= old_size
; i
< new_size
- 1; ++i
)
3998 set_hash_next_slot (h
, i
, make_number (i
+ 1));
4000 if (!NILP (h
->next_free
))
4002 Lisp_Object last
, next
;
4004 last
= h
->next_free
;
4005 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4009 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
4012 XSETFASTINT (h
->next_free
, old_size
);
4015 for (i
= 0; i
< old_size
; ++i
)
4016 if (!NILP (HASH_HASH (h
, i
)))
4018 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4019 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4020 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4021 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4027 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4028 the hash code of KEY. Value is the index of the entry in H
4029 matching KEY, or -1 if not found. */
4032 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4034 EMACS_UINT hash_code
;
4035 ptrdiff_t start_of_bucket
;
4038 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4039 eassert ((hash_code
& ~INTMASK
) == 0);
4043 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4044 idx
= HASH_INDEX (h
, start_of_bucket
);
4046 /* We need not gcpro idx since it's either an integer or nil. */
4049 ptrdiff_t i
= XFASTINT (idx
);
4050 if (EQ (key
, HASH_KEY (h
, i
))
4052 && hash_code
== XUINT (HASH_HASH (h
, i
))
4053 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4055 idx
= HASH_NEXT (h
, i
);
4058 return NILP (idx
) ? -1 : XFASTINT (idx
);
4062 /* Put an entry into hash table H that associates KEY with VALUE.
4063 HASH is a previously computed hash code of KEY.
4064 Value is the index of the entry in H matching KEY. */
4067 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4070 ptrdiff_t start_of_bucket
, i
;
4072 eassert ((hash
& ~INTMASK
) == 0);
4074 /* Increment count after resizing because resizing may fail. */
4075 maybe_resize_hash_table (h
);
4078 /* Store key/value in the key_and_value vector. */
4079 i
= XFASTINT (h
->next_free
);
4080 h
->next_free
= HASH_NEXT (h
, i
);
4081 set_hash_key_slot (h
, i
, key
);
4082 set_hash_value_slot (h
, i
, value
);
4084 /* Remember its hash code. */
4085 set_hash_hash_slot (h
, i
, make_number (hash
));
4087 /* Add new entry to its collision chain. */
4088 start_of_bucket
= hash
% ASIZE (h
->index
);
4089 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4090 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4095 /* Remove the entry matching KEY from hash table H, if there is one. */
4098 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4100 EMACS_UINT hash_code
;
4101 ptrdiff_t start_of_bucket
;
4102 Lisp_Object idx
, prev
;
4104 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4105 eassert ((hash_code
& ~INTMASK
) == 0);
4106 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4107 idx
= HASH_INDEX (h
, start_of_bucket
);
4110 /* We need not gcpro idx, prev since they're either integers or nil. */
4113 ptrdiff_t i
= XFASTINT (idx
);
4115 if (EQ (key
, HASH_KEY (h
, i
))
4117 && hash_code
== XUINT (HASH_HASH (h
, i
))
4118 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4120 /* Take entry out of collision chain. */
4122 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4124 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4126 /* Clear slots in key_and_value and add the slots to
4128 set_hash_key_slot (h
, i
, Qnil
);
4129 set_hash_value_slot (h
, i
, Qnil
);
4130 set_hash_hash_slot (h
, i
, Qnil
);
4131 set_hash_next_slot (h
, i
, h
->next_free
);
4132 h
->next_free
= make_number (i
);
4134 eassert (h
->count
>= 0);
4140 idx
= HASH_NEXT (h
, i
);
4146 /* Clear hash table H. */
4149 hash_clear (struct Lisp_Hash_Table
*h
)
4153 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4155 for (i
= 0; i
< size
; ++i
)
4157 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4158 set_hash_key_slot (h
, i
, Qnil
);
4159 set_hash_value_slot (h
, i
, Qnil
);
4160 set_hash_hash_slot (h
, i
, Qnil
);
4163 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4164 ASET (h
->index
, i
, Qnil
);
4166 h
->next_free
= make_number (0);
4173 /************************************************************************
4175 ************************************************************************/
4177 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4178 entries from the table that don't survive the current GC.
4179 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4180 true if anything was marked. */
4183 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4185 ptrdiff_t bucket
, n
;
4188 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4191 for (bucket
= 0; bucket
< n
; ++bucket
)
4193 Lisp_Object idx
, next
, prev
;
4195 /* Follow collision chain, removing entries that
4196 don't survive this garbage collection. */
4198 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4200 ptrdiff_t i
= XFASTINT (idx
);
4201 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4202 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4205 if (EQ (h
->weak
, Qkey
))
4206 remove_p
= !key_known_to_survive_p
;
4207 else if (EQ (h
->weak
, Qvalue
))
4208 remove_p
= !value_known_to_survive_p
;
4209 else if (EQ (h
->weak
, Qkey_or_value
))
4210 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4211 else if (EQ (h
->weak
, Qkey_and_value
))
4212 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4216 next
= HASH_NEXT (h
, i
);
4218 if (remove_entries_p
)
4222 /* Take out of collision chain. */
4224 set_hash_index_slot (h
, bucket
, next
);
4226 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4228 /* Add to free list. */
4229 set_hash_next_slot (h
, i
, h
->next_free
);
4232 /* Clear key, value, and hash. */
4233 set_hash_key_slot (h
, i
, Qnil
);
4234 set_hash_value_slot (h
, i
, Qnil
);
4235 set_hash_hash_slot (h
, i
, Qnil
);
4248 /* Make sure key and value survive. */
4249 if (!key_known_to_survive_p
)
4251 mark_object (HASH_KEY (h
, i
));
4255 if (!value_known_to_survive_p
)
4257 mark_object (HASH_VALUE (h
, i
));
4268 /* Remove elements from weak hash tables that don't survive the
4269 current garbage collection. Remove weak tables that don't survive
4270 from Vweak_hash_tables. Called from gc_sweep. */
4272 NO_INLINE
/* For better stack traces */
4274 sweep_weak_hash_tables (void)
4276 struct Lisp_Hash_Table
*h
, *used
, *next
;
4279 /* Mark all keys and values that are in use. Keep on marking until
4280 there is no more change. This is necessary for cases like
4281 value-weak table A containing an entry X -> Y, where Y is used in a
4282 key-weak table B, Z -> Y. If B comes after A in the list of weak
4283 tables, X -> Y might be removed from A, although when looking at B
4284 one finds that it shouldn't. */
4288 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4290 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4291 marked
|= sweep_weak_table (h
, 0);
4296 /* Remove tables and entries that aren't used. */
4297 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4299 next
= h
->next_weak
;
4301 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4303 /* TABLE is marked as used. Sweep its contents. */
4305 sweep_weak_table (h
, 1);
4307 /* Add table to the list of used weak hash tables. */
4308 h
->next_weak
= used
;
4313 weak_hash_tables
= used
;
4318 /***********************************************************************
4319 Hash Code Computation
4320 ***********************************************************************/
4322 /* Maximum depth up to which to dive into Lisp structures. */
4324 #define SXHASH_MAX_DEPTH 3
4326 /* Maximum length up to which to take list and vector elements into
4329 #define SXHASH_MAX_LEN 7
4331 /* Return a hash for string PTR which has length LEN. The hash value
4332 can be any EMACS_UINT value. */
4335 hash_string (char const *ptr
, ptrdiff_t len
)
4337 char const *p
= ptr
;
4338 char const *end
= p
+ len
;
4340 EMACS_UINT hash
= 0;
4345 hash
= sxhash_combine (hash
, c
);
4351 /* Return a hash for string PTR which has length LEN. The hash
4352 code returned is guaranteed to fit in a Lisp integer. */
4355 sxhash_string (char const *ptr
, ptrdiff_t len
)
4357 EMACS_UINT hash
= hash_string (ptr
, len
);
4358 return SXHASH_REDUCE (hash
);
4361 /* Return a hash for the floating point value VAL. */
4364 sxhash_float (double val
)
4366 EMACS_UINT hash
= 0;
4368 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4369 + (sizeof val
% sizeof hash
!= 0))
4373 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4377 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4378 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4379 hash
= sxhash_combine (hash
, u
.word
[i
]);
4380 return SXHASH_REDUCE (hash
);
4383 /* Return a hash for list LIST. DEPTH is the current depth in the
4384 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4387 sxhash_list (Lisp_Object list
, int depth
)
4389 EMACS_UINT hash
= 0;
4392 if (depth
< SXHASH_MAX_DEPTH
)
4394 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4395 list
= XCDR (list
), ++i
)
4397 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4398 hash
= sxhash_combine (hash
, hash2
);
4403 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4404 hash
= sxhash_combine (hash
, hash2
);
4407 return SXHASH_REDUCE (hash
);
4411 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4412 the Lisp structure. */
4415 sxhash_vector (Lisp_Object vec
, int depth
)
4417 EMACS_UINT hash
= ASIZE (vec
);
4420 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4421 for (i
= 0; i
< n
; ++i
)
4423 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4424 hash
= sxhash_combine (hash
, hash2
);
4427 return SXHASH_REDUCE (hash
);
4430 /* Return a hash for bool-vector VECTOR. */
4433 sxhash_bool_vector (Lisp_Object vec
)
4435 EMACS_INT size
= bool_vector_size (vec
);
4436 EMACS_UINT hash
= size
;
4439 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4440 for (i
= 0; i
< n
; ++i
)
4441 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4443 return SXHASH_REDUCE (hash
);
4447 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4448 structure. Value is an unsigned integer clipped to INTMASK. */
4451 sxhash (Lisp_Object obj
, int depth
)
4455 if (depth
> SXHASH_MAX_DEPTH
)
4458 switch (XTYPE (obj
))
4470 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4473 /* This can be everything from a vector to an overlay. */
4474 case Lisp_Vectorlike
:
4476 /* According to the CL HyperSpec, two arrays are equal only if
4477 they are `eq', except for strings and bit-vectors. In
4478 Emacs, this works differently. We have to compare element
4480 hash
= sxhash_vector (obj
, depth
);
4481 else if (BOOL_VECTOR_P (obj
))
4482 hash
= sxhash_bool_vector (obj
);
4484 /* Others are `equal' if they are `eq', so let's take their
4490 hash
= sxhash_list (obj
, depth
);
4494 hash
= sxhash_float (XFLOAT_DATA (obj
));
4506 /***********************************************************************
4508 ***********************************************************************/
4511 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4512 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4515 EMACS_UINT hash
= sxhash (obj
, 0);
4516 return make_number (hash
);
4520 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4521 doc
: /* Create and return a new hash table.
4523 Arguments are specified as keyword/argument pairs. The following
4524 arguments are defined:
4526 :test TEST -- TEST must be a symbol that specifies how to compare
4527 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4528 `equal'. User-supplied test and hash functions can be specified via
4529 `define-hash-table-test'.
4531 :size SIZE -- A hint as to how many elements will be put in the table.
4534 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4535 fills up. If REHASH-SIZE is an integer, increase the size by that
4536 amount. If it is a float, it must be > 1.0, and the new size is the
4537 old size multiplied by that factor. Default is 1.5.
4539 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4540 Resize the hash table when the ratio (number of entries / table size)
4541 is greater than or equal to THRESHOLD. Default is 0.8.
4543 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4544 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4545 returned is a weak table. Key/value pairs are removed from a weak
4546 hash table when there are no non-weak references pointing to their
4547 key, value, one of key or value, or both key and value, depending on
4548 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4551 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4552 (ptrdiff_t nargs
, Lisp_Object
*args
)
4554 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4555 struct hash_table_test testdesc
;
4559 /* The vector `used' is used to keep track of arguments that
4560 have been consumed. */
4561 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4562 memset (used
, 0, nargs
* sizeof *used
);
4564 /* See if there's a `:test TEST' among the arguments. */
4565 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4566 test
= i
? args
[i
] : Qeql
;
4568 testdesc
= hashtest_eq
;
4569 else if (EQ (test
, Qeql
))
4570 testdesc
= hashtest_eql
;
4571 else if (EQ (test
, Qequal
))
4572 testdesc
= hashtest_equal
;
4575 /* See if it is a user-defined test. */
4578 prop
= Fget (test
, Qhash_table_test
);
4579 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4580 signal_error ("Invalid hash table test", test
);
4581 testdesc
.name
= test
;
4582 testdesc
.user_cmp_function
= XCAR (prop
);
4583 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4584 testdesc
.hashfn
= hashfn_user_defined
;
4585 testdesc
.cmpfn
= cmpfn_user_defined
;
4588 /* See if there's a `:size SIZE' argument. */
4589 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4590 size
= i
? args
[i
] : Qnil
;
4592 size
= make_number (DEFAULT_HASH_SIZE
);
4593 else if (!INTEGERP (size
) || XINT (size
) < 0)
4594 signal_error ("Invalid hash table size", size
);
4596 /* Look for `:rehash-size SIZE'. */
4597 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4598 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4599 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4600 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4601 signal_error ("Invalid hash table rehash size", rehash_size
);
4603 /* Look for `:rehash-threshold THRESHOLD'. */
4604 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4605 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4606 if (! (FLOATP (rehash_threshold
)
4607 && 0 < XFLOAT_DATA (rehash_threshold
)
4608 && XFLOAT_DATA (rehash_threshold
) <= 1))
4609 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4611 /* Look for `:weakness WEAK'. */
4612 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4613 weak
= i
? args
[i
] : Qnil
;
4615 weak
= Qkey_and_value
;
4618 && !EQ (weak
, Qvalue
)
4619 && !EQ (weak
, Qkey_or_value
)
4620 && !EQ (weak
, Qkey_and_value
))
4621 signal_error ("Invalid hash table weakness", weak
);
4623 /* Now, all args should have been used up, or there's a problem. */
4624 for (i
= 0; i
< nargs
; ++i
)
4626 signal_error ("Invalid argument list", args
[i
]);
4629 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4633 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4634 doc
: /* Return a copy of hash table TABLE. */)
4637 return copy_hash_table (check_hash_table (table
));
4641 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4642 doc
: /* Return the number of elements in TABLE. */)
4645 return make_number (check_hash_table (table
)->count
);
4649 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4650 Shash_table_rehash_size
, 1, 1, 0,
4651 doc
: /* Return the current rehash size of TABLE. */)
4654 return check_hash_table (table
)->rehash_size
;
4658 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4659 Shash_table_rehash_threshold
, 1, 1, 0,
4660 doc
: /* Return the current rehash threshold of TABLE. */)
4663 return check_hash_table (table
)->rehash_threshold
;
4667 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4668 doc
: /* Return the size of TABLE.
4669 The size can be used as an argument to `make-hash-table' to create
4670 a hash table than can hold as many elements as TABLE holds
4671 without need for resizing. */)
4674 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4675 return make_number (HASH_TABLE_SIZE (h
));
4679 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4680 doc
: /* Return the test TABLE uses. */)
4683 return check_hash_table (table
)->test
.name
;
4687 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4689 doc
: /* Return the weakness of TABLE. */)
4692 return check_hash_table (table
)->weak
;
4696 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4697 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4700 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4704 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4705 doc
: /* Clear hash table TABLE and return it. */)
4708 hash_clear (check_hash_table (table
));
4709 /* Be compatible with XEmacs. */
4714 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4715 doc
: /* Look up KEY in TABLE and return its associated value.
4716 If KEY is not found, return DFLT which defaults to nil. */)
4717 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4719 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4720 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4721 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4725 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4726 doc
: /* Associate KEY with VALUE in hash table TABLE.
4727 If KEY is already present in table, replace its current value with
4728 VALUE. In any case, return VALUE. */)
4729 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4731 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4735 i
= hash_lookup (h
, key
, &hash
);
4737 set_hash_value_slot (h
, i
, value
);
4739 hash_put (h
, key
, value
, hash
);
4745 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4746 doc
: /* Remove KEY from TABLE. */)
4747 (Lisp_Object key
, Lisp_Object table
)
4749 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4750 hash_remove_from_table (h
, key
);
4755 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4756 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4757 FUNCTION is called with two arguments, KEY and VALUE.
4758 `maphash' always returns nil. */)
4759 (Lisp_Object function
, Lisp_Object table
)
4761 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4762 Lisp_Object args
[3];
4765 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4766 if (!NILP (HASH_HASH (h
, i
)))
4769 args
[1] = HASH_KEY (h
, i
);
4770 args
[2] = HASH_VALUE (h
, i
);
4778 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4779 Sdefine_hash_table_test
, 3, 3, 0,
4780 doc
: /* Define a new hash table test with name NAME, a symbol.
4782 In hash tables created with NAME specified as test, use TEST to
4783 compare keys, and HASH for computing hash codes of keys.
4785 TEST must be a function taking two arguments and returning non-nil if
4786 both arguments are the same. HASH must be a function taking one
4787 argument and returning an object that is the hash code of the argument.
4788 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4789 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4790 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4792 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4797 /************************************************************************
4798 MD5, SHA-1, and SHA-2
4799 ************************************************************************/
4806 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4809 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4810 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4814 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4815 register EMACS_INT b
, e
;
4816 register struct buffer
*bp
;
4819 void *(*hash_func
) (const char *, size_t, void *);
4822 CHECK_SYMBOL (algorithm
);
4824 if (STRINGP (object
))
4826 if (NILP (coding_system
))
4828 /* Decide the coding-system to encode the data with. */
4830 if (STRING_MULTIBYTE (object
))
4831 /* use default, we can't guess correct value */
4832 coding_system
= preferred_coding_system ();
4834 coding_system
= Qraw_text
;
4837 if (NILP (Fcoding_system_p (coding_system
)))
4839 /* Invalid coding system. */
4841 if (!NILP (noerror
))
4842 coding_system
= Qraw_text
;
4844 xsignal1 (Qcoding_system_error
, coding_system
);
4847 if (STRING_MULTIBYTE (object
))
4848 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4850 size
= SCHARS (object
);
4851 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4853 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4854 end_byte
= (end_char
== size
4856 : string_char_to_byte (object
, end_char
));
4860 struct buffer
*prev
= current_buffer
;
4862 record_unwind_current_buffer ();
4864 CHECK_BUFFER (object
);
4866 bp
= XBUFFER (object
);
4867 set_buffer_internal (bp
);
4873 CHECK_NUMBER_COERCE_MARKER (start
);
4881 CHECK_NUMBER_COERCE_MARKER (end
);
4886 temp
= b
, b
= e
, e
= temp
;
4888 if (!(BEGV
<= b
&& e
<= ZV
))
4889 args_out_of_range (start
, end
);
4891 if (NILP (coding_system
))
4893 /* Decide the coding-system to encode the data with.
4894 See fileio.c:Fwrite-region */
4896 if (!NILP (Vcoding_system_for_write
))
4897 coding_system
= Vcoding_system_for_write
;
4900 bool force_raw_text
= 0;
4902 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4903 if (NILP (coding_system
)
4904 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4906 coding_system
= Qnil
;
4907 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4911 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4913 /* Check file-coding-system-alist. */
4914 Lisp_Object args
[4], val
;
4916 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4917 args
[3] = Fbuffer_file_name (object
);
4918 val
= Ffind_operation_coding_system (4, args
);
4919 if (CONSP (val
) && !NILP (XCDR (val
)))
4920 coding_system
= XCDR (val
);
4923 if (NILP (coding_system
)
4924 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4926 /* If we still have not decided a coding system, use the
4927 default value of buffer-file-coding-system. */
4928 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4932 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4933 /* Confirm that VAL can surely encode the current region. */
4934 coding_system
= call4 (Vselect_safe_coding_system_function
,
4935 make_number (b
), make_number (e
),
4936 coding_system
, Qnil
);
4939 coding_system
= Qraw_text
;
4942 if (NILP (Fcoding_system_p (coding_system
)))
4944 /* Invalid coding system. */
4946 if (!NILP (noerror
))
4947 coding_system
= Qraw_text
;
4949 xsignal1 (Qcoding_system_error
, coding_system
);
4953 object
= make_buffer_string (b
, e
, 0);
4954 set_buffer_internal (prev
);
4955 /* Discard the unwind protect for recovering the current
4959 if (STRING_MULTIBYTE (object
))
4960 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4962 end_byte
= SBYTES (object
);
4965 if (EQ (algorithm
, Qmd5
))
4967 digest_size
= MD5_DIGEST_SIZE
;
4968 hash_func
= md5_buffer
;
4970 else if (EQ (algorithm
, Qsha1
))
4972 digest_size
= SHA1_DIGEST_SIZE
;
4973 hash_func
= sha1_buffer
;
4975 else if (EQ (algorithm
, Qsha224
))
4977 digest_size
= SHA224_DIGEST_SIZE
;
4978 hash_func
= sha224_buffer
;
4980 else if (EQ (algorithm
, Qsha256
))
4982 digest_size
= SHA256_DIGEST_SIZE
;
4983 hash_func
= sha256_buffer
;
4985 else if (EQ (algorithm
, Qsha384
))
4987 digest_size
= SHA384_DIGEST_SIZE
;
4988 hash_func
= sha384_buffer
;
4990 else if (EQ (algorithm
, Qsha512
))
4992 digest_size
= SHA512_DIGEST_SIZE
;
4993 hash_func
= sha512_buffer
;
4996 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4998 /* allocate 2 x digest_size so that it can be re-used to hold the
5000 digest
= make_uninit_string (digest_size
* 2);
5002 hash_func (SSDATA (object
) + start_byte
,
5003 end_byte
- start_byte
,
5008 unsigned char *p
= SDATA (digest
);
5009 for (i
= digest_size
- 1; i
>= 0; i
--)
5011 static char const hexdigit
[16] = "0123456789abcdef";
5013 p
[2 * i
] = hexdigit
[p_i
>> 4];
5014 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5019 return make_unibyte_string (SSDATA (digest
), digest_size
);
5022 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5023 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5025 A message digest is a cryptographic checksum of a document, and the
5026 algorithm to calculate it is defined in RFC 1321.
5028 The two optional arguments START and END are character positions
5029 specifying for which part of OBJECT the message digest should be
5030 computed. If nil or omitted, the digest is computed for the whole
5033 The MD5 message digest is computed from the result of encoding the
5034 text in a coding system, not directly from the internal Emacs form of
5035 the text. The optional fourth argument CODING-SYSTEM specifies which
5036 coding system to encode the text with. It should be the same coding
5037 system that you used or will use when actually writing the text into a
5040 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5041 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5042 system would be chosen by default for writing this text into a file.
5044 If OBJECT is a string, the most preferred coding system (see the
5045 command `prefer-coding-system') is used.
5047 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5048 guesswork fails. Normally, an error is signaled in such case. */)
5049 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5051 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5054 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5055 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5056 ALGORITHM is a symbol specifying the hash to use:
5057 md5, sha1, sha224, sha256, sha384 or sha512.
5059 The two optional arguments START and END are positions specifying for
5060 which part of OBJECT to compute the hash. If nil or omitted, uses the
5063 If BINARY is non-nil, returns a string in binary form. */)
5064 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5066 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5072 DEFSYM (Qmd5
, "md5");
5073 DEFSYM (Qsha1
, "sha1");
5074 DEFSYM (Qsha224
, "sha224");
5075 DEFSYM (Qsha256
, "sha256");
5076 DEFSYM (Qsha384
, "sha384");
5077 DEFSYM (Qsha512
, "sha512");
5079 /* Hash table stuff. */
5080 DEFSYM (Qhash_table_p
, "hash-table-p");
5082 DEFSYM (Qeql
, "eql");
5083 DEFSYM (Qequal
, "equal");
5084 DEFSYM (QCtest
, ":test");
5085 DEFSYM (QCsize
, ":size");
5086 DEFSYM (QCrehash_size
, ":rehash-size");
5087 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5088 DEFSYM (QCweakness
, ":weakness");
5089 DEFSYM (Qkey
, "key");
5090 DEFSYM (Qvalue
, "value");
5091 DEFSYM (Qhash_table_test
, "hash-table-test");
5092 DEFSYM (Qkey_or_value
, "key-or-value");
5093 DEFSYM (Qkey_and_value
, "key-and-value");
5096 defsubr (&Smake_hash_table
);
5097 defsubr (&Scopy_hash_table
);
5098 defsubr (&Shash_table_count
);
5099 defsubr (&Shash_table_rehash_size
);
5100 defsubr (&Shash_table_rehash_threshold
);
5101 defsubr (&Shash_table_size
);
5102 defsubr (&Shash_table_test
);
5103 defsubr (&Shash_table_weakness
);
5104 defsubr (&Shash_table_p
);
5105 defsubr (&Sclrhash
);
5106 defsubr (&Sgethash
);
5107 defsubr (&Sputhash
);
5108 defsubr (&Sremhash
);
5109 defsubr (&Smaphash
);
5110 defsubr (&Sdefine_hash_table_test
);
5112 DEFSYM (Qstring_lessp
, "string-lessp");
5113 DEFSYM (Qstring_collate_lessp
, "string-collate-lessp");
5114 DEFSYM (Qstring_collate_equalp
, "string-collate-equalp");
5115 DEFSYM (Qprovide
, "provide");
5116 DEFSYM (Qrequire
, "require");
5117 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5118 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5119 DEFSYM (Qwidget_type
, "widget-type");
5121 staticpro (&string_char_byte_cache_string
);
5122 string_char_byte_cache_string
= Qnil
;
5124 require_nesting_list
= Qnil
;
5125 staticpro (&require_nesting_list
);
5127 Fset (Qyes_or_no_p_history
, Qnil
);
5129 DEFVAR_LISP ("features", Vfeatures
,
5130 doc
: /* A list of symbols which are the features of the executing Emacs.
5131 Used by `featurep' and `require', and altered by `provide'. */);
5132 Vfeatures
= list1 (intern_c_string ("emacs"));
5133 DEFSYM (Qsubfeatures
, "subfeatures");
5134 DEFSYM (Qfuncall
, "funcall");
5136 #ifdef HAVE_LANGINFO_CODESET
5137 DEFSYM (Qcodeset
, "codeset");
5138 DEFSYM (Qdays
, "days");
5139 DEFSYM (Qmonths
, "months");
5140 DEFSYM (Qpaper
, "paper");
5141 #endif /* HAVE_LANGINFO_CODESET */
5143 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5144 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5145 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5146 invoked by mouse clicks and mouse menu items.
5148 On some platforms, file selection dialogs are also enabled if this is
5152 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5153 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5154 This applies to commands from menus and tool bar buttons even when
5155 they are initiated from the keyboard. If `use-dialog-box' is nil,
5156 that disables the use of a file dialog, regardless of the value of
5158 use_file_dialog
= 1;
5160 defsubr (&Sidentity
);
5163 defsubr (&Ssafe_length
);
5164 defsubr (&Sstring_bytes
);
5165 defsubr (&Sstring_equal
);
5166 defsubr (&Scompare_strings
);
5167 defsubr (&Sstring_lessp
);
5168 defsubr (&Sstring_collate_lessp
);
5169 defsubr (&Sstring_collate_equalp
);
5172 defsubr (&Svconcat
);
5173 defsubr (&Scopy_sequence
);
5174 defsubr (&Sstring_make_multibyte
);
5175 defsubr (&Sstring_make_unibyte
);
5176 defsubr (&Sstring_as_multibyte
);
5177 defsubr (&Sstring_as_unibyte
);
5178 defsubr (&Sstring_to_multibyte
);
5179 defsubr (&Sstring_to_unibyte
);
5180 defsubr (&Scopy_alist
);
5181 defsubr (&Ssubstring
);
5182 defsubr (&Ssubstring_no_properties
);
5195 defsubr (&Snreverse
);
5196 defsubr (&Sreverse
);
5198 defsubr (&Splist_get
);
5200 defsubr (&Splist_put
);
5202 defsubr (&Slax_plist_get
);
5203 defsubr (&Slax_plist_put
);
5206 defsubr (&Sequal_including_properties
);
5207 defsubr (&Sfillarray
);
5208 defsubr (&Sclear_string
);
5212 defsubr (&Smapconcat
);
5213 defsubr (&Syes_or_no_p
);
5214 defsubr (&Sload_average
);
5215 defsubr (&Sfeaturep
);
5216 defsubr (&Srequire
);
5217 defsubr (&Sprovide
);
5218 defsubr (&Splist_member
);
5219 defsubr (&Swidget_put
);
5220 defsubr (&Swidget_get
);
5221 defsubr (&Swidget_apply
);
5222 defsubr (&Sbase64_encode_region
);
5223 defsubr (&Sbase64_decode_region
);
5224 defsubr (&Sbase64_encode_string
);
5225 defsubr (&Sbase64_decode_string
);
5227 defsubr (&Ssecure_hash
);
5228 defsubr (&Slocale_info
);
5230 hashtest_eq
.name
= Qeq
;
5231 hashtest_eq
.user_hash_function
= Qnil
;
5232 hashtest_eq
.user_cmp_function
= Qnil
;
5233 hashtest_eq
.cmpfn
= 0;
5234 hashtest_eq
.hashfn
= hashfn_eq
;
5236 hashtest_eql
.name
= Qeql
;
5237 hashtest_eql
.user_hash_function
= Qnil
;
5238 hashtest_eql
.user_cmp_function
= Qnil
;
5239 hashtest_eql
.cmpfn
= cmpfn_eql
;
5240 hashtest_eql
.hashfn
= hashfn_eql
;
5242 hashtest_equal
.name
= Qequal
;
5243 hashtest_equal
.user_hash_function
= Qnil
;
5244 hashtest_equal
.user_cmp_function
= Qnil
;
5245 hashtest_equal
.cmpfn
= cmpfn_equal
;
5246 hashtest_equal
.hashfn
= hashfn_equal
;