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. */)
55 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
56 doc
: /* Return a pseudo-random number.
57 All integers representable in Lisp, i.e. between `most-negative-fixnum'
58 and `most-positive-fixnum', inclusive, are equally likely.
60 With positive integer LIMIT, return random number in interval [0,LIMIT).
61 With argument t, set the random number seed from the current time and pid.
62 With a string argument, set the seed based on the string's contents.
63 Other values of LIMIT are ignored.
65 See Info node `(elisp)Random Numbers' for more details. */)
72 else if (STRINGP (limit
))
73 seed_random (SSDATA (limit
), SBYTES (limit
));
76 if (INTEGERP (limit
) && 0 < XINT (limit
))
79 /* Return the remainder, except reject the rare case where
80 get_random returns a number so close to INTMASK that the
81 remainder isn't random. */
82 EMACS_INT remainder
= val
% XINT (limit
);
83 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
84 return make_number (remainder
);
87 return make_number (val
);
90 /* Heuristic on how many iterations of a tight loop can be safely done
91 before it's time to do a QUIT. This must be a power of 2. */
92 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
94 /* Random data-structure functions. */
97 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
99 CHECK_TYPE (NILP (x
), Qlistp
, y
);
102 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
103 doc
: /* Return the length of vector, list or string SEQUENCE.
104 A byte-code function object is also allowed.
105 If the string contains multibyte characters, this is not necessarily
106 the number of bytes in the string; it is the number of characters.
107 To get the number of bytes, use `string-bytes'. */)
108 (register Lisp_Object sequence
)
110 register Lisp_Object val
;
112 if (STRINGP (sequence
))
113 XSETFASTINT (val
, SCHARS (sequence
));
114 else if (VECTORP (sequence
))
115 XSETFASTINT (val
, ASIZE (sequence
));
116 else if (CHAR_TABLE_P (sequence
))
117 XSETFASTINT (val
, MAX_CHAR
);
118 else if (BOOL_VECTOR_P (sequence
))
119 XSETFASTINT (val
, bool_vector_size (sequence
));
120 else if (COMPILEDP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
122 else if (CONSP (sequence
))
129 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
131 if (MOST_POSITIVE_FIXNUM
< i
)
132 error ("List too long");
135 sequence
= XCDR (sequence
);
137 while (CONSP (sequence
));
139 CHECK_LIST_END (sequence
, sequence
);
141 val
= make_number (i
);
143 else if (NILP (sequence
))
144 XSETFASTINT (val
, 0);
146 wrong_type_argument (Qsequencep
, sequence
);
151 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
152 doc
: /* Return the length of a list, but avoid error or infinite loop.
153 This function never gets an error. If LIST is not really a list,
154 it returns 0. If LIST is circular, it returns a finite value
155 which is at least the number of distinct elements. */)
158 Lisp_Object tail
, halftail
;
163 return make_number (0);
165 /* halftail is used to detect circular lists. */
166 for (tail
= halftail
= list
; ; )
171 if (EQ (tail
, halftail
))
174 if ((lolen
& 1) == 0)
176 halftail
= XCDR (halftail
);
177 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
181 hilen
+= UINTMAX_MAX
+ 1.0;
186 /* If the length does not fit into a fixnum, return a float.
187 On all known practical machines this returns an upper bound on
189 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
192 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
193 doc
: /* Return the number of bytes in STRING.
194 If STRING is multibyte, this may be greater than the length of STRING. */)
197 CHECK_STRING (string
);
198 return make_number (SBYTES (string
));
201 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
202 doc
: /* Return t if two strings have identical contents.
203 Case is significant, but text properties are ignored.
204 Symbols are also allowed; their print names are used instead. */)
205 (register Lisp_Object s1
, Lisp_Object s2
)
208 s1
= SYMBOL_NAME (s1
);
210 s2
= SYMBOL_NAME (s2
);
214 if (SCHARS (s1
) != SCHARS (s2
)
215 || SBYTES (s1
) != SBYTES (s2
)
216 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
221 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
222 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
223 The arguments START1, END1, START2, and END2, if non-nil, are
224 positions specifying which parts of STR1 or STR2 to compare. In
225 string STR1, compare the part between START1 (inclusive) and END1
226 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
227 the string; if END1 is nil, it defaults to the length of the string.
228 Likewise, in string STR2, compare the part between START2 and END2.
229 Like in `substring', negative values are counted from the end.
231 The strings are compared by the numeric values of their characters.
232 For instance, STR1 is "less than" STR2 if its first differing
233 character has a smaller numeric value. If IGNORE-CASE is non-nil,
234 characters are converted to lower-case before comparing them. Unibyte
235 strings are converted to multibyte for comparison.
237 The value is t if the strings (or specified portions) match.
238 If string STR1 is less, the value is a negative number N;
239 - 1 - N is the number of characters that match at the beginning.
240 If string STR1 is greater, the value is a positive number N;
241 N - 1 is the number of characters that match at the beginning. */)
242 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
243 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
245 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
250 /* For backward compatibility, silently bring too-large positive end
251 values into range. */
252 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
253 end1
= make_number (SCHARS (str1
));
254 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
255 end2
= make_number (SCHARS (str2
));
257 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
258 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
263 i1_byte
= string_char_to_byte (str1
, i1
);
264 i2_byte
= string_char_to_byte (str2
, i2
);
266 while (i1
< to1
&& i2
< to2
)
268 /* When we find a mismatch, we must compare the
269 characters, not just the bytes. */
272 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
273 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
278 if (! NILP (ignore_case
))
280 c1
= XINT (Fupcase (make_number (c1
)));
281 c2
= XINT (Fupcase (make_number (c2
)));
287 /* Note that I1 has already been incremented
288 past the character that we are comparing;
289 hence we don't add or subtract 1 here. */
291 return make_number (- i1
+ from1
);
293 return make_number (i1
- from1
);
297 return make_number (i1
- from1
+ 1);
299 return make_number (- i1
+ from1
- 1);
304 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
305 doc
: /* Return t if first arg string is less than second in lexicographic order.
307 Symbols are also allowed; their print names are used instead. */)
308 (register Lisp_Object s1
, Lisp_Object s2
)
310 register ptrdiff_t end
;
311 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
314 s1
= SYMBOL_NAME (s1
);
316 s2
= SYMBOL_NAME (s2
);
320 i1
= i1_byte
= i2
= i2_byte
= 0;
323 if (end
> SCHARS (s2
))
328 /* When we find a mismatch, we must compare the
329 characters, not just the bytes. */
332 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
333 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
336 return c1
< c2
? Qt
: Qnil
;
338 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
341 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
342 doc
: /* Return t if first arg string is less than second in collation order.
343 Symbols are also allowed; their print names are used instead.
345 This function obeys the conventions for collation order in your
346 locale settings. For example, punctuation and whitespace characters
347 might be considered less significant for sorting:
349 \(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
350 => \("11" "1 1" "1.1" "12" "1 2" "1.2")
352 The optional argument LOCALE, a string, overrides the setting of your
353 current locale identifier for collation. The value is system
354 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
355 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
357 If IGNORE-CASE is non-nil, characters are converted to lower-case
358 before comparing them.
360 To emulate Unicode-compliant collation on MS-Windows systems,
361 bind `w32-collate-ignore-punctuation' to a non-nil value, since
362 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
364 If your system does not support a locale environment, this function
365 behaves like `string-lessp'. */)
366 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
368 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
369 /* Check parameters. */
371 s1
= SYMBOL_NAME (s1
);
373 s2
= SYMBOL_NAME (s2
);
377 CHECK_STRING (locale
);
379 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
381 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
382 return Fstring_lessp (s1
, s2
);
383 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
386 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
387 doc
: /* Return t if two strings have identical contents.
388 Symbols are also allowed; their print names are used instead.
390 This function obeys the conventions for collation order in your locale
391 settings. For example, characters with different coding points but
392 the same meaning might be considered as equal, like different grave
393 accent Unicode characters:
395 \(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
398 The optional argument LOCALE, a string, overrides the setting of your
399 current locale identifier for collation. The value is system
400 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
401 while it would be \"enu_USA.1252\" on MS Windows systems.
403 If IGNORE-CASE is non-nil, characters are converted to lower-case
404 before comparing them.
406 To emulate Unicode-compliant collation on MS-Windows systems,
407 bind `w32-collate-ignore-punctuation' to a non-nil value, since
408 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
410 If your system does not support a locale environment, this function
411 behaves like `string-equal'.
413 Do NOT use this function to compare file names for equality, only
414 for sorting them. */)
415 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
417 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
418 /* Check parameters. */
420 s1
= SYMBOL_NAME (s1
);
422 s2
= SYMBOL_NAME (s2
);
426 CHECK_STRING (locale
);
428 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
430 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
431 return Fstring_equal (s1
, s2
);
432 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
435 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
436 enum Lisp_Type target_type
, bool last_special
);
440 concat2 (Lisp_Object s1
, Lisp_Object s2
)
445 return concat (2, args
, Lisp_String
, 0);
450 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
456 return concat (3, args
, Lisp_String
, 0);
459 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
460 doc
: /* Concatenate all the arguments and make the result a list.
461 The result is a list whose elements are the elements of all the arguments.
462 Each argument may be a list, vector or string.
463 The last argument is not copied, just used as the tail of the new list.
464 usage: (append &rest SEQUENCES) */)
465 (ptrdiff_t nargs
, Lisp_Object
*args
)
467 return concat (nargs
, args
, Lisp_Cons
, 1);
470 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
471 doc
: /* Concatenate all the arguments and make the result a string.
472 The result is a string whose elements are the elements of all the arguments.
473 Each argument may be a string or a list or vector of characters (integers).
474 usage: (concat &rest SEQUENCES) */)
475 (ptrdiff_t nargs
, Lisp_Object
*args
)
477 return concat (nargs
, args
, Lisp_String
, 0);
480 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
481 doc
: /* Concatenate all the arguments and make the result a vector.
482 The result is a vector whose elements are the elements of all the arguments.
483 Each argument may be a list, vector or string.
484 usage: (vconcat &rest SEQUENCES) */)
485 (ptrdiff_t nargs
, Lisp_Object
*args
)
487 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
491 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
492 doc
: /* Return a copy of a list, vector, string or char-table.
493 The elements of a list or vector are not copied; they are shared
494 with the original. */)
497 if (NILP (arg
)) return arg
;
499 if (CHAR_TABLE_P (arg
))
501 return copy_char_table (arg
);
504 if (BOOL_VECTOR_P (arg
))
506 EMACS_INT nbits
= bool_vector_size (arg
);
507 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
508 Lisp_Object val
= make_uninit_bool_vector (nbits
);
509 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
513 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
514 wrong_type_argument (Qsequencep
, arg
);
516 return concat (1, &arg
, XTYPE (arg
), 0);
519 /* This structure holds information of an argument of `concat' that is
520 a string and has text properties to be copied. */
523 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
524 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
525 ptrdiff_t to
; /* refer to VAL (the target string) */
529 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
530 enum Lisp_Type target_type
, bool last_special
)
536 ptrdiff_t toindex_byte
= 0;
537 EMACS_INT result_len
;
538 EMACS_INT result_len_byte
;
540 Lisp_Object last_tail
;
543 /* When we make a multibyte string, we can't copy text properties
544 while concatenating each string because the length of resulting
545 string can't be decided until we finish the whole concatenation.
546 So, we record strings that have text properties to be copied
547 here, and copy the text properties after the concatenation. */
548 struct textprop_rec
*textprops
= NULL
;
549 /* Number of elements in textprops. */
550 ptrdiff_t num_textprops
= 0;
555 /* In append, the last arg isn't treated like the others */
556 if (last_special
&& nargs
> 0)
559 last_tail
= args
[nargs
];
564 /* Check each argument. */
565 for (argnum
= 0; argnum
< nargs
; argnum
++)
568 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
569 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
570 wrong_type_argument (Qsequencep
, this);
573 /* Compute total length in chars of arguments in RESULT_LEN.
574 If desired output is a string, also compute length in bytes
575 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
576 whether the result should be a multibyte string. */
580 for (argnum
= 0; argnum
< nargs
; argnum
++)
584 len
= XFASTINT (Flength (this));
585 if (target_type
== Lisp_String
)
587 /* We must count the number of bytes needed in the string
588 as well as the number of characters. */
592 ptrdiff_t this_len_byte
;
594 if (VECTORP (this) || COMPILEDP (this))
595 for (i
= 0; i
< len
; i
++)
598 CHECK_CHARACTER (ch
);
600 this_len_byte
= CHAR_BYTES (c
);
601 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
603 result_len_byte
+= this_len_byte
;
604 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
607 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
608 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
609 else if (CONSP (this))
610 for (; CONSP (this); this = XCDR (this))
613 CHECK_CHARACTER (ch
);
615 this_len_byte
= CHAR_BYTES (c
);
616 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
618 result_len_byte
+= this_len_byte
;
619 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
622 else if (STRINGP (this))
624 if (STRING_MULTIBYTE (this))
627 this_len_byte
= SBYTES (this);
630 this_len_byte
= count_size_as_multibyte (SDATA (this),
632 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
634 result_len_byte
+= this_len_byte
;
639 if (MOST_POSITIVE_FIXNUM
< result_len
)
640 memory_full (SIZE_MAX
);
643 if (! some_multibyte
)
644 result_len_byte
= result_len
;
646 /* Create the output object. */
647 if (target_type
== Lisp_Cons
)
648 val
= Fmake_list (make_number (result_len
), Qnil
);
649 else if (target_type
== Lisp_Vectorlike
)
650 val
= Fmake_vector (make_number (result_len
), Qnil
);
651 else if (some_multibyte
)
652 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
654 val
= make_uninit_string (result_len
);
656 /* In `append', if all but last arg are nil, return last arg. */
657 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
660 /* Copy the contents of the args into the result. */
662 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
664 toindex
= 0, toindex_byte
= 0;
668 SAFE_NALLOCA (textprops
, 1, nargs
);
670 for (argnum
= 0; argnum
< nargs
; argnum
++)
673 ptrdiff_t thisleni
= 0;
674 register ptrdiff_t thisindex
= 0;
675 register ptrdiff_t thisindex_byte
= 0;
679 thislen
= Flength (this), thisleni
= XINT (thislen
);
681 /* Between strings of the same kind, copy fast. */
682 if (STRINGP (this) && STRINGP (val
)
683 && STRING_MULTIBYTE (this) == some_multibyte
)
685 ptrdiff_t thislen_byte
= SBYTES (this);
687 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
688 if (string_intervals (this))
690 textprops
[num_textprops
].argnum
= argnum
;
691 textprops
[num_textprops
].from
= 0;
692 textprops
[num_textprops
++].to
= toindex
;
694 toindex_byte
+= thislen_byte
;
697 /* Copy a single-byte string to a multibyte string. */
698 else if (STRINGP (this) && STRINGP (val
))
700 if (string_intervals (this))
702 textprops
[num_textprops
].argnum
= argnum
;
703 textprops
[num_textprops
].from
= 0;
704 textprops
[num_textprops
++].to
= toindex
;
706 toindex_byte
+= copy_text (SDATA (this),
707 SDATA (val
) + toindex_byte
,
708 SCHARS (this), 0, 1);
712 /* Copy element by element. */
715 register Lisp_Object elt
;
717 /* Fetch next element of `this' arg into `elt', or break if
718 `this' is exhausted. */
719 if (NILP (this)) break;
721 elt
= XCAR (this), this = XCDR (this);
722 else if (thisindex
>= thisleni
)
724 else if (STRINGP (this))
727 if (STRING_MULTIBYTE (this))
728 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
733 c
= SREF (this, thisindex
); thisindex
++;
734 if (some_multibyte
&& !ASCII_CHAR_P (c
))
735 c
= BYTE8_TO_CHAR (c
);
737 XSETFASTINT (elt
, c
);
739 else if (BOOL_VECTOR_P (this))
741 elt
= bool_vector_ref (this, thisindex
);
746 elt
= AREF (this, thisindex
);
750 /* Store this element into the result. */
757 else if (VECTORP (val
))
759 ASET (val
, toindex
, elt
);
765 CHECK_CHARACTER (elt
);
768 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
770 SSET (val
, toindex_byte
++, c
);
776 XSETCDR (prev
, last_tail
);
778 if (num_textprops
> 0)
781 ptrdiff_t last_to_end
= -1;
783 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
785 this = args
[textprops
[argnum
].argnum
];
786 props
= text_property_list (this,
788 make_number (SCHARS (this)),
790 /* If successive arguments have properties, be sure that the
791 value of `composition' property be the copy. */
792 if (last_to_end
== textprops
[argnum
].to
)
793 make_composition_value_copy (props
);
794 add_text_properties_from_list (val
, props
,
795 make_number (textprops
[argnum
].to
));
796 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
804 static Lisp_Object string_char_byte_cache_string
;
805 static ptrdiff_t string_char_byte_cache_charpos
;
806 static ptrdiff_t string_char_byte_cache_bytepos
;
809 clear_string_char_byte_cache (void)
811 string_char_byte_cache_string
= Qnil
;
814 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
817 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
820 ptrdiff_t best_below
, best_below_byte
;
821 ptrdiff_t best_above
, best_above_byte
;
823 best_below
= best_below_byte
= 0;
824 best_above
= SCHARS (string
);
825 best_above_byte
= SBYTES (string
);
826 if (best_above
== best_above_byte
)
829 if (EQ (string
, string_char_byte_cache_string
))
831 if (string_char_byte_cache_charpos
< char_index
)
833 best_below
= string_char_byte_cache_charpos
;
834 best_below_byte
= string_char_byte_cache_bytepos
;
838 best_above
= string_char_byte_cache_charpos
;
839 best_above_byte
= string_char_byte_cache_bytepos
;
843 if (char_index
- best_below
< best_above
- char_index
)
845 unsigned char *p
= SDATA (string
) + best_below_byte
;
847 while (best_below
< char_index
)
849 p
+= BYTES_BY_CHAR_HEAD (*p
);
852 i_byte
= p
- SDATA (string
);
856 unsigned char *p
= SDATA (string
) + best_above_byte
;
858 while (best_above
> char_index
)
861 while (!CHAR_HEAD_P (*p
)) p
--;
864 i_byte
= p
- SDATA (string
);
867 string_char_byte_cache_bytepos
= i_byte
;
868 string_char_byte_cache_charpos
= char_index
;
869 string_char_byte_cache_string
= string
;
874 /* Return the character index corresponding to BYTE_INDEX in STRING. */
877 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
880 ptrdiff_t best_below
, best_below_byte
;
881 ptrdiff_t best_above
, best_above_byte
;
883 best_below
= best_below_byte
= 0;
884 best_above
= SCHARS (string
);
885 best_above_byte
= SBYTES (string
);
886 if (best_above
== best_above_byte
)
889 if (EQ (string
, string_char_byte_cache_string
))
891 if (string_char_byte_cache_bytepos
< byte_index
)
893 best_below
= string_char_byte_cache_charpos
;
894 best_below_byte
= string_char_byte_cache_bytepos
;
898 best_above
= string_char_byte_cache_charpos
;
899 best_above_byte
= string_char_byte_cache_bytepos
;
903 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
905 unsigned char *p
= SDATA (string
) + best_below_byte
;
906 unsigned char *pend
= SDATA (string
) + byte_index
;
910 p
+= BYTES_BY_CHAR_HEAD (*p
);
914 i_byte
= p
- SDATA (string
);
918 unsigned char *p
= SDATA (string
) + best_above_byte
;
919 unsigned char *pbeg
= SDATA (string
) + byte_index
;
924 while (!CHAR_HEAD_P (*p
)) p
--;
928 i_byte
= p
- SDATA (string
);
931 string_char_byte_cache_bytepos
= i_byte
;
932 string_char_byte_cache_charpos
= i
;
933 string_char_byte_cache_string
= string
;
938 /* Convert STRING to a multibyte string. */
941 string_make_multibyte (Lisp_Object string
)
948 if (STRING_MULTIBYTE (string
))
951 nbytes
= count_size_as_multibyte (SDATA (string
),
953 /* If all the chars are ASCII, they won't need any more bytes
954 once converted. In that case, we can return STRING itself. */
955 if (nbytes
== SBYTES (string
))
958 buf
= SAFE_ALLOCA (nbytes
);
959 copy_text (SDATA (string
), buf
, SBYTES (string
),
962 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
969 /* Convert STRING (if unibyte) to a multibyte string without changing
970 the number of characters. Characters 0200 trough 0237 are
971 converted to eight-bit characters. */
974 string_to_multibyte (Lisp_Object string
)
981 if (STRING_MULTIBYTE (string
))
984 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
985 /* If all the chars are ASCII, they won't need any more bytes once
987 if (nbytes
== SBYTES (string
))
988 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
990 buf
= SAFE_ALLOCA (nbytes
);
991 memcpy (buf
, SDATA (string
), SBYTES (string
));
992 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
994 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1001 /* Convert STRING to a single-byte string. */
1004 string_make_unibyte (Lisp_Object string
)
1011 if (! STRING_MULTIBYTE (string
))
1014 nchars
= SCHARS (string
);
1016 buf
= SAFE_ALLOCA (nchars
);
1017 copy_text (SDATA (string
), buf
, SBYTES (string
),
1020 ret
= make_unibyte_string ((char *) buf
, nchars
);
1026 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1028 doc
: /* Return the multibyte equivalent of STRING.
1029 If STRING is unibyte and contains non-ASCII characters, the function
1030 `unibyte-char-to-multibyte' is used to convert each unibyte character
1031 to a multibyte character. In this case, the returned string is a
1032 newly created string with no text properties. If STRING is multibyte
1033 or entirely ASCII, it is returned unchanged. In particular, when
1034 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1035 \(When the characters are all ASCII, Emacs primitives will treat the
1036 string the same way whether it is unibyte or multibyte.) */)
1037 (Lisp_Object string
)
1039 CHECK_STRING (string
);
1041 return string_make_multibyte (string
);
1044 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1046 doc
: /* Return the unibyte equivalent of STRING.
1047 Multibyte character codes are converted to unibyte according to
1048 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1049 If the lookup in the translation table fails, this function takes just
1050 the low 8 bits of each character. */)
1051 (Lisp_Object string
)
1053 CHECK_STRING (string
);
1055 return string_make_unibyte (string
);
1058 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1060 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1061 If STRING is unibyte, the result is STRING itself.
1062 Otherwise it is a newly created string, with no text properties.
1063 If STRING is multibyte and contains a character of charset
1064 `eight-bit', it is converted to the corresponding single byte. */)
1065 (Lisp_Object string
)
1067 CHECK_STRING (string
);
1069 if (STRING_MULTIBYTE (string
))
1071 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1072 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1074 string
= make_unibyte_string ((char *) str
, bytes
);
1080 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1082 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1083 If STRING is multibyte, the result is STRING itself.
1084 Otherwise it is a newly created string, with no text properties.
1086 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1087 part of a correct utf-8 sequence), it is converted to the corresponding
1088 multibyte character of charset `eight-bit'.
1089 See also `string-to-multibyte'.
1091 Beware, this often doesn't really do what you think it does.
1092 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1093 If you're not sure, whether to use `string-as-multibyte' or
1094 `string-to-multibyte', use `string-to-multibyte'. */)
1095 (Lisp_Object string
)
1097 CHECK_STRING (string
);
1099 if (! STRING_MULTIBYTE (string
))
1101 Lisp_Object new_string
;
1102 ptrdiff_t nchars
, nbytes
;
1104 parse_str_as_multibyte (SDATA (string
),
1107 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1108 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1109 if (nbytes
!= SBYTES (string
))
1110 str_as_multibyte (SDATA (new_string
), nbytes
,
1111 SBYTES (string
), NULL
);
1112 string
= new_string
;
1113 set_string_intervals (string
, NULL
);
1118 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1120 doc
: /* Return a multibyte string with the same individual chars as STRING.
1121 If STRING is multibyte, the result is STRING itself.
1122 Otherwise it is a newly created string, with no text properties.
1124 If STRING is unibyte and contains an 8-bit byte, it is converted to
1125 the corresponding multibyte character of charset `eight-bit'.
1127 This differs from `string-as-multibyte' by converting each byte of a correct
1128 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1129 correct sequence. */)
1130 (Lisp_Object string
)
1132 CHECK_STRING (string
);
1134 return string_to_multibyte (string
);
1137 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1139 doc
: /* Return a unibyte string with the same individual chars as STRING.
1140 If STRING is unibyte, the result is STRING itself.
1141 Otherwise it is a newly created string, with no text properties,
1142 where each `eight-bit' character is converted to the corresponding byte.
1143 If STRING contains a non-ASCII, non-`eight-bit' character,
1144 an error is signaled. */)
1145 (Lisp_Object string
)
1147 CHECK_STRING (string
);
1149 if (STRING_MULTIBYTE (string
))
1151 ptrdiff_t chars
= SCHARS (string
);
1152 unsigned char *str
= xmalloc (chars
);
1153 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1155 if (converted
< chars
)
1156 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1157 string
= make_unibyte_string ((char *) str
, chars
);
1164 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1165 doc
: /* Return a copy of ALIST.
1166 This is an alist which represents the same mapping from objects to objects,
1167 but does not share the alist structure with ALIST.
1168 The objects mapped (cars and cdrs of elements of the alist)
1169 are shared, however.
1170 Elements of ALIST that are not conses are also shared. */)
1173 register Lisp_Object tem
;
1178 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1179 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1181 register Lisp_Object car
;
1185 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1190 /* Check that ARRAY can have a valid subarray [FROM..TO),
1191 given that its size is SIZE.
1192 If FROM is nil, use 0; if TO is nil, use SIZE.
1193 Count negative values backwards from the end.
1194 Set *IFROM and *ITO to the two indexes used. */
1197 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1198 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1202 if (INTEGERP (from
))
1208 else if (NILP (from
))
1211 wrong_type_argument (Qintegerp
, from
);
1222 wrong_type_argument (Qintegerp
, to
);
1224 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1225 args_out_of_range_3 (array
, from
, to
);
1231 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1232 doc
: /* Return a new string whose contents are a substring of STRING.
1233 The returned string consists of the characters between index FROM
1234 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1235 zero-indexed: 0 means the first character of STRING. Negative values
1236 are counted from the end of STRING. If TO is nil, the substring runs
1237 to the end of STRING.
1239 The STRING argument may also be a vector. In that case, the return
1240 value is a new vector that contains the elements between index FROM
1241 \(inclusive) and index TO (exclusive) of that vector argument.
1243 With one argument, just copy STRING (with properties, if any). */)
1244 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1247 ptrdiff_t size
, ifrom
, ito
;
1249 size
= CHECK_VECTOR_OR_STRING (string
);
1250 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1252 if (STRINGP (string
))
1255 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1257 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1258 res
= make_specified_string (SSDATA (string
) + from_byte
,
1259 ito
- ifrom
, to_byte
- from_byte
,
1260 STRING_MULTIBYTE (string
));
1261 copy_text_properties (make_number (ifrom
), make_number (ito
),
1262 string
, make_number (0), res
, Qnil
);
1265 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1271 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1272 doc
: /* Return a substring of STRING, without text properties.
1273 It starts at index FROM and ends before TO.
1274 TO may be nil or omitted; then the substring runs to the end of STRING.
1275 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1276 If FROM or TO is negative, it counts from the end.
1278 With one argument, just copy STRING without its properties. */)
1279 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1281 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1283 CHECK_STRING (string
);
1285 size
= SCHARS (string
);
1286 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1288 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1290 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1291 return make_specified_string (SSDATA (string
) + from_byte
,
1292 to_char
- from_char
, to_byte
- from_byte
,
1293 STRING_MULTIBYTE (string
));
1296 /* Extract a substring of STRING, giving start and end positions
1297 both in characters and in bytes. */
1300 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1301 ptrdiff_t to
, ptrdiff_t to_byte
)
1304 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1306 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1307 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1309 if (STRINGP (string
))
1311 res
= make_specified_string (SSDATA (string
) + from_byte
,
1312 to
- from
, to_byte
- from_byte
,
1313 STRING_MULTIBYTE (string
));
1314 copy_text_properties (make_number (from
), make_number (to
),
1315 string
, make_number (0), res
, Qnil
);
1318 res
= Fvector (to
- from
, aref_addr (string
, from
));
1323 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1324 doc
: /* Take cdr N times on LIST, return the result. */)
1325 (Lisp_Object n
, Lisp_Object list
)
1330 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1333 CHECK_LIST_CONS (list
, list
);
1339 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1340 doc
: /* Return the Nth element of LIST.
1341 N counts from zero. If LIST is not that long, nil is returned. */)
1342 (Lisp_Object n
, Lisp_Object list
)
1344 return Fcar (Fnthcdr (n
, list
));
1347 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1348 doc
: /* Return element of SEQUENCE at index N. */)
1349 (register Lisp_Object sequence
, Lisp_Object n
)
1352 if (CONSP (sequence
) || NILP (sequence
))
1353 return Fcar (Fnthcdr (n
, sequence
));
1355 /* Faref signals a "not array" error, so check here. */
1356 CHECK_ARRAY (sequence
, Qsequencep
);
1357 return Faref (sequence
, n
);
1360 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1361 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1362 The value is actually the tail of LIST whose car is ELT. */)
1363 (register Lisp_Object elt
, Lisp_Object list
)
1365 register Lisp_Object tail
;
1366 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1368 register Lisp_Object tem
;
1369 CHECK_LIST_CONS (tail
, list
);
1371 if (! NILP (Fequal (elt
, tem
)))
1378 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1379 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1380 The value is actually the tail of LIST whose car is ELT. */)
1381 (register Lisp_Object elt
, Lisp_Object list
)
1385 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1389 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1393 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1404 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1405 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1406 The value is actually the tail of LIST whose car is ELT. */)
1407 (register Lisp_Object elt
, Lisp_Object list
)
1409 register Lisp_Object tail
;
1412 return Fmemq (elt
, list
);
1414 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1416 register Lisp_Object tem
;
1417 CHECK_LIST_CONS (tail
, list
);
1419 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1426 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1427 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1428 The value is actually the first element of LIST whose car is KEY.
1429 Elements of LIST that are not conses are ignored. */)
1430 (Lisp_Object key
, Lisp_Object list
)
1435 || (CONSP (XCAR (list
))
1436 && EQ (XCAR (XCAR (list
)), key
)))
1441 || (CONSP (XCAR (list
))
1442 && EQ (XCAR (XCAR (list
)), key
)))
1447 || (CONSP (XCAR (list
))
1448 && EQ (XCAR (XCAR (list
)), key
)))
1458 /* Like Fassq but never report an error and do not allow quits.
1459 Use only on lists known never to be circular. */
1462 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1465 && (!CONSP (XCAR (list
))
1466 || !EQ (XCAR (XCAR (list
)), key
)))
1469 return CAR_SAFE (list
);
1472 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1473 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1474 The value is actually the first element of LIST whose car equals KEY. */)
1475 (Lisp_Object key
, Lisp_Object list
)
1482 || (CONSP (XCAR (list
))
1483 && (car
= XCAR (XCAR (list
)),
1484 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1489 || (CONSP (XCAR (list
))
1490 && (car
= XCAR (XCAR (list
)),
1491 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1496 || (CONSP (XCAR (list
))
1497 && (car
= XCAR (XCAR (list
)),
1498 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1508 /* Like Fassoc but never report an error and do not allow quits.
1509 Use only on lists known never to be circular. */
1512 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1515 && (!CONSP (XCAR (list
))
1516 || (!EQ (XCAR (XCAR (list
)), key
)
1517 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1520 return CONSP (list
) ? XCAR (list
) : Qnil
;
1523 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1524 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1525 The value is actually the first element of LIST whose cdr is KEY. */)
1526 (register Lisp_Object key
, Lisp_Object list
)
1531 || (CONSP (XCAR (list
))
1532 && EQ (XCDR (XCAR (list
)), key
)))
1537 || (CONSP (XCAR (list
))
1538 && EQ (XCDR (XCAR (list
)), key
)))
1543 || (CONSP (XCAR (list
))
1544 && EQ (XCDR (XCAR (list
)), key
)))
1554 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1555 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1556 The value is actually the first element of LIST whose cdr equals KEY. */)
1557 (Lisp_Object key
, Lisp_Object list
)
1564 || (CONSP (XCAR (list
))
1565 && (cdr
= XCDR (XCAR (list
)),
1566 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1571 || (CONSP (XCAR (list
))
1572 && (cdr
= XCDR (XCAR (list
)),
1573 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1578 || (CONSP (XCAR (list
))
1579 && (cdr
= XCDR (XCAR (list
)),
1580 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1590 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1591 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1592 More precisely, this function skips any members `eq' to ELT at the
1593 front of LIST, then removes members `eq' to ELT from the remaining
1594 sublist by modifying its list structure, then returns the resulting
1597 Write `(setq foo (delq element foo))' to be sure of correctly changing
1598 the value of a list `foo'. */)
1599 (register Lisp_Object elt
, Lisp_Object list
)
1601 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1604 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1606 Lisp_Object tem
= XCAR (tail
);
1612 Fsetcdr (prev
, XCDR (tail
));
1620 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1621 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1622 SEQ must be a sequence (i.e. a list, a vector, or a string).
1623 The return value is a sequence of the same type.
1625 If SEQ is a list, this behaves like `delq', except that it compares
1626 with `equal' instead of `eq'. In particular, it may remove elements
1627 by altering the list structure.
1629 If SEQ is not a list, deletion is never performed destructively;
1630 instead this function creates and returns a new vector or string.
1632 Write `(setq foo (delete element foo))' to be sure of correctly
1633 changing the value of a sequence `foo'. */)
1634 (Lisp_Object elt
, Lisp_Object seq
)
1640 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1641 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1644 if (n
!= ASIZE (seq
))
1646 struct Lisp_Vector
*p
= allocate_vector (n
);
1648 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1649 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1650 p
->contents
[n
++] = AREF (seq
, i
);
1652 XSETVECTOR (seq
, p
);
1655 else if (STRINGP (seq
))
1657 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1660 for (i
= nchars
= nbytes
= ibyte
= 0;
1662 ++i
, ibyte
+= cbytes
)
1664 if (STRING_MULTIBYTE (seq
))
1666 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1667 cbytes
= CHAR_BYTES (c
);
1675 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1682 if (nchars
!= SCHARS (seq
))
1686 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1687 if (!STRING_MULTIBYTE (seq
))
1688 STRING_SET_UNIBYTE (tem
);
1690 for (i
= nchars
= nbytes
= ibyte
= 0;
1692 ++i
, ibyte
+= cbytes
)
1694 if (STRING_MULTIBYTE (seq
))
1696 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1697 cbytes
= CHAR_BYTES (c
);
1705 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1707 unsigned char *from
= SDATA (seq
) + ibyte
;
1708 unsigned char *to
= SDATA (tem
) + nbytes
;
1714 for (n
= cbytes
; n
--; )
1724 Lisp_Object tail
, prev
;
1726 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1728 CHECK_LIST_CONS (tail
, seq
);
1730 if (!NILP (Fequal (elt
, XCAR (tail
))))
1735 Fsetcdr (prev
, XCDR (tail
));
1746 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1747 doc
: /* Reverse order of items in a list, vector or string SEQ.
1748 If SEQ is a list, it should be nil-terminated.
1749 This function may destructively modify SEQ to produce the value. */)
1754 else if (STRINGP (seq
))
1755 return Freverse (seq
);
1756 else if (CONSP (seq
))
1758 Lisp_Object prev
, tail
, next
;
1760 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1763 CHECK_LIST_CONS (tail
, tail
);
1765 Fsetcdr (tail
, prev
);
1770 else if (VECTORP (seq
))
1772 ptrdiff_t i
, size
= ASIZE (seq
);
1774 for (i
= 0; i
< size
/ 2; i
++)
1776 Lisp_Object tem
= AREF (seq
, i
);
1777 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1778 ASET (seq
, size
- i
- 1, tem
);
1781 else if (BOOL_VECTOR_P (seq
))
1783 ptrdiff_t i
, size
= bool_vector_size (seq
);
1785 for (i
= 0; i
< size
/ 2; i
++)
1787 bool tem
= bool_vector_bitref (seq
, i
);
1788 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1789 bool_vector_set (seq
, size
- i
- 1, tem
);
1793 wrong_type_argument (Qarrayp
, seq
);
1797 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1798 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1799 See also the function `nreverse', which is used more often. */)
1806 else if (CONSP (seq
))
1808 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1811 new = Fcons (XCAR (seq
), new);
1813 CHECK_LIST_END (seq
, seq
);
1815 else if (VECTORP (seq
))
1817 ptrdiff_t i
, size
= ASIZE (seq
);
1819 new = make_uninit_vector (size
);
1820 for (i
= 0; i
< size
; i
++)
1821 ASET (new, i
, AREF (seq
, size
- i
- 1));
1823 else if (BOOL_VECTOR_P (seq
))
1826 EMACS_INT nbits
= bool_vector_size (seq
);
1828 new = make_uninit_bool_vector (nbits
);
1829 for (i
= 0; i
< nbits
; i
++)
1830 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1832 else if (STRINGP (seq
))
1834 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1840 new = make_uninit_string (size
);
1841 for (i
= 0; i
< size
; i
++)
1842 SSET (new, i
, SREF (seq
, size
- i
- 1));
1846 unsigned char *p
, *q
;
1848 new = make_uninit_multibyte_string (size
, bytes
);
1849 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1850 while (q
> SDATA (new))
1854 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1856 CHAR_STRING (ch
, q
);
1861 wrong_type_argument (Qsequencep
, seq
);
1865 /* Sort LIST using PREDICATE, preserving original order of elements
1866 considered as equal. */
1869 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1871 Lisp_Object front
, back
;
1872 register Lisp_Object len
, tem
;
1873 struct gcpro gcpro1
, gcpro2
;
1877 len
= Flength (list
);
1878 length
= XINT (len
);
1882 XSETINT (len
, (length
/ 2) - 1);
1883 tem
= Fnthcdr (len
, list
);
1885 Fsetcdr (tem
, Qnil
);
1887 GCPRO2 (front
, back
);
1888 front
= Fsort (front
, predicate
);
1889 back
= Fsort (back
, predicate
);
1891 return merge (front
, back
, predicate
);
1894 /* Using PRED to compare, return whether A and B are in order.
1895 Compare stably when A appeared before B in the input. */
1897 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1899 return NILP (call2 (pred
, b
, a
));
1902 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1903 into DEST. Argument arrays must be nonempty and must not overlap,
1904 except that B might be the last part of DEST. */
1906 merge_vectors (Lisp_Object pred
,
1907 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1908 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1909 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1911 eassume (0 < alen
&& 0 < blen
);
1912 Lisp_Object
const *alim
= a
+ alen
;
1913 Lisp_Object
const *blim
= b
+ blen
;
1917 if (inorder (pred
, a
[0], b
[0]))
1923 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1932 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1939 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1940 temporary storage. LEN must be at least 2. */
1942 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1943 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1944 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1947 ptrdiff_t halflen
= len
>> 1;
1948 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1949 if (1 < len
- halflen
)
1950 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1951 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1954 /* Using PRED to compare, sort from LEN-length SRC into DST.
1955 Len must be positive. */
1957 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1958 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1959 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1962 ptrdiff_t halflen
= len
>> 1;
1968 sort_vector_inplace (pred
, halflen
, src
, dest
);
1969 if (1 < len
- halflen
)
1970 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1971 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1975 /* Sort VECTOR in place using PREDICATE, preserving original order of
1976 elements considered as equal. */
1979 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1981 ptrdiff_t len
= ASIZE (vector
);
1984 ptrdiff_t halflen
= len
>> 1;
1986 struct gcpro gcpro1
, gcpro2
;
1987 GCPRO2 (vector
, predicate
);
1989 SAFE_ALLOCA_LISP (tmp
, halflen
);
1990 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1991 tmp
[i
] = make_number (0);
1992 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1997 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1998 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1999 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2000 modified by side effects. PREDICATE is called with two elements of
2001 SEQ, and should return non-nil if the first element should sort before
2003 (Lisp_Object seq
, Lisp_Object predicate
)
2006 seq
= sort_list (seq
, predicate
);
2007 else if (VECTORP (seq
))
2008 sort_vector (seq
, predicate
);
2009 else if (!NILP (seq
))
2010 wrong_type_argument (Qsequencep
, seq
);
2015 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2018 register Lisp_Object tail
;
2020 register Lisp_Object l1
, l2
;
2021 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2028 /* It is sufficient to protect org_l1 and org_l2.
2029 When l1 and l2 are updated, we copy the new values
2030 back into the org_ vars. */
2031 GCPRO4 (org_l1
, org_l2
, pred
, value
);
2051 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2066 Fsetcdr (tail
, tem
);
2072 /* This does not check for quits. That is safe since it must terminate. */
2074 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2075 doc
: /* Extract a value from a property list.
2076 PLIST is a property list, which is a list of the form
2077 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2078 corresponding to the given PROP, or nil if PROP is not one of the
2079 properties on the list. This function never signals an error. */)
2080 (Lisp_Object plist
, Lisp_Object prop
)
2082 Lisp_Object tail
, halftail
;
2084 /* halftail is used to detect circular lists. */
2085 tail
= halftail
= plist
;
2086 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2088 if (EQ (prop
, XCAR (tail
)))
2089 return XCAR (XCDR (tail
));
2091 tail
= XCDR (XCDR (tail
));
2092 halftail
= XCDR (halftail
);
2093 if (EQ (tail
, halftail
))
2100 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2101 doc
: /* Return the value of SYMBOL's PROPNAME property.
2102 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2103 (Lisp_Object symbol
, Lisp_Object propname
)
2105 CHECK_SYMBOL (symbol
);
2106 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2109 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2110 doc
: /* Change value in PLIST of PROP to VAL.
2111 PLIST is a property list, which is a list of the form
2112 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2113 If PROP is already a property on the list, its value is set to VAL,
2114 otherwise the new PROP VAL pair is added. The new plist is returned;
2115 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2116 The PLIST is modified by side effects. */)
2117 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2119 register Lisp_Object tail
, prev
;
2120 Lisp_Object newcell
;
2122 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2123 tail
= XCDR (XCDR (tail
)))
2125 if (EQ (prop
, XCAR (tail
)))
2127 Fsetcar (XCDR (tail
), val
);
2134 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2138 Fsetcdr (XCDR (prev
), newcell
);
2142 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2143 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2144 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2145 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2147 CHECK_SYMBOL (symbol
);
2149 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2153 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2154 doc
: /* Extract a value from a property list, comparing with `equal'.
2155 PLIST is a property list, which is a list of the form
2156 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2157 corresponding to the given PROP, or nil if PROP is not
2158 one of the properties on the list. */)
2159 (Lisp_Object plist
, Lisp_Object prop
)
2164 CONSP (tail
) && CONSP (XCDR (tail
));
2165 tail
= XCDR (XCDR (tail
)))
2167 if (! NILP (Fequal (prop
, XCAR (tail
))))
2168 return XCAR (XCDR (tail
));
2173 CHECK_LIST_END (tail
, prop
);
2178 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2179 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2180 PLIST is a property list, which is a list of the form
2181 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2182 If PROP is already a property on the list, its value is set to VAL,
2183 otherwise the new PROP VAL pair is added. The new plist is returned;
2184 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2185 The PLIST is modified by side effects. */)
2186 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2188 register Lisp_Object tail
, prev
;
2189 Lisp_Object newcell
;
2191 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2192 tail
= XCDR (XCDR (tail
)))
2194 if (! NILP (Fequal (prop
, XCAR (tail
))))
2196 Fsetcar (XCDR (tail
), val
);
2203 newcell
= list2 (prop
, val
);
2207 Fsetcdr (XCDR (prev
), newcell
);
2211 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2212 doc
: /* Return t if the two args are the same Lisp object.
2213 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2214 (Lisp_Object obj1
, Lisp_Object obj2
)
2217 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2219 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2222 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2223 doc
: /* Return t if two Lisp objects have similar structure and contents.
2224 They must have the same data type.
2225 Conses are compared by comparing the cars and the cdrs.
2226 Vectors and strings are compared element by element.
2227 Numbers are compared by value, but integers cannot equal floats.
2228 (Use `=' if you want integers and floats to be able to be equal.)
2229 Symbols must match exactly. */)
2230 (register Lisp_Object o1
, Lisp_Object o2
)
2232 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2235 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2236 doc
: /* Return t if two Lisp objects have similar structure and contents.
2237 This is like `equal' except that it compares the text properties
2238 of strings. (`equal' ignores text properties.) */)
2239 (register Lisp_Object o1
, Lisp_Object o2
)
2241 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2244 /* DEPTH is current depth of recursion. Signal an error if it
2246 PROPS means compare string text properties too. */
2249 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2255 error ("Stack overflow in equal");
2258 Lisp_Object args
[2];
2261 ht
= Fmake_hash_table (2, args
);
2265 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2267 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2269 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2271 { /* `o1' was seen already. */
2272 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2273 if (!NILP (Fmemq (o2
, o2s
)))
2276 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2279 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2289 if (XTYPE (o1
) != XTYPE (o2
))
2298 d1
= extract_float (o1
);
2299 d2
= extract_float (o2
);
2300 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2301 though they are not =. */
2302 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2306 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2310 /* FIXME: This inf-loops in a circular list! */
2314 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2318 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2319 depth
+ 1, props
, ht
)
2320 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2321 depth
+ 1, props
, ht
))
2323 o1
= XOVERLAY (o1
)->plist
;
2324 o2
= XOVERLAY (o2
)->plist
;
2329 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2330 && (XMARKER (o1
)->buffer
== 0
2331 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2335 case Lisp_Vectorlike
:
2338 ptrdiff_t size
= ASIZE (o1
);
2339 /* Pseudovectors have the type encoded in the size field, so this test
2340 actually checks that the objects have the same type as well as the
2342 if (ASIZE (o2
) != size
)
2344 /* Boolvectors are compared much like strings. */
2345 if (BOOL_VECTOR_P (o1
))
2347 EMACS_INT size
= bool_vector_size (o1
);
2348 if (size
!= bool_vector_size (o2
))
2350 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2351 bool_vector_bytes (size
)))
2355 if (WINDOW_CONFIGURATIONP (o1
))
2356 return compare_window_configurations (o1
, o2
, 0);
2358 /* Aside from them, only true vectors, char-tables, compiled
2359 functions, and fonts (font-spec, font-entity, font-object)
2360 are sensible to compare, so eliminate the others now. */
2361 if (size
& PSEUDOVECTOR_FLAG
)
2363 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2366 size
&= PSEUDOVECTOR_SIZE_MASK
;
2368 for (i
= 0; i
< size
; i
++)
2373 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2381 if (SCHARS (o1
) != SCHARS (o2
))
2383 if (SBYTES (o1
) != SBYTES (o2
))
2385 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2387 if (props
&& !compare_string_intervals (o1
, o2
))
2399 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2400 doc
: /* Store each element of ARRAY with ITEM.
2401 ARRAY is a vector, string, char-table, or bool-vector. */)
2402 (Lisp_Object array
, Lisp_Object item
)
2404 register ptrdiff_t size
, idx
;
2406 if (VECTORP (array
))
2407 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2408 ASET (array
, idx
, item
);
2409 else if (CHAR_TABLE_P (array
))
2413 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2414 set_char_table_contents (array
, i
, item
);
2415 set_char_table_defalt (array
, item
);
2417 else if (STRINGP (array
))
2419 register unsigned char *p
= SDATA (array
);
2421 CHECK_CHARACTER (item
);
2422 charval
= XFASTINT (item
);
2423 size
= SCHARS (array
);
2424 if (STRING_MULTIBYTE (array
))
2426 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2427 int len
= CHAR_STRING (charval
, str
);
2428 ptrdiff_t size_byte
= SBYTES (array
);
2430 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2431 || SCHARS (array
) * len
!= size_byte
)
2432 error ("Attempt to change byte length of a string");
2433 for (idx
= 0; idx
< size_byte
; idx
++)
2434 *p
++ = str
[idx
% len
];
2437 for (idx
= 0; idx
< size
; idx
++)
2440 else if (BOOL_VECTOR_P (array
))
2441 return bool_vector_fill (array
, item
);
2443 wrong_type_argument (Qarrayp
, array
);
2447 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2449 doc
: /* Clear the contents of STRING.
2450 This makes STRING unibyte and may change its length. */)
2451 (Lisp_Object string
)
2454 CHECK_STRING (string
);
2455 len
= SBYTES (string
);
2456 memset (SDATA (string
), 0, len
);
2457 STRING_SET_CHARS (string
, len
);
2458 STRING_SET_UNIBYTE (string
);
2464 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2466 Lisp_Object args
[2];
2469 return Fnconc (2, args
);
2472 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2473 doc
: /* Concatenate any number of lists by altering them.
2474 Only the last argument is not altered, and need not be a list.
2475 usage: (nconc &rest LISTS) */)
2476 (ptrdiff_t nargs
, Lisp_Object
*args
)
2479 register Lisp_Object tail
, tem
, val
;
2483 for (argnum
= 0; argnum
< nargs
; argnum
++)
2486 if (NILP (tem
)) continue;
2491 if (argnum
+ 1 == nargs
) break;
2493 CHECK_LIST_CONS (tem
, tem
);
2502 tem
= args
[argnum
+ 1];
2503 Fsetcdr (tail
, tem
);
2505 args
[argnum
+ 1] = tail
;
2511 /* This is the guts of all mapping functions.
2512 Apply FN to each element of SEQ, one by one,
2513 storing the results into elements of VALS, a C vector of Lisp_Objects.
2514 LENI is the length of VALS, which should also be the length of SEQ. */
2517 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2519 register Lisp_Object tail
;
2521 register EMACS_INT i
;
2522 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2526 /* Don't let vals contain any garbage when GC happens. */
2527 for (i
= 0; i
< leni
; i
++)
2530 GCPRO3 (dummy
, fn
, seq
);
2532 gcpro1
.nvars
= leni
;
2536 /* We need not explicitly protect `tail' because it is used only on lists, and
2537 1) lists are not relocated and 2) the list is marked via `seq' so will not
2540 if (VECTORP (seq
) || COMPILEDP (seq
))
2542 for (i
= 0; i
< leni
; i
++)
2544 dummy
= call1 (fn
, AREF (seq
, i
));
2549 else if (BOOL_VECTOR_P (seq
))
2551 for (i
= 0; i
< leni
; i
++)
2553 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2558 else if (STRINGP (seq
))
2562 for (i
= 0, i_byte
= 0; i
< leni
;)
2565 ptrdiff_t i_before
= i
;
2567 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2568 XSETFASTINT (dummy
, c
);
2569 dummy
= call1 (fn
, dummy
);
2571 vals
[i_before
] = dummy
;
2574 else /* Must be a list, since Flength did not get an error */
2577 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2579 dummy
= call1 (fn
, XCAR (tail
));
2589 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2590 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2591 In between each pair of results, stick in SEPARATOR. Thus, " " as
2592 SEPARATOR results in spaces between the values returned by FUNCTION.
2593 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2594 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2597 register EMACS_INT leni
;
2600 register Lisp_Object
*args
;
2601 struct gcpro gcpro1
;
2605 len
= Flength (sequence
);
2606 if (CHAR_TABLE_P (sequence
))
2607 wrong_type_argument (Qlistp
, sequence
);
2609 nargs
= leni
+ leni
- 1;
2610 if (nargs
< 0) return empty_unibyte_string
;
2612 SAFE_ALLOCA_LISP (args
, nargs
);
2615 mapcar1 (leni
, args
, function
, sequence
);
2618 for (i
= leni
- 1; i
> 0; i
--)
2619 args
[i
+ i
] = args
[i
];
2621 for (i
= 1; i
< nargs
; i
+= 2)
2622 args
[i
] = separator
;
2624 ret
= Fconcat (nargs
, args
);
2630 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2631 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2632 The result is a list just as long as SEQUENCE.
2633 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2634 (Lisp_Object function
, Lisp_Object sequence
)
2636 register Lisp_Object len
;
2637 register EMACS_INT leni
;
2638 register Lisp_Object
*args
;
2642 len
= Flength (sequence
);
2643 if (CHAR_TABLE_P (sequence
))
2644 wrong_type_argument (Qlistp
, sequence
);
2645 leni
= XFASTINT (len
);
2647 SAFE_ALLOCA_LISP (args
, leni
);
2649 mapcar1 (leni
, args
, function
, sequence
);
2651 ret
= Flist (leni
, args
);
2657 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2658 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2659 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2660 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2661 (Lisp_Object function
, Lisp_Object sequence
)
2663 register EMACS_INT leni
;
2665 leni
= XFASTINT (Flength (sequence
));
2666 if (CHAR_TABLE_P (sequence
))
2667 wrong_type_argument (Qlistp
, sequence
);
2668 mapcar1 (leni
, 0, function
, sequence
);
2673 /* This is how C code calls `yes-or-no-p' and allows the user
2676 Anything that calls this function must protect from GC! */
2679 do_yes_or_no_p (Lisp_Object prompt
)
2681 return call1 (intern ("yes-or-no-p"), prompt
);
2684 /* Anything that calls this function must protect from GC! */
2686 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2687 doc
: /* Ask user a yes-or-no question.
2688 Return t if answer is yes, and nil if the answer is no.
2689 PROMPT is the string to display to ask the question. It should end in
2690 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2692 The user must confirm the answer with RET, and can edit it until it
2695 If dialog boxes are supported, a dialog box will be used
2696 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2697 (Lisp_Object prompt
)
2700 struct gcpro gcpro1
;
2702 CHECK_STRING (prompt
);
2704 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2707 Lisp_Object pane
, menu
, obj
;
2708 redisplay_preserve_echo_area (4);
2709 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2710 Fcons (build_string ("No"), Qnil
));
2712 menu
= Fcons (prompt
, pane
);
2713 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2718 AUTO_STRING (yes_or_no
, "(yes or no) ");
2719 prompt
= Fconcat (2, (Lisp_Object
[]) {prompt
, yes_or_no
});
2724 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2725 Qyes_or_no_p_history
, Qnil
,
2727 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2732 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2740 message1 ("Please answer yes or no.");
2741 Fsleep_for (make_number (2), Qnil
);
2745 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2746 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2748 Each of the three load averages is multiplied by 100, then converted
2751 When USE-FLOATS is non-nil, floats will be used instead of integers.
2752 These floats are not multiplied by 100.
2754 If the 5-minute or 15-minute load averages are not available, return a
2755 shortened list, containing only those averages which are available.
2757 An error is thrown if the load average can't be obtained. In some
2758 cases making it work would require Emacs being installed setuid or
2759 setgid so that it can read kernel information, and that usually isn't
2761 (Lisp_Object use_floats
)
2764 int loads
= getloadavg (load_ave
, 3);
2765 Lisp_Object ret
= Qnil
;
2768 error ("load-average not implemented for this operating system");
2772 Lisp_Object load
= (NILP (use_floats
)
2773 ? make_number (100.0 * load_ave
[loads
])
2774 : make_float (load_ave
[loads
]));
2775 ret
= Fcons (load
, ret
);
2781 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2782 doc
: /* Return t if FEATURE is present in this Emacs.
2784 Use this to conditionalize execution of lisp code based on the
2785 presence or absence of Emacs or environment extensions.
2786 Use `provide' to declare that a feature is available. This function
2787 looks at the value of the variable `features'. The optional argument
2788 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2789 (Lisp_Object feature
, Lisp_Object subfeature
)
2791 register Lisp_Object tem
;
2792 CHECK_SYMBOL (feature
);
2793 tem
= Fmemq (feature
, Vfeatures
);
2794 if (!NILP (tem
) && !NILP (subfeature
))
2795 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2796 return (NILP (tem
)) ? Qnil
: Qt
;
2799 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2800 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2801 The optional argument SUBFEATURES should be a list of symbols listing
2802 particular subfeatures supported in this version of FEATURE. */)
2803 (Lisp_Object feature
, Lisp_Object subfeatures
)
2805 register Lisp_Object tem
;
2806 CHECK_SYMBOL (feature
);
2807 CHECK_LIST (subfeatures
);
2808 if (!NILP (Vautoload_queue
))
2809 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2811 tem
= Fmemq (feature
, Vfeatures
);
2813 Vfeatures
= Fcons (feature
, Vfeatures
);
2814 if (!NILP (subfeatures
))
2815 Fput (feature
, Qsubfeatures
, subfeatures
);
2816 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2818 /* Run any load-hooks for this file. */
2819 tem
= Fassq (feature
, Vafter_load_alist
);
2821 Fmapc (Qfuncall
, XCDR (tem
));
2826 /* `require' and its subroutines. */
2828 /* List of features currently being require'd, innermost first. */
2830 static Lisp_Object require_nesting_list
;
2833 require_unwind (Lisp_Object old_value
)
2835 require_nesting_list
= old_value
;
2838 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2839 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2840 If FEATURE is not a member of the list `features', then the feature
2841 is not loaded; so load the file FILENAME.
2842 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2843 and `load' will try to load this name appended with the suffix `.elc' or
2844 `.el', in that order. The name without appended suffix will not be used.
2845 See `get-load-suffixes' for the complete list of suffixes.
2846 If the optional third argument NOERROR is non-nil,
2847 then return nil if the file is not found instead of signaling an error.
2848 Normally the return value is FEATURE.
2849 The normal messages at start and end of loading FILENAME are suppressed. */)
2850 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2853 struct gcpro gcpro1
, gcpro2
;
2854 bool from_file
= load_in_progress
;
2856 CHECK_SYMBOL (feature
);
2858 /* Record the presence of `require' in this file
2859 even if the feature specified is already loaded.
2860 But not more than once in any file,
2861 and not when we aren't loading or reading from a file. */
2863 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2864 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2869 tem
= Fcons (Qrequire
, feature
);
2870 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2871 LOADHIST_ATTACH (tem
);
2873 tem
= Fmemq (feature
, Vfeatures
);
2877 ptrdiff_t count
= SPECPDL_INDEX ();
2880 /* This is to make sure that loadup.el gives a clear picture
2881 of what files are preloaded and when. */
2882 if (! NILP (Vpurify_flag
))
2883 error ("(require %s) while preparing to dump",
2884 SDATA (SYMBOL_NAME (feature
)));
2886 /* A certain amount of recursive `require' is legitimate,
2887 but if we require the same feature recursively 3 times,
2889 tem
= require_nesting_list
;
2890 while (! NILP (tem
))
2892 if (! NILP (Fequal (feature
, XCAR (tem
))))
2897 error ("Recursive `require' for feature `%s'",
2898 SDATA (SYMBOL_NAME (feature
)));
2900 /* Update the list for any nested `require's that occur. */
2901 record_unwind_protect (require_unwind
, require_nesting_list
);
2902 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2904 /* Value saved here is to be restored into Vautoload_queue */
2905 record_unwind_protect (un_autoload
, Vautoload_queue
);
2906 Vautoload_queue
= Qt
;
2908 /* Load the file. */
2909 GCPRO2 (feature
, filename
);
2910 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2911 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2914 /* If load failed entirely, return nil. */
2916 return unbind_to (count
, Qnil
);
2918 tem
= Fmemq (feature
, Vfeatures
);
2920 error ("Required feature `%s' was not provided",
2921 SDATA (SYMBOL_NAME (feature
)));
2923 /* Once loading finishes, don't undo it. */
2924 Vautoload_queue
= Qt
;
2925 feature
= unbind_to (count
, feature
);
2931 /* Primitives for work of the "widget" library.
2932 In an ideal world, this section would not have been necessary.
2933 However, lisp function calls being as slow as they are, it turns
2934 out that some functions in the widget library (wid-edit.el) are the
2935 bottleneck of Widget operation. Here is their translation to C,
2936 for the sole reason of efficiency. */
2938 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2939 doc
: /* Return non-nil if PLIST has the property PROP.
2940 PLIST is a property list, which is a list of the form
2941 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2942 Unlike `plist-get', this allows you to distinguish between a missing
2943 property and a property with the value nil.
2944 The value is actually the tail of PLIST whose car is PROP. */)
2945 (Lisp_Object plist
, Lisp_Object prop
)
2947 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2950 plist
= XCDR (plist
);
2951 plist
= CDR (plist
);
2956 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2957 doc
: /* In WIDGET, set PROPERTY to VALUE.
2958 The value can later be retrieved with `widget-get'. */)
2959 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2961 CHECK_CONS (widget
);
2962 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2966 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2967 doc
: /* In WIDGET, get the value of PROPERTY.
2968 The value could either be specified when the widget was created, or
2969 later with `widget-put'. */)
2970 (Lisp_Object widget
, Lisp_Object property
)
2978 CHECK_CONS (widget
);
2979 tmp
= Fplist_member (XCDR (widget
), property
);
2985 tmp
= XCAR (widget
);
2988 widget
= Fget (tmp
, Qwidget_type
);
2992 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2993 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2994 ARGS are passed as extra arguments to the function.
2995 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2996 (ptrdiff_t nargs
, Lisp_Object
*args
)
2998 /* This function can GC. */
2999 Lisp_Object newargs
[3];
3000 struct gcpro gcpro1
, gcpro2
;
3003 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3004 newargs
[1] = args
[0];
3005 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3006 GCPRO2 (newargs
[0], newargs
[2]);
3007 result
= Fapply (3, newargs
);
3012 #ifdef HAVE_LANGINFO_CODESET
3013 #include <langinfo.h>
3016 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3017 doc
: /* Access locale data ITEM for the current C locale, if available.
3018 ITEM should be one of the following:
3020 `codeset', returning the character set as a string (locale item CODESET);
3022 `days', returning a 7-element vector of day names (locale items DAY_n);
3024 `months', returning a 12-element vector of month names (locale items MON_n);
3026 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3027 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3029 If the system can't provide such information through a call to
3030 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3032 See also Info node `(libc)Locales'.
3034 The data read from the system are decoded using `locale-coding-system'. */)
3038 #ifdef HAVE_LANGINFO_CODESET
3040 if (EQ (item
, Qcodeset
))
3042 str
= nl_langinfo (CODESET
);
3043 return build_string (str
);
3046 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3048 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3049 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3051 struct gcpro gcpro1
;
3053 synchronize_system_time_locale ();
3054 for (i
= 0; i
< 7; i
++)
3056 str
= nl_langinfo (days
[i
]);
3057 val
= build_unibyte_string (str
);
3058 /* Fixme: Is this coding system necessarily right, even if
3059 it is consistent with CODESET? If not, what to do? */
3060 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3068 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3070 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3071 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3072 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3074 struct gcpro gcpro1
;
3076 synchronize_system_time_locale ();
3077 for (i
= 0; i
< 12; i
++)
3079 str
= nl_langinfo (months
[i
]);
3080 val
= build_unibyte_string (str
);
3081 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3088 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3089 but is in the locale files. This could be used by ps-print. */
3091 else if (EQ (item
, Qpaper
))
3092 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3093 #endif /* PAPER_WIDTH */
3094 #endif /* HAVE_LANGINFO_CODESET*/
3098 /* base64 encode/decode functions (RFC 2045).
3099 Based on code from GNU recode. */
3101 #define MIME_LINE_LENGTH 76
3103 #define IS_ASCII(Character) \
3105 #define IS_BASE64(Character) \
3106 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3107 #define IS_BASE64_IGNORABLE(Character) \
3108 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3109 || (Character) == '\f' || (Character) == '\r')
3111 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3112 character or return retval if there are no characters left to
3114 #define READ_QUADRUPLET_BYTE(retval) \
3119 if (nchars_return) \
3120 *nchars_return = nchars; \
3125 while (IS_BASE64_IGNORABLE (c))
3127 /* Table of characters coding the 64 values. */
3128 static const char base64_value_to_char
[64] =
3130 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3131 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3132 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3133 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3134 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3135 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3136 '8', '9', '+', '/' /* 60-63 */
3139 /* Table of base64 values for first 128 characters. */
3140 static const short base64_char_to_value
[128] =
3142 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3143 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3144 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3145 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3146 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3147 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3148 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3149 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3150 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3151 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3152 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3153 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3154 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3157 /* The following diagram shows the logical steps by which three octets
3158 get transformed into four base64 characters.
3160 .--------. .--------. .--------.
3161 |aaaaaabb| |bbbbcccc| |ccdddddd|
3162 `--------' `--------' `--------'
3164 .--------+--------+--------+--------.
3165 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3166 `--------+--------+--------+--------'
3168 .--------+--------+--------+--------.
3169 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3170 `--------+--------+--------+--------'
3172 The octets are divided into 6 bit chunks, which are then encoded into
3173 base64 characters. */
3176 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3177 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3180 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3182 doc
: /* Base64-encode the region between BEG and END.
3183 Return the length of the encoded text.
3184 Optional third argument NO-LINE-BREAK means do not break long lines
3185 into shorter lines. */)
3186 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3189 ptrdiff_t allength
, length
;
3190 ptrdiff_t ibeg
, iend
, encoded_length
;
3191 ptrdiff_t old_pos
= PT
;
3194 validate_region (&beg
, &end
);
3196 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3197 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3198 move_gap_both (XFASTINT (beg
), ibeg
);
3200 /* We need to allocate enough room for encoding the text.
3201 We need 33 1/3% more space, plus a newline every 76
3202 characters, and then we round up. */
3203 length
= iend
- ibeg
;
3204 allength
= length
+ length
/3 + 1;
3205 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3207 encoded
= SAFE_ALLOCA (allength
);
3208 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3209 encoded
, length
, NILP (no_line_break
),
3210 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3211 if (encoded_length
> allength
)
3214 if (encoded_length
< 0)
3216 /* The encoding wasn't possible. */
3218 error ("Multibyte character in data for base64 encoding");
3221 /* Now we have encoded the region, so we insert the new contents
3222 and delete the old. (Insert first in order to preserve markers.) */
3223 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3224 insert (encoded
, encoded_length
);
3226 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3228 /* If point was outside of the region, restore it exactly; else just
3229 move to the beginning of the region. */
3230 if (old_pos
>= XFASTINT (end
))
3231 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3232 else if (old_pos
> XFASTINT (beg
))
3233 old_pos
= XFASTINT (beg
);
3236 /* We return the length of the encoded text. */
3237 return make_number (encoded_length
);
3240 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3242 doc
: /* Base64-encode STRING and return the result.
3243 Optional second argument NO-LINE-BREAK means do not break long lines
3244 into shorter lines. */)
3245 (Lisp_Object string
, Lisp_Object no_line_break
)
3247 ptrdiff_t allength
, length
, encoded_length
;
3249 Lisp_Object encoded_string
;
3252 CHECK_STRING (string
);
3254 /* We need to allocate enough room for encoding the text.
3255 We need 33 1/3% more space, plus a newline every 76
3256 characters, and then we round up. */
3257 length
= SBYTES (string
);
3258 allength
= length
+ length
/3 + 1;
3259 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3261 /* We need to allocate enough room for decoding the text. */
3262 encoded
= SAFE_ALLOCA (allength
);
3264 encoded_length
= base64_encode_1 (SSDATA (string
),
3265 encoded
, length
, NILP (no_line_break
),
3266 STRING_MULTIBYTE (string
));
3267 if (encoded_length
> allength
)
3270 if (encoded_length
< 0)
3272 /* The encoding wasn't possible. */
3273 error ("Multibyte character in data for base64 encoding");
3276 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3279 return encoded_string
;
3283 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3284 bool line_break
, bool multibyte
)
3297 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3298 if (CHAR_BYTE8_P (c
))
3299 c
= CHAR_TO_BYTE8 (c
);
3307 /* Wrap line every 76 characters. */
3311 if (counter
< MIME_LINE_LENGTH
/ 4)
3320 /* Process first byte of a triplet. */
3322 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3323 value
= (0x03 & c
) << 4;
3325 /* Process second byte of a triplet. */
3329 *e
++ = base64_value_to_char
[value
];
3337 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3338 if (CHAR_BYTE8_P (c
))
3339 c
= CHAR_TO_BYTE8 (c
);
3347 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3348 value
= (0x0f & c
) << 2;
3350 /* Process third byte of a triplet. */
3354 *e
++ = base64_value_to_char
[value
];
3361 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3362 if (CHAR_BYTE8_P (c
))
3363 c
= CHAR_TO_BYTE8 (c
);
3371 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3372 *e
++ = base64_value_to_char
[0x3f & c
];
3379 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3381 doc
: /* Base64-decode the region between BEG and END.
3382 Return the length of the decoded text.
3383 If the region can't be decoded, signal an error and don't modify the buffer. */)
3384 (Lisp_Object beg
, Lisp_Object end
)
3386 ptrdiff_t ibeg
, iend
, length
, allength
;
3388 ptrdiff_t old_pos
= PT
;
3389 ptrdiff_t decoded_length
;
3390 ptrdiff_t inserted_chars
;
3391 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3394 validate_region (&beg
, &end
);
3396 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3397 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3399 length
= iend
- ibeg
;
3401 /* We need to allocate enough room for decoding the text. If we are
3402 working on a multibyte buffer, each decoded code may occupy at
3404 allength
= multibyte
? length
* 2 : length
;
3405 decoded
= SAFE_ALLOCA (allength
);
3407 move_gap_both (XFASTINT (beg
), ibeg
);
3408 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3410 multibyte
, &inserted_chars
);
3411 if (decoded_length
> allength
)
3414 if (decoded_length
< 0)
3416 /* The decoding wasn't possible. */
3417 error ("Invalid base64 data");
3420 /* Now we have decoded the region, so we insert the new contents
3421 and delete the old. (Insert first in order to preserve markers.) */
3422 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3423 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3426 /* Delete the original text. */
3427 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3428 iend
+ decoded_length
, 1);
3430 /* If point was outside of the region, restore it exactly; else just
3431 move to the beginning of the region. */
3432 if (old_pos
>= XFASTINT (end
))
3433 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3434 else if (old_pos
> XFASTINT (beg
))
3435 old_pos
= XFASTINT (beg
);
3436 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3438 return make_number (inserted_chars
);
3441 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3443 doc
: /* Base64-decode STRING and return the result. */)
3444 (Lisp_Object string
)
3447 ptrdiff_t length
, decoded_length
;
3448 Lisp_Object decoded_string
;
3451 CHECK_STRING (string
);
3453 length
= SBYTES (string
);
3454 /* We need to allocate enough room for decoding the text. */
3455 decoded
= SAFE_ALLOCA (length
);
3457 /* The decoded result should be unibyte. */
3458 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3460 if (decoded_length
> length
)
3462 else if (decoded_length
>= 0)
3463 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3465 decoded_string
= Qnil
;
3468 if (!STRINGP (decoded_string
))
3469 error ("Invalid base64 data");
3471 return decoded_string
;
3474 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3475 MULTIBYTE, the decoded result should be in multibyte
3476 form. If NCHARS_RETURN is not NULL, store the number of produced
3477 characters in *NCHARS_RETURN. */
3480 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3481 bool multibyte
, ptrdiff_t *nchars_return
)
3483 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3486 unsigned long value
;
3487 ptrdiff_t nchars
= 0;
3491 /* Process first byte of a quadruplet. */
3493 READ_QUADRUPLET_BYTE (e
-to
);
3497 value
= base64_char_to_value
[c
] << 18;
3499 /* Process second byte of a quadruplet. */
3501 READ_QUADRUPLET_BYTE (-1);
3505 value
|= base64_char_to_value
[c
] << 12;
3507 c
= (unsigned char) (value
>> 16);
3508 if (multibyte
&& c
>= 128)
3509 e
+= BYTE8_STRING (c
, e
);
3514 /* Process third byte of a quadruplet. */
3516 READ_QUADRUPLET_BYTE (-1);
3520 READ_QUADRUPLET_BYTE (-1);
3529 value
|= base64_char_to_value
[c
] << 6;
3531 c
= (unsigned char) (0xff & value
>> 8);
3532 if (multibyte
&& c
>= 128)
3533 e
+= BYTE8_STRING (c
, e
);
3538 /* Process fourth byte of a quadruplet. */
3540 READ_QUADRUPLET_BYTE (-1);
3547 value
|= base64_char_to_value
[c
];
3549 c
= (unsigned char) (0xff & value
);
3550 if (multibyte
&& c
>= 128)
3551 e
+= BYTE8_STRING (c
, e
);
3560 /***********************************************************************
3562 ***** Hash Tables *****
3564 ***********************************************************************/
3566 /* Implemented by gerd@gnu.org. This hash table implementation was
3567 inspired by CMUCL hash tables. */
3571 1. For small tables, association lists are probably faster than
3572 hash tables because they have lower overhead.
3574 For uses of hash tables where the O(1) behavior of table
3575 operations is not a requirement, it might therefore be a good idea
3576 not to hash. Instead, we could just do a linear search in the
3577 key_and_value vector of the hash table. This could be done
3578 if a `:linear-search t' argument is given to make-hash-table. */
3581 /* The list of all weak hash tables. Don't staticpro this one. */
3583 static struct Lisp_Hash_Table
*weak_hash_tables
;
3586 /***********************************************************************
3588 ***********************************************************************/
3591 CHECK_HASH_TABLE (Lisp_Object x
)
3593 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3597 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3599 h
->key_and_value
= key_and_value
;
3602 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3607 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3609 gc_aset (h
->next
, idx
, val
);
3612 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3617 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3619 gc_aset (h
->hash
, idx
, val
);
3622 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3627 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3629 gc_aset (h
->index
, idx
, val
);
3632 /* If OBJ is a Lisp hash table, return a pointer to its struct
3633 Lisp_Hash_Table. Otherwise, signal an error. */
3635 static struct Lisp_Hash_Table
*
3636 check_hash_table (Lisp_Object obj
)
3638 CHECK_HASH_TABLE (obj
);
3639 return XHASH_TABLE (obj
);
3643 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3644 number. A number is "almost" a prime number if it is not divisible
3645 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3648 next_almost_prime (EMACS_INT n
)
3650 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3651 for (n
|= 1; ; n
+= 2)
3652 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3657 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3658 which USED[I] is non-zero. If found at index I in ARGS, set
3659 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3660 0. This function is used to extract a keyword/argument pair from
3661 a DEFUN parameter list. */
3664 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3668 for (i
= 1; i
< nargs
; i
++)
3669 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3680 /* Return a Lisp vector which has the same contents as VEC but has
3681 at least INCR_MIN more entries, where INCR_MIN is positive.
3682 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3683 than NITEMS_MAX. Entries in the resulting
3684 vector that are not copied from VEC are set to nil. */
3687 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3689 struct Lisp_Vector
*v
;
3690 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3691 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3692 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3693 ? nitems_max
: C_language_max
);
3694 eassert (VECTORP (vec
));
3695 eassert (0 < incr_min
&& -1 <= nitems_max
);
3696 old_size
= ASIZE (vec
);
3697 incr_max
= n_max
- old_size
;
3698 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3699 if (incr_max
< incr
)
3700 memory_full (SIZE_MAX
);
3701 new_size
= old_size
+ incr
;
3702 v
= allocate_vector (new_size
);
3703 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3704 for (i
= old_size
; i
< new_size
; ++i
)
3705 v
->contents
[i
] = Qnil
;
3706 XSETVECTOR (vec
, v
);
3711 /***********************************************************************
3713 ***********************************************************************/
3715 static struct hash_table_test hashtest_eq
;
3716 struct hash_table_test hashtest_eql
, hashtest_equal
;
3718 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3719 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3720 KEY2 are the same. */
3723 cmpfn_eql (struct hash_table_test
*ht
,
3727 return (FLOATP (key1
)
3729 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3733 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3734 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3735 KEY2 are the same. */
3738 cmpfn_equal (struct hash_table_test
*ht
,
3742 return !NILP (Fequal (key1
, key2
));
3746 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3747 HASH2 in hash table H using H->user_cmp_function. Value is true
3748 if KEY1 and KEY2 are the same. */
3751 cmpfn_user_defined (struct hash_table_test
*ht
,
3755 Lisp_Object args
[3];
3757 args
[0] = ht
->user_cmp_function
;
3760 return !NILP (Ffuncall (3, args
));
3764 /* Value is a hash code for KEY for use in hash table H which uses
3765 `eq' to compare keys. The hash code returned is guaranteed to fit
3766 in a Lisp integer. */
3769 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3771 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3775 /* Value is a hash code for KEY for use in hash table H which uses
3776 `eql' to compare keys. The hash code returned is guaranteed to fit
3777 in a Lisp integer. */
3780 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3784 hash
= sxhash (key
, 0);
3786 hash
= XHASH (key
) ^ XTYPE (key
);
3790 /* Value is a hash code for KEY for use in hash table H which uses
3791 `equal' to compare keys. The hash code returned is guaranteed to fit
3792 in a Lisp integer. */
3795 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3797 EMACS_UINT hash
= sxhash (key
, 0);
3801 /* Value is a hash code for KEY for use in hash table H which uses as
3802 user-defined function to compare keys. The hash code returned is
3803 guaranteed to fit in a Lisp integer. */
3806 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3808 Lisp_Object args
[2], hash
;
3810 args
[0] = ht
->user_hash_function
;
3812 hash
= Ffuncall (2, args
);
3813 return hashfn_eq (ht
, hash
);
3816 /* An upper bound on the size of a hash table index. It must fit in
3817 ptrdiff_t and be a valid Emacs fixnum. */
3818 #define INDEX_SIZE_BOUND \
3819 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3821 /* Create and initialize a new hash table.
3823 TEST specifies the test the hash table will use to compare keys.
3824 It must be either one of the predefined tests `eq', `eql' or
3825 `equal' or a symbol denoting a user-defined test named TEST with
3826 test and hash functions USER_TEST and USER_HASH.
3828 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3830 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3831 new size when it becomes full is computed by adding REHASH_SIZE to
3832 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3833 table's new size is computed by multiplying its old size with
3836 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3837 be resized when the ratio of (number of entries in the table) /
3838 (table size) is >= REHASH_THRESHOLD.
3840 WEAK specifies the weakness of the table. If non-nil, it must be
3841 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3844 make_hash_table (struct hash_table_test test
,
3845 Lisp_Object size
, Lisp_Object rehash_size
,
3846 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3848 struct Lisp_Hash_Table
*h
;
3850 EMACS_INT index_size
, sz
;
3854 /* Preconditions. */
3855 eassert (SYMBOLP (test
.name
));
3856 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3857 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3858 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3859 eassert (FLOATP (rehash_threshold
)
3860 && 0 < XFLOAT_DATA (rehash_threshold
)
3861 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3863 if (XFASTINT (size
) == 0)
3864 size
= make_number (1);
3866 sz
= XFASTINT (size
);
3867 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3868 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3869 ? next_almost_prime (index_float
)
3870 : INDEX_SIZE_BOUND
+ 1);
3871 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3872 error ("Hash table too large");
3874 /* Allocate a table and initialize it. */
3875 h
= allocate_hash_table ();
3877 /* Initialize hash table slots. */
3880 h
->rehash_threshold
= rehash_threshold
;
3881 h
->rehash_size
= rehash_size
;
3883 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3884 h
->hash
= Fmake_vector (size
, Qnil
);
3885 h
->next
= Fmake_vector (size
, Qnil
);
3886 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3888 /* Set up the free list. */
3889 for (i
= 0; i
< sz
- 1; ++i
)
3890 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3891 h
->next_free
= make_number (0);
3893 XSET_HASH_TABLE (table
, h
);
3894 eassert (HASH_TABLE_P (table
));
3895 eassert (XHASH_TABLE (table
) == h
);
3897 /* Maybe add this hash table to the list of all weak hash tables. */
3899 h
->next_weak
= NULL
;
3902 h
->next_weak
= weak_hash_tables
;
3903 weak_hash_tables
= h
;
3910 /* Return a copy of hash table H1. Keys and values are not copied,
3911 only the table itself is. */
3914 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3917 struct Lisp_Hash_Table
*h2
;
3919 h2
= allocate_hash_table ();
3921 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3922 h2
->hash
= Fcopy_sequence (h1
->hash
);
3923 h2
->next
= Fcopy_sequence (h1
->next
);
3924 h2
->index
= Fcopy_sequence (h1
->index
);
3925 XSET_HASH_TABLE (table
, h2
);
3927 /* Maybe add this hash table to the list of all weak hash tables. */
3928 if (!NILP (h2
->weak
))
3930 h2
->next_weak
= weak_hash_tables
;
3931 weak_hash_tables
= h2
;
3938 /* Resize hash table H if it's too full. If H cannot be resized
3939 because it's already too large, throw an error. */
3942 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3944 if (NILP (h
->next_free
))
3946 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3947 EMACS_INT new_size
, index_size
, nsize
;
3951 if (INTEGERP (h
->rehash_size
))
3952 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3955 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3956 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3958 new_size
= float_new_size
;
3959 if (new_size
<= old_size
)
3960 new_size
= old_size
+ 1;
3963 new_size
= INDEX_SIZE_BOUND
+ 1;
3965 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3966 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3967 ? next_almost_prime (index_float
)
3968 : INDEX_SIZE_BOUND
+ 1);
3969 nsize
= max (index_size
, 2 * new_size
);
3970 if (INDEX_SIZE_BOUND
< nsize
)
3971 error ("Hash table too large to resize");
3973 #ifdef ENABLE_CHECKING
3974 if (HASH_TABLE_P (Vpurify_flag
)
3975 && XHASH_TABLE (Vpurify_flag
) == h
)
3976 Fmessage (2, ((Lisp_Object
[])
3977 { build_string ("Growing hash table to: %d"),
3978 make_number (new_size
) }));
3981 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3982 2 * (new_size
- old_size
), -1));
3983 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3984 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3985 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3987 /* Update the free list. Do it so that new entries are added at
3988 the end of the free list. This makes some operations like
3990 for (i
= old_size
; i
< new_size
- 1; ++i
)
3991 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3993 if (!NILP (h
->next_free
))
3995 Lisp_Object last
, next
;
3997 last
= h
->next_free
;
3998 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4002 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
4005 XSETFASTINT (h
->next_free
, old_size
);
4008 for (i
= 0; i
< old_size
; ++i
)
4009 if (!NILP (HASH_HASH (h
, i
)))
4011 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4012 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4013 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4014 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4020 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4021 the hash code of KEY. Value is the index of the entry in H
4022 matching KEY, or -1 if not found. */
4025 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4027 EMACS_UINT hash_code
;
4028 ptrdiff_t start_of_bucket
;
4031 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4032 eassert ((hash_code
& ~INTMASK
) == 0);
4036 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4037 idx
= HASH_INDEX (h
, start_of_bucket
);
4039 /* We need not gcpro idx since it's either an integer or nil. */
4042 ptrdiff_t i
= XFASTINT (idx
);
4043 if (EQ (key
, HASH_KEY (h
, i
))
4045 && hash_code
== XUINT (HASH_HASH (h
, i
))
4046 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4048 idx
= HASH_NEXT (h
, i
);
4051 return NILP (idx
) ? -1 : XFASTINT (idx
);
4055 /* Put an entry into hash table H that associates KEY with VALUE.
4056 HASH is a previously computed hash code of KEY.
4057 Value is the index of the entry in H matching KEY. */
4060 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4063 ptrdiff_t start_of_bucket
, i
;
4065 eassert ((hash
& ~INTMASK
) == 0);
4067 /* Increment count after resizing because resizing may fail. */
4068 maybe_resize_hash_table (h
);
4071 /* Store key/value in the key_and_value vector. */
4072 i
= XFASTINT (h
->next_free
);
4073 h
->next_free
= HASH_NEXT (h
, i
);
4074 set_hash_key_slot (h
, i
, key
);
4075 set_hash_value_slot (h
, i
, value
);
4077 /* Remember its hash code. */
4078 set_hash_hash_slot (h
, i
, make_number (hash
));
4080 /* Add new entry to its collision chain. */
4081 start_of_bucket
= hash
% ASIZE (h
->index
);
4082 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4083 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4088 /* Remove the entry matching KEY from hash table H, if there is one. */
4091 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4093 EMACS_UINT hash_code
;
4094 ptrdiff_t start_of_bucket
;
4095 Lisp_Object idx
, prev
;
4097 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4098 eassert ((hash_code
& ~INTMASK
) == 0);
4099 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4100 idx
= HASH_INDEX (h
, start_of_bucket
);
4103 /* We need not gcpro idx, prev since they're either integers or nil. */
4106 ptrdiff_t i
= XFASTINT (idx
);
4108 if (EQ (key
, HASH_KEY (h
, i
))
4110 && hash_code
== XUINT (HASH_HASH (h
, i
))
4111 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4113 /* Take entry out of collision chain. */
4115 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4117 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4119 /* Clear slots in key_and_value and add the slots to
4121 set_hash_key_slot (h
, i
, Qnil
);
4122 set_hash_value_slot (h
, i
, Qnil
);
4123 set_hash_hash_slot (h
, i
, Qnil
);
4124 set_hash_next_slot (h
, i
, h
->next_free
);
4125 h
->next_free
= make_number (i
);
4127 eassert (h
->count
>= 0);
4133 idx
= HASH_NEXT (h
, i
);
4139 /* Clear hash table H. */
4142 hash_clear (struct Lisp_Hash_Table
*h
)
4146 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4148 for (i
= 0; i
< size
; ++i
)
4150 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4151 set_hash_key_slot (h
, i
, Qnil
);
4152 set_hash_value_slot (h
, i
, Qnil
);
4153 set_hash_hash_slot (h
, i
, Qnil
);
4156 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4157 ASET (h
->index
, i
, Qnil
);
4159 h
->next_free
= make_number (0);
4166 /************************************************************************
4168 ************************************************************************/
4170 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4171 entries from the table that don't survive the current GC.
4172 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4173 true if anything was marked. */
4176 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4178 ptrdiff_t bucket
, n
;
4181 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4184 for (bucket
= 0; bucket
< n
; ++bucket
)
4186 Lisp_Object idx
, next
, prev
;
4188 /* Follow collision chain, removing entries that
4189 don't survive this garbage collection. */
4191 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4193 ptrdiff_t i
= XFASTINT (idx
);
4194 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4195 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4198 if (EQ (h
->weak
, Qkey
))
4199 remove_p
= !key_known_to_survive_p
;
4200 else if (EQ (h
->weak
, Qvalue
))
4201 remove_p
= !value_known_to_survive_p
;
4202 else if (EQ (h
->weak
, Qkey_or_value
))
4203 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4204 else if (EQ (h
->weak
, Qkey_and_value
))
4205 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4209 next
= HASH_NEXT (h
, i
);
4211 if (remove_entries_p
)
4215 /* Take out of collision chain. */
4217 set_hash_index_slot (h
, bucket
, next
);
4219 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4221 /* Add to free list. */
4222 set_hash_next_slot (h
, i
, h
->next_free
);
4225 /* Clear key, value, and hash. */
4226 set_hash_key_slot (h
, i
, Qnil
);
4227 set_hash_value_slot (h
, i
, Qnil
);
4228 set_hash_hash_slot (h
, i
, Qnil
);
4241 /* Make sure key and value survive. */
4242 if (!key_known_to_survive_p
)
4244 mark_object (HASH_KEY (h
, i
));
4248 if (!value_known_to_survive_p
)
4250 mark_object (HASH_VALUE (h
, i
));
4261 /* Remove elements from weak hash tables that don't survive the
4262 current garbage collection. Remove weak tables that don't survive
4263 from Vweak_hash_tables. Called from gc_sweep. */
4265 NO_INLINE
/* For better stack traces */
4267 sweep_weak_hash_tables (void)
4269 struct Lisp_Hash_Table
*h
, *used
, *next
;
4272 /* Mark all keys and values that are in use. Keep on marking until
4273 there is no more change. This is necessary for cases like
4274 value-weak table A containing an entry X -> Y, where Y is used in a
4275 key-weak table B, Z -> Y. If B comes after A in the list of weak
4276 tables, X -> Y might be removed from A, although when looking at B
4277 one finds that it shouldn't. */
4281 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4283 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4284 marked
|= sweep_weak_table (h
, 0);
4289 /* Remove tables and entries that aren't used. */
4290 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4292 next
= h
->next_weak
;
4294 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4296 /* TABLE is marked as used. Sweep its contents. */
4298 sweep_weak_table (h
, 1);
4300 /* Add table to the list of used weak hash tables. */
4301 h
->next_weak
= used
;
4306 weak_hash_tables
= used
;
4311 /***********************************************************************
4312 Hash Code Computation
4313 ***********************************************************************/
4315 /* Maximum depth up to which to dive into Lisp structures. */
4317 #define SXHASH_MAX_DEPTH 3
4319 /* Maximum length up to which to take list and vector elements into
4322 #define SXHASH_MAX_LEN 7
4324 /* Return a hash for string PTR which has length LEN. The hash value
4325 can be any EMACS_UINT value. */
4328 hash_string (char const *ptr
, ptrdiff_t len
)
4330 char const *p
= ptr
;
4331 char const *end
= p
+ len
;
4333 EMACS_UINT hash
= 0;
4338 hash
= sxhash_combine (hash
, c
);
4344 /* Return a hash for string PTR which has length LEN. The hash
4345 code returned is guaranteed to fit in a Lisp integer. */
4348 sxhash_string (char const *ptr
, ptrdiff_t len
)
4350 EMACS_UINT hash
= hash_string (ptr
, len
);
4351 return SXHASH_REDUCE (hash
);
4354 /* Return a hash for the floating point value VAL. */
4357 sxhash_float (double val
)
4359 EMACS_UINT hash
= 0;
4361 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4362 + (sizeof val
% sizeof hash
!= 0))
4366 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4370 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4371 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4372 hash
= sxhash_combine (hash
, u
.word
[i
]);
4373 return SXHASH_REDUCE (hash
);
4376 /* Return a hash for list LIST. DEPTH is the current depth in the
4377 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4380 sxhash_list (Lisp_Object list
, int depth
)
4382 EMACS_UINT hash
= 0;
4385 if (depth
< SXHASH_MAX_DEPTH
)
4387 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4388 list
= XCDR (list
), ++i
)
4390 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4391 hash
= sxhash_combine (hash
, hash2
);
4396 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4397 hash
= sxhash_combine (hash
, hash2
);
4400 return SXHASH_REDUCE (hash
);
4404 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4405 the Lisp structure. */
4408 sxhash_vector (Lisp_Object vec
, int depth
)
4410 EMACS_UINT hash
= ASIZE (vec
);
4413 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4414 for (i
= 0; i
< n
; ++i
)
4416 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4417 hash
= sxhash_combine (hash
, hash2
);
4420 return SXHASH_REDUCE (hash
);
4423 /* Return a hash for bool-vector VECTOR. */
4426 sxhash_bool_vector (Lisp_Object vec
)
4428 EMACS_INT size
= bool_vector_size (vec
);
4429 EMACS_UINT hash
= size
;
4432 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4433 for (i
= 0; i
< n
; ++i
)
4434 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4436 return SXHASH_REDUCE (hash
);
4440 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4441 structure. Value is an unsigned integer clipped to INTMASK. */
4444 sxhash (Lisp_Object obj
, int depth
)
4448 if (depth
> SXHASH_MAX_DEPTH
)
4451 switch (XTYPE (obj
))
4463 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4466 /* This can be everything from a vector to an overlay. */
4467 case Lisp_Vectorlike
:
4469 /* According to the CL HyperSpec, two arrays are equal only if
4470 they are `eq', except for strings and bit-vectors. In
4471 Emacs, this works differently. We have to compare element
4473 hash
= sxhash_vector (obj
, depth
);
4474 else if (BOOL_VECTOR_P (obj
))
4475 hash
= sxhash_bool_vector (obj
);
4477 /* Others are `equal' if they are `eq', so let's take their
4483 hash
= sxhash_list (obj
, depth
);
4487 hash
= sxhash_float (XFLOAT_DATA (obj
));
4499 /***********************************************************************
4501 ***********************************************************************/
4504 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4505 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4508 EMACS_UINT hash
= sxhash (obj
, 0);
4509 return make_number (hash
);
4513 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4514 doc
: /* Create and return a new hash table.
4516 Arguments are specified as keyword/argument pairs. The following
4517 arguments are defined:
4519 :test TEST -- TEST must be a symbol that specifies how to compare
4520 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4521 `equal'. User-supplied test and hash functions can be specified via
4522 `define-hash-table-test'.
4524 :size SIZE -- A hint as to how many elements will be put in the table.
4527 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4528 fills up. If REHASH-SIZE is an integer, increase the size by that
4529 amount. If it is a float, it must be > 1.0, and the new size is the
4530 old size multiplied by that factor. Default is 1.5.
4532 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4533 Resize the hash table when the ratio (number of entries / table size)
4534 is greater than or equal to THRESHOLD. Default is 0.8.
4536 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4537 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4538 returned is a weak table. Key/value pairs are removed from a weak
4539 hash table when there are no non-weak references pointing to their
4540 key, value, one of key or value, or both key and value, depending on
4541 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4544 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4545 (ptrdiff_t nargs
, Lisp_Object
*args
)
4547 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4548 struct hash_table_test testdesc
;
4552 /* The vector `used' is used to keep track of arguments that
4553 have been consumed. */
4554 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4555 memset (used
, 0, nargs
* sizeof *used
);
4557 /* See if there's a `:test TEST' among the arguments. */
4558 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4559 test
= i
? args
[i
] : Qeql
;
4561 testdesc
= hashtest_eq
;
4562 else if (EQ (test
, Qeql
))
4563 testdesc
= hashtest_eql
;
4564 else if (EQ (test
, Qequal
))
4565 testdesc
= hashtest_equal
;
4568 /* See if it is a user-defined test. */
4571 prop
= Fget (test
, Qhash_table_test
);
4572 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4573 signal_error ("Invalid hash table test", test
);
4574 testdesc
.name
= test
;
4575 testdesc
.user_cmp_function
= XCAR (prop
);
4576 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4577 testdesc
.hashfn
= hashfn_user_defined
;
4578 testdesc
.cmpfn
= cmpfn_user_defined
;
4581 /* See if there's a `:size SIZE' argument. */
4582 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4583 size
= i
? args
[i
] : Qnil
;
4585 size
= make_number (DEFAULT_HASH_SIZE
);
4586 else if (!INTEGERP (size
) || XINT (size
) < 0)
4587 signal_error ("Invalid hash table size", size
);
4589 /* Look for `:rehash-size SIZE'. */
4590 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4591 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4592 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4593 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4594 signal_error ("Invalid hash table rehash size", rehash_size
);
4596 /* Look for `:rehash-threshold THRESHOLD'. */
4597 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4598 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4599 if (! (FLOATP (rehash_threshold
)
4600 && 0 < XFLOAT_DATA (rehash_threshold
)
4601 && XFLOAT_DATA (rehash_threshold
) <= 1))
4602 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4604 /* Look for `:weakness WEAK'. */
4605 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4606 weak
= i
? args
[i
] : Qnil
;
4608 weak
= Qkey_and_value
;
4611 && !EQ (weak
, Qvalue
)
4612 && !EQ (weak
, Qkey_or_value
)
4613 && !EQ (weak
, Qkey_and_value
))
4614 signal_error ("Invalid hash table weakness", weak
);
4616 /* Now, all args should have been used up, or there's a problem. */
4617 for (i
= 0; i
< nargs
; ++i
)
4619 signal_error ("Invalid argument list", args
[i
]);
4622 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4626 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4627 doc
: /* Return a copy of hash table TABLE. */)
4630 return copy_hash_table (check_hash_table (table
));
4634 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4635 doc
: /* Return the number of elements in TABLE. */)
4638 return make_number (check_hash_table (table
)->count
);
4642 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4643 Shash_table_rehash_size
, 1, 1, 0,
4644 doc
: /* Return the current rehash size of TABLE. */)
4647 return check_hash_table (table
)->rehash_size
;
4651 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4652 Shash_table_rehash_threshold
, 1, 1, 0,
4653 doc
: /* Return the current rehash threshold of TABLE. */)
4656 return check_hash_table (table
)->rehash_threshold
;
4660 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4661 doc
: /* Return the size of TABLE.
4662 The size can be used as an argument to `make-hash-table' to create
4663 a hash table than can hold as many elements as TABLE holds
4664 without need for resizing. */)
4667 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4668 return make_number (HASH_TABLE_SIZE (h
));
4672 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4673 doc
: /* Return the test TABLE uses. */)
4676 return check_hash_table (table
)->test
.name
;
4680 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4682 doc
: /* Return the weakness of TABLE. */)
4685 return check_hash_table (table
)->weak
;
4689 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4690 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4693 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4697 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4698 doc
: /* Clear hash table TABLE and return it. */)
4701 hash_clear (check_hash_table (table
));
4702 /* Be compatible with XEmacs. */
4707 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4708 doc
: /* Look up KEY in TABLE and return its associated value.
4709 If KEY is not found, return DFLT which defaults to nil. */)
4710 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4712 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4713 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4714 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4718 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4719 doc
: /* Associate KEY with VALUE in hash table TABLE.
4720 If KEY is already present in table, replace its current value with
4721 VALUE. In any case, return VALUE. */)
4722 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4724 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4728 i
= hash_lookup (h
, key
, &hash
);
4730 set_hash_value_slot (h
, i
, value
);
4732 hash_put (h
, key
, value
, hash
);
4738 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4739 doc
: /* Remove KEY from TABLE. */)
4740 (Lisp_Object key
, Lisp_Object table
)
4742 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4743 hash_remove_from_table (h
, key
);
4748 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4749 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4750 FUNCTION is called with two arguments, KEY and VALUE.
4751 `maphash' always returns nil. */)
4752 (Lisp_Object function
, Lisp_Object table
)
4754 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4755 Lisp_Object args
[3];
4758 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4759 if (!NILP (HASH_HASH (h
, i
)))
4762 args
[1] = HASH_KEY (h
, i
);
4763 args
[2] = HASH_VALUE (h
, i
);
4771 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4772 Sdefine_hash_table_test
, 3, 3, 0,
4773 doc
: /* Define a new hash table test with name NAME, a symbol.
4775 In hash tables created with NAME specified as test, use TEST to
4776 compare keys, and HASH for computing hash codes of keys.
4778 TEST must be a function taking two arguments and returning non-nil if
4779 both arguments are the same. HASH must be a function taking one
4780 argument and returning an object that is the hash code of the argument.
4781 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4782 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4783 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4785 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4790 /************************************************************************
4791 MD5, SHA-1, and SHA-2
4792 ************************************************************************/
4799 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4802 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4803 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4807 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4808 register EMACS_INT b
, e
;
4809 register struct buffer
*bp
;
4812 void *(*hash_func
) (const char *, size_t, void *);
4815 CHECK_SYMBOL (algorithm
);
4817 if (STRINGP (object
))
4819 if (NILP (coding_system
))
4821 /* Decide the coding-system to encode the data with. */
4823 if (STRING_MULTIBYTE (object
))
4824 /* use default, we can't guess correct value */
4825 coding_system
= preferred_coding_system ();
4827 coding_system
= Qraw_text
;
4830 if (NILP (Fcoding_system_p (coding_system
)))
4832 /* Invalid coding system. */
4834 if (!NILP (noerror
))
4835 coding_system
= Qraw_text
;
4837 xsignal1 (Qcoding_system_error
, coding_system
);
4840 if (STRING_MULTIBYTE (object
))
4841 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4843 size
= SCHARS (object
);
4844 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4846 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4847 end_byte
= (end_char
== size
4849 : string_char_to_byte (object
, end_char
));
4853 struct buffer
*prev
= current_buffer
;
4855 record_unwind_current_buffer ();
4857 CHECK_BUFFER (object
);
4859 bp
= XBUFFER (object
);
4860 set_buffer_internal (bp
);
4866 CHECK_NUMBER_COERCE_MARKER (start
);
4874 CHECK_NUMBER_COERCE_MARKER (end
);
4879 temp
= b
, b
= e
, e
= temp
;
4881 if (!(BEGV
<= b
&& e
<= ZV
))
4882 args_out_of_range (start
, end
);
4884 if (NILP (coding_system
))
4886 /* Decide the coding-system to encode the data with.
4887 See fileio.c:Fwrite-region */
4889 if (!NILP (Vcoding_system_for_write
))
4890 coding_system
= Vcoding_system_for_write
;
4893 bool force_raw_text
= 0;
4895 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4896 if (NILP (coding_system
)
4897 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4899 coding_system
= Qnil
;
4900 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4904 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4906 /* Check file-coding-system-alist. */
4907 Lisp_Object args
[4], val
;
4909 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4910 args
[3] = Fbuffer_file_name (object
);
4911 val
= Ffind_operation_coding_system (4, args
);
4912 if (CONSP (val
) && !NILP (XCDR (val
)))
4913 coding_system
= XCDR (val
);
4916 if (NILP (coding_system
)
4917 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4919 /* If we still have not decided a coding system, use the
4920 default value of buffer-file-coding-system. */
4921 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4925 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4926 /* Confirm that VAL can surely encode the current region. */
4927 coding_system
= call4 (Vselect_safe_coding_system_function
,
4928 make_number (b
), make_number (e
),
4929 coding_system
, Qnil
);
4932 coding_system
= Qraw_text
;
4935 if (NILP (Fcoding_system_p (coding_system
)))
4937 /* Invalid coding system. */
4939 if (!NILP (noerror
))
4940 coding_system
= Qraw_text
;
4942 xsignal1 (Qcoding_system_error
, coding_system
);
4946 object
= make_buffer_string (b
, e
, 0);
4947 set_buffer_internal (prev
);
4948 /* Discard the unwind protect for recovering the current
4952 if (STRING_MULTIBYTE (object
))
4953 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4955 end_byte
= SBYTES (object
);
4958 if (EQ (algorithm
, Qmd5
))
4960 digest_size
= MD5_DIGEST_SIZE
;
4961 hash_func
= md5_buffer
;
4963 else if (EQ (algorithm
, Qsha1
))
4965 digest_size
= SHA1_DIGEST_SIZE
;
4966 hash_func
= sha1_buffer
;
4968 else if (EQ (algorithm
, Qsha224
))
4970 digest_size
= SHA224_DIGEST_SIZE
;
4971 hash_func
= sha224_buffer
;
4973 else if (EQ (algorithm
, Qsha256
))
4975 digest_size
= SHA256_DIGEST_SIZE
;
4976 hash_func
= sha256_buffer
;
4978 else if (EQ (algorithm
, Qsha384
))
4980 digest_size
= SHA384_DIGEST_SIZE
;
4981 hash_func
= sha384_buffer
;
4983 else if (EQ (algorithm
, Qsha512
))
4985 digest_size
= SHA512_DIGEST_SIZE
;
4986 hash_func
= sha512_buffer
;
4989 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4991 /* allocate 2 x digest_size so that it can be re-used to hold the
4993 digest
= make_uninit_string (digest_size
* 2);
4995 hash_func (SSDATA (object
) + start_byte
,
4996 end_byte
- start_byte
,
5001 unsigned char *p
= SDATA (digest
);
5002 for (i
= digest_size
- 1; i
>= 0; i
--)
5004 static char const hexdigit
[16] = "0123456789abcdef";
5006 p
[2 * i
] = hexdigit
[p_i
>> 4];
5007 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5012 return make_unibyte_string (SSDATA (digest
), digest_size
);
5015 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5016 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5018 A message digest is a cryptographic checksum of a document, and the
5019 algorithm to calculate it is defined in RFC 1321.
5021 The two optional arguments START and END are character positions
5022 specifying for which part of OBJECT the message digest should be
5023 computed. If nil or omitted, the digest is computed for the whole
5026 The MD5 message digest is computed from the result of encoding the
5027 text in a coding system, not directly from the internal Emacs form of
5028 the text. The optional fourth argument CODING-SYSTEM specifies which
5029 coding system to encode the text with. It should be the same coding
5030 system that you used or will use when actually writing the text into a
5033 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5034 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5035 system would be chosen by default for writing this text into a file.
5037 If OBJECT is a string, the most preferred coding system (see the
5038 command `prefer-coding-system') is used.
5040 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5041 guesswork fails. Normally, an error is signaled in such case. */)
5042 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5044 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5047 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5048 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5049 ALGORITHM is a symbol specifying the hash to use:
5050 md5, sha1, sha224, sha256, sha384 or sha512.
5052 The two optional arguments START and END are positions specifying for
5053 which part of OBJECT to compute the hash. If nil or omitted, uses the
5056 If BINARY is non-nil, returns a string in binary form. */)
5057 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5059 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5065 DEFSYM (Qmd5
, "md5");
5066 DEFSYM (Qsha1
, "sha1");
5067 DEFSYM (Qsha224
, "sha224");
5068 DEFSYM (Qsha256
, "sha256");
5069 DEFSYM (Qsha384
, "sha384");
5070 DEFSYM (Qsha512
, "sha512");
5072 /* Hash table stuff. */
5073 DEFSYM (Qhash_table_p
, "hash-table-p");
5075 DEFSYM (Qeql
, "eql");
5076 DEFSYM (Qequal
, "equal");
5077 DEFSYM (QCtest
, ":test");
5078 DEFSYM (QCsize
, ":size");
5079 DEFSYM (QCrehash_size
, ":rehash-size");
5080 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5081 DEFSYM (QCweakness
, ":weakness");
5082 DEFSYM (Qkey
, "key");
5083 DEFSYM (Qvalue
, "value");
5084 DEFSYM (Qhash_table_test
, "hash-table-test");
5085 DEFSYM (Qkey_or_value
, "key-or-value");
5086 DEFSYM (Qkey_and_value
, "key-and-value");
5089 defsubr (&Smake_hash_table
);
5090 defsubr (&Scopy_hash_table
);
5091 defsubr (&Shash_table_count
);
5092 defsubr (&Shash_table_rehash_size
);
5093 defsubr (&Shash_table_rehash_threshold
);
5094 defsubr (&Shash_table_size
);
5095 defsubr (&Shash_table_test
);
5096 defsubr (&Shash_table_weakness
);
5097 defsubr (&Shash_table_p
);
5098 defsubr (&Sclrhash
);
5099 defsubr (&Sgethash
);
5100 defsubr (&Sputhash
);
5101 defsubr (&Sremhash
);
5102 defsubr (&Smaphash
);
5103 defsubr (&Sdefine_hash_table_test
);
5105 DEFSYM (Qstring_lessp
, "string-lessp");
5106 DEFSYM (Qstring_collate_lessp
, "string-collate-lessp");
5107 DEFSYM (Qstring_collate_equalp
, "string-collate-equalp");
5108 DEFSYM (Qprovide
, "provide");
5109 DEFSYM (Qrequire
, "require");
5110 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5111 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5112 DEFSYM (Qwidget_type
, "widget-type");
5114 staticpro (&string_char_byte_cache_string
);
5115 string_char_byte_cache_string
= Qnil
;
5117 require_nesting_list
= Qnil
;
5118 staticpro (&require_nesting_list
);
5120 Fset (Qyes_or_no_p_history
, Qnil
);
5122 DEFVAR_LISP ("features", Vfeatures
,
5123 doc
: /* A list of symbols which are the features of the executing Emacs.
5124 Used by `featurep' and `require', and altered by `provide'. */);
5125 Vfeatures
= list1 (intern_c_string ("emacs"));
5126 DEFSYM (Qsubfeatures
, "subfeatures");
5127 DEFSYM (Qfuncall
, "funcall");
5129 #ifdef HAVE_LANGINFO_CODESET
5130 DEFSYM (Qcodeset
, "codeset");
5131 DEFSYM (Qdays
, "days");
5132 DEFSYM (Qmonths
, "months");
5133 DEFSYM (Qpaper
, "paper");
5134 #endif /* HAVE_LANGINFO_CODESET */
5136 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5137 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5138 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5139 invoked by mouse clicks and mouse menu items.
5141 On some platforms, file selection dialogs are also enabled if this is
5145 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5146 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5147 This applies to commands from menus and tool bar buttons even when
5148 they are initiated from the keyboard. If `use-dialog-box' is nil,
5149 that disables the use of a file dialog, regardless of the value of
5151 use_file_dialog
= 1;
5153 defsubr (&Sidentity
);
5156 defsubr (&Ssafe_length
);
5157 defsubr (&Sstring_bytes
);
5158 defsubr (&Sstring_equal
);
5159 defsubr (&Scompare_strings
);
5160 defsubr (&Sstring_lessp
);
5161 defsubr (&Sstring_collate_lessp
);
5162 defsubr (&Sstring_collate_equalp
);
5165 defsubr (&Svconcat
);
5166 defsubr (&Scopy_sequence
);
5167 defsubr (&Sstring_make_multibyte
);
5168 defsubr (&Sstring_make_unibyte
);
5169 defsubr (&Sstring_as_multibyte
);
5170 defsubr (&Sstring_as_unibyte
);
5171 defsubr (&Sstring_to_multibyte
);
5172 defsubr (&Sstring_to_unibyte
);
5173 defsubr (&Scopy_alist
);
5174 defsubr (&Ssubstring
);
5175 defsubr (&Ssubstring_no_properties
);
5188 defsubr (&Snreverse
);
5189 defsubr (&Sreverse
);
5191 defsubr (&Splist_get
);
5193 defsubr (&Splist_put
);
5195 defsubr (&Slax_plist_get
);
5196 defsubr (&Slax_plist_put
);
5199 defsubr (&Sequal_including_properties
);
5200 defsubr (&Sfillarray
);
5201 defsubr (&Sclear_string
);
5205 defsubr (&Smapconcat
);
5206 defsubr (&Syes_or_no_p
);
5207 defsubr (&Sload_average
);
5208 defsubr (&Sfeaturep
);
5209 defsubr (&Srequire
);
5210 defsubr (&Sprovide
);
5211 defsubr (&Splist_member
);
5212 defsubr (&Swidget_put
);
5213 defsubr (&Swidget_get
);
5214 defsubr (&Swidget_apply
);
5215 defsubr (&Sbase64_encode_region
);
5216 defsubr (&Sbase64_decode_region
);
5217 defsubr (&Sbase64_encode_string
);
5218 defsubr (&Sbase64_decode_string
);
5220 defsubr (&Ssecure_hash
);
5221 defsubr (&Slocale_info
);
5223 hashtest_eq
.name
= Qeq
;
5224 hashtest_eq
.user_hash_function
= Qnil
;
5225 hashtest_eq
.user_cmp_function
= Qnil
;
5226 hashtest_eq
.cmpfn
= 0;
5227 hashtest_eq
.hashfn
= hashfn_eq
;
5229 hashtest_eql
.name
= Qeql
;
5230 hashtest_eql
.user_hash_function
= Qnil
;
5231 hashtest_eql
.user_cmp_function
= Qnil
;
5232 hashtest_eql
.cmpfn
= cmpfn_eql
;
5233 hashtest_eql
.hashfn
= hashfn_eql
;
5235 hashtest_equal
.name
= Qequal
;
5236 hashtest_equal
.user_hash_function
= Qnil
;
5237 hashtest_equal
.user_cmp_function
= Qnil
;
5238 hashtest_equal
.cmpfn
= cmpfn_equal
;
5239 hashtest_equal
.hashfn
= hashfn_equal
;