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/>. */
28 #include "character.h"
30 #include "composite.h"
32 #include "intervals.h"
35 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
36 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
37 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
39 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
40 doc
: /* Return the argument unchanged. */
47 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
48 doc
: /* Return a pseudo-random number.
49 All integers representable in Lisp, i.e. between `most-negative-fixnum'
50 and `most-positive-fixnum', inclusive, are equally likely.
52 With positive integer LIMIT, return random number in interval [0,LIMIT).
53 With argument t, set the random number seed from the current time and pid.
54 With a string argument, set the seed based on the string's contents.
55 Other values of LIMIT are ignored.
57 See Info node `(elisp)Random Numbers' for more details. */)
64 else if (STRINGP (limit
))
65 seed_random (SSDATA (limit
), SBYTES (limit
));
68 if (INTEGERP (limit
) && 0 < XINT (limit
))
71 /* Return the remainder, except reject the rare case where
72 get_random returns a number so close to INTMASK that the
73 remainder isn't random. */
74 EMACS_INT remainder
= val
% XINT (limit
);
75 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
76 return make_number (remainder
);
79 return make_number (val
);
82 /* Heuristic on how many iterations of a tight loop can be safely done
83 before it's time to do a QUIT. This must be a power of 2. */
84 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
86 /* Random data-structure functions. */
89 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
91 CHECK_TYPE (NILP (x
), Qlistp
, y
);
94 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
95 doc
: /* Return the length of vector, list or string SEQUENCE.
96 A byte-code function object is also allowed.
97 If the string contains multibyte characters, this is not necessarily
98 the number of bytes in the string; it is the number of characters.
99 To get the number of bytes, use `string-bytes'. */)
100 (register Lisp_Object sequence
)
102 register Lisp_Object val
;
104 if (STRINGP (sequence
))
105 XSETFASTINT (val
, SCHARS (sequence
));
106 else if (VECTORP (sequence
))
107 XSETFASTINT (val
, ASIZE (sequence
));
108 else if (CHAR_TABLE_P (sequence
))
109 XSETFASTINT (val
, MAX_CHAR
);
110 else if (BOOL_VECTOR_P (sequence
))
111 XSETFASTINT (val
, bool_vector_size (sequence
));
112 else if (COMPILEDP (sequence
))
113 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
114 else if (CONSP (sequence
))
121 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
123 if (MOST_POSITIVE_FIXNUM
< i
)
124 error ("List too long");
127 sequence
= XCDR (sequence
);
129 while (CONSP (sequence
));
131 CHECK_LIST_END (sequence
, sequence
);
133 val
= make_number (i
);
135 else if (NILP (sequence
))
136 XSETFASTINT (val
, 0);
138 wrong_type_argument (Qsequencep
, sequence
);
143 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
144 doc
: /* Return the length of a list, but avoid error or infinite loop.
145 This function never gets an error. If LIST is not really a list,
146 it returns 0. If LIST is circular, it returns a finite value
147 which is at least the number of distinct elements. */)
150 Lisp_Object tail
, halftail
;
155 return make_number (0);
157 /* halftail is used to detect circular lists. */
158 for (tail
= halftail
= list
; ; )
163 if (EQ (tail
, halftail
))
166 if ((lolen
& 1) == 0)
168 halftail
= XCDR (halftail
);
169 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
173 hilen
+= UINTMAX_MAX
+ 1.0;
178 /* If the length does not fit into a fixnum, return a float.
179 On all known practical machines this returns an upper bound on
181 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
184 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
185 doc
: /* Return the number of bytes in STRING.
186 If STRING is multibyte, this may be greater than the length of STRING. */)
189 CHECK_STRING (string
);
190 return make_number (SBYTES (string
));
193 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
194 doc
: /* Return t if two strings have identical contents.
195 Case is significant, but text properties are ignored.
196 Symbols are also allowed; their print names are used instead. */)
197 (register Lisp_Object s1
, Lisp_Object s2
)
200 s1
= SYMBOL_NAME (s1
);
202 s2
= SYMBOL_NAME (s2
);
206 if (SCHARS (s1
) != SCHARS (s2
)
207 || SBYTES (s1
) != SBYTES (s2
)
208 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
213 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
214 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
215 The arguments START1, END1, START2, and END2, if non-nil, are
216 positions specifying which parts of STR1 or STR2 to compare. In
217 string STR1, compare the part between START1 (inclusive) and END1
218 (exclusive). If START1 is nil, it defaults to 0, the beginning of
219 the string; if END1 is nil, it defaults to the length of the string.
220 Likewise, in string STR2, compare the part between START2 and END2.
221 Like in `substring', negative values are counted from the end.
223 The strings are compared by the numeric values of their characters.
224 For instance, STR1 is "less than" STR2 if its first differing
225 character has a smaller numeric value. If IGNORE-CASE is non-nil,
226 characters are converted to lower-case before comparing them. Unibyte
227 strings are converted to multibyte for comparison.
229 The value is t if the strings (or specified portions) match.
230 If string STR1 is less, the value is a negative number N;
231 - 1 - N is the number of characters that match at the beginning.
232 If string STR1 is greater, the value is a positive number N;
233 N - 1 is the number of characters that match at the beginning. */)
234 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
235 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
237 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
242 /* For backward compatibility, silently bring too-large positive end
243 values into range. */
244 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
245 end1
= make_number (SCHARS (str1
));
246 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
247 end2
= make_number (SCHARS (str2
));
249 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
250 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
255 i1_byte
= string_char_to_byte (str1
, i1
);
256 i2_byte
= string_char_to_byte (str2
, i2
);
258 while (i1
< to1
&& i2
< to2
)
260 /* When we find a mismatch, we must compare the
261 characters, not just the bytes. */
264 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
265 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
270 if (! NILP (ignore_case
))
272 c1
= XINT (Fupcase (make_number (c1
)));
273 c2
= XINT (Fupcase (make_number (c2
)));
279 /* Note that I1 has already been incremented
280 past the character that we are comparing;
281 hence we don't add or subtract 1 here. */
283 return make_number (- i1
+ from1
);
285 return make_number (i1
- from1
);
289 return make_number (i1
- from1
+ 1);
291 return make_number (- i1
+ from1
- 1);
296 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
297 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
299 Symbols are also allowed; their print names are used instead. */)
300 (register Lisp_Object string1
, Lisp_Object string2
)
302 register ptrdiff_t end
;
303 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
305 if (SYMBOLP (string1
))
306 string1
= SYMBOL_NAME (string1
);
307 if (SYMBOLP (string2
))
308 string2
= SYMBOL_NAME (string2
);
309 CHECK_STRING (string1
);
310 CHECK_STRING (string2
);
312 i1
= i1_byte
= i2
= i2_byte
= 0;
314 end
= SCHARS (string1
);
315 if (end
> SCHARS (string2
))
316 end
= SCHARS (string2
);
320 /* When we find a mismatch, we must compare the
321 characters, not just the bytes. */
324 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
325 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
328 return c1
< c2
? Qt
: Qnil
;
330 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
333 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
334 doc
: /* Return t if first arg string is less than second in collation order.
335 Symbols are also allowed; their print names are used instead.
337 This function obeys the conventions for collation order in your
338 locale settings. For example, punctuation and whitespace characters
339 might be considered less significant for sorting:
341 (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
342 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
344 The optional argument LOCALE, a string, overrides the setting of your
345 current locale identifier for collation. The value is system
346 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
347 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
349 If IGNORE-CASE is non-nil, characters are converted to lower-case
350 before comparing them.
352 To emulate Unicode-compliant collation on MS-Windows systems,
353 bind `w32-collate-ignore-punctuation' to a non-nil value, since
354 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
356 If your system does not support a locale environment, this function
357 behaves like `string-lessp'. */)
358 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
360 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
361 /* Check parameters. */
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 CHECK_STRING (locale
);
371 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
373 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
374 return Fstring_lessp (s1
, s2
);
375 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
378 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
379 doc
: /* Return t if two strings have identical contents.
380 Symbols are also allowed; their print names are used instead.
382 This function obeys the conventions for collation order in your locale
383 settings. For example, characters with different coding points but
384 the same meaning might be considered as equal, like different grave
385 accent Unicode characters:
387 (string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
390 The optional argument LOCALE, a string, overrides the setting of your
391 current locale identifier for collation. The value is system
392 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
393 while it would be \"enu_USA.1252\" on MS Windows systems.
395 If IGNORE-CASE is non-nil, characters are converted to lower-case
396 before comparing them.
398 To emulate Unicode-compliant collation on MS-Windows systems,
399 bind `w32-collate-ignore-punctuation' to a non-nil value, since
400 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
402 If your system does not support a locale environment, this function
403 behaves like `string-equal'.
405 Do NOT use this function to compare file names for equality, only
406 for sorting them. */)
407 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
409 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
410 /* Check parameters. */
412 s1
= SYMBOL_NAME (s1
);
414 s2
= SYMBOL_NAME (s2
);
418 CHECK_STRING (locale
);
420 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
422 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
423 return Fstring_equal (s1
, s2
);
424 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
427 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
428 enum Lisp_Type target_type
, bool last_special
);
432 concat2 (Lisp_Object s1
, Lisp_Object s2
)
434 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
439 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
441 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
444 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
445 doc
: /* Concatenate all the arguments and make the result a list.
446 The result is a list whose elements are the elements of all the arguments.
447 Each argument may be a list, vector or string.
448 The last argument is not copied, just used as the tail of the new list.
449 usage: (append &rest SEQUENCES) */)
450 (ptrdiff_t nargs
, Lisp_Object
*args
)
452 return concat (nargs
, args
, Lisp_Cons
, 1);
455 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
456 doc
: /* Concatenate all the arguments and make the result a string.
457 The result is a string whose elements are the elements of all the arguments.
458 Each argument may be a string or a list or vector of characters (integers).
459 usage: (concat &rest SEQUENCES) */)
460 (ptrdiff_t nargs
, Lisp_Object
*args
)
462 return concat (nargs
, args
, Lisp_String
, 0);
465 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
466 doc
: /* Concatenate all the arguments and make the result a vector.
467 The result is a vector whose elements are the elements of all the arguments.
468 Each argument may be a list, vector or string.
469 usage: (vconcat &rest SEQUENCES) */)
470 (ptrdiff_t nargs
, Lisp_Object
*args
)
472 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
476 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
477 doc
: /* Return a copy of a list, vector, string or char-table.
478 The elements of a list or vector are not copied; they are shared
479 with the original. */)
482 if (NILP (arg
)) return arg
;
484 if (CHAR_TABLE_P (arg
))
486 return copy_char_table (arg
);
489 if (BOOL_VECTOR_P (arg
))
491 EMACS_INT nbits
= bool_vector_size (arg
);
492 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
493 Lisp_Object val
= make_uninit_bool_vector (nbits
);
494 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
498 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
499 wrong_type_argument (Qsequencep
, arg
);
501 return concat (1, &arg
, XTYPE (arg
), 0);
504 /* This structure holds information of an argument of `concat' that is
505 a string and has text properties to be copied. */
508 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
509 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
510 ptrdiff_t to
; /* refer to VAL (the target string) */
514 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
515 enum Lisp_Type target_type
, bool last_special
)
521 ptrdiff_t toindex_byte
= 0;
522 EMACS_INT result_len
;
523 EMACS_INT result_len_byte
;
525 Lisp_Object last_tail
;
528 /* When we make a multibyte string, we can't copy text properties
529 while concatenating each string because the length of resulting
530 string can't be decided until we finish the whole concatenation.
531 So, we record strings that have text properties to be copied
532 here, and copy the text properties after the concatenation. */
533 struct textprop_rec
*textprops
= NULL
;
534 /* Number of elements in textprops. */
535 ptrdiff_t num_textprops
= 0;
540 /* In append, the last arg isn't treated like the others */
541 if (last_special
&& nargs
> 0)
544 last_tail
= args
[nargs
];
549 /* Check each argument. */
550 for (argnum
= 0; argnum
< nargs
; argnum
++)
553 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
554 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
555 wrong_type_argument (Qsequencep
, this);
558 /* Compute total length in chars of arguments in RESULT_LEN.
559 If desired output is a string, also compute length in bytes
560 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
561 whether the result should be a multibyte string. */
565 for (argnum
= 0; argnum
< nargs
; argnum
++)
569 len
= XFASTINT (Flength (this));
570 if (target_type
== Lisp_String
)
572 /* We must count the number of bytes needed in the string
573 as well as the number of characters. */
577 ptrdiff_t this_len_byte
;
579 if (VECTORP (this) || COMPILEDP (this))
580 for (i
= 0; i
< len
; i
++)
583 CHECK_CHARACTER (ch
);
585 this_len_byte
= CHAR_BYTES (c
);
586 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
588 result_len_byte
+= this_len_byte
;
589 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
592 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
593 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
594 else if (CONSP (this))
595 for (; CONSP (this); this = XCDR (this))
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 (STRINGP (this))
609 if (STRING_MULTIBYTE (this))
612 this_len_byte
= SBYTES (this);
615 this_len_byte
= count_size_as_multibyte (SDATA (this),
617 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
619 result_len_byte
+= this_len_byte
;
624 if (MOST_POSITIVE_FIXNUM
< result_len
)
625 memory_full (SIZE_MAX
);
628 if (! some_multibyte
)
629 result_len_byte
= result_len
;
631 /* Create the output object. */
632 if (target_type
== Lisp_Cons
)
633 val
= Fmake_list (make_number (result_len
), Qnil
);
634 else if (target_type
== Lisp_Vectorlike
)
635 val
= Fmake_vector (make_number (result_len
), Qnil
);
636 else if (some_multibyte
)
637 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
639 val
= make_uninit_string (result_len
);
641 /* In `append', if all but last arg are nil, return last arg. */
642 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
645 /* Copy the contents of the args into the result. */
647 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
649 toindex
= 0, toindex_byte
= 0;
653 SAFE_NALLOCA (textprops
, 1, nargs
);
655 for (argnum
= 0; argnum
< nargs
; argnum
++)
658 ptrdiff_t thisleni
= 0;
659 register ptrdiff_t thisindex
= 0;
660 register ptrdiff_t thisindex_byte
= 0;
664 thislen
= Flength (this), thisleni
= XINT (thislen
);
666 /* Between strings of the same kind, copy fast. */
667 if (STRINGP (this) && STRINGP (val
)
668 && STRING_MULTIBYTE (this) == some_multibyte
)
670 ptrdiff_t thislen_byte
= SBYTES (this);
672 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
673 if (string_intervals (this))
675 textprops
[num_textprops
].argnum
= argnum
;
676 textprops
[num_textprops
].from
= 0;
677 textprops
[num_textprops
++].to
= toindex
;
679 toindex_byte
+= thislen_byte
;
682 /* Copy a single-byte string to a multibyte string. */
683 else if (STRINGP (this) && STRINGP (val
))
685 if (string_intervals (this))
687 textprops
[num_textprops
].argnum
= argnum
;
688 textprops
[num_textprops
].from
= 0;
689 textprops
[num_textprops
++].to
= toindex
;
691 toindex_byte
+= copy_text (SDATA (this),
692 SDATA (val
) + toindex_byte
,
693 SCHARS (this), 0, 1);
697 /* Copy element by element. */
700 register Lisp_Object elt
;
702 /* Fetch next element of `this' arg into `elt', or break if
703 `this' is exhausted. */
704 if (NILP (this)) break;
706 elt
= XCAR (this), this = XCDR (this);
707 else if (thisindex
>= thisleni
)
709 else if (STRINGP (this))
712 if (STRING_MULTIBYTE (this))
713 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
718 c
= SREF (this, thisindex
); thisindex
++;
719 if (some_multibyte
&& !ASCII_CHAR_P (c
))
720 c
= BYTE8_TO_CHAR (c
);
722 XSETFASTINT (elt
, c
);
724 else if (BOOL_VECTOR_P (this))
726 elt
= bool_vector_ref (this, thisindex
);
731 elt
= AREF (this, thisindex
);
735 /* Store this element into the result. */
742 else if (VECTORP (val
))
744 ASET (val
, toindex
, elt
);
750 CHECK_CHARACTER (elt
);
753 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
755 SSET (val
, toindex_byte
++, c
);
761 XSETCDR (prev
, last_tail
);
763 if (num_textprops
> 0)
766 ptrdiff_t last_to_end
= -1;
768 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
770 this = args
[textprops
[argnum
].argnum
];
771 props
= text_property_list (this,
773 make_number (SCHARS (this)),
775 /* If successive arguments have properties, be sure that the
776 value of `composition' property be the copy. */
777 if (last_to_end
== textprops
[argnum
].to
)
778 make_composition_value_copy (props
);
779 add_text_properties_from_list (val
, props
,
780 make_number (textprops
[argnum
].to
));
781 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
789 static Lisp_Object string_char_byte_cache_string
;
790 static ptrdiff_t string_char_byte_cache_charpos
;
791 static ptrdiff_t string_char_byte_cache_bytepos
;
794 clear_string_char_byte_cache (void)
796 string_char_byte_cache_string
= Qnil
;
799 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
802 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
805 ptrdiff_t best_below
, best_below_byte
;
806 ptrdiff_t best_above
, best_above_byte
;
808 best_below
= best_below_byte
= 0;
809 best_above
= SCHARS (string
);
810 best_above_byte
= SBYTES (string
);
811 if (best_above
== best_above_byte
)
814 if (EQ (string
, string_char_byte_cache_string
))
816 if (string_char_byte_cache_charpos
< char_index
)
818 best_below
= string_char_byte_cache_charpos
;
819 best_below_byte
= string_char_byte_cache_bytepos
;
823 best_above
= string_char_byte_cache_charpos
;
824 best_above_byte
= string_char_byte_cache_bytepos
;
828 if (char_index
- best_below
< best_above
- char_index
)
830 unsigned char *p
= SDATA (string
) + best_below_byte
;
832 while (best_below
< char_index
)
834 p
+= BYTES_BY_CHAR_HEAD (*p
);
837 i_byte
= p
- SDATA (string
);
841 unsigned char *p
= SDATA (string
) + best_above_byte
;
843 while (best_above
> char_index
)
846 while (!CHAR_HEAD_P (*p
)) p
--;
849 i_byte
= p
- SDATA (string
);
852 string_char_byte_cache_bytepos
= i_byte
;
853 string_char_byte_cache_charpos
= char_index
;
854 string_char_byte_cache_string
= string
;
859 /* Return the character index corresponding to BYTE_INDEX in STRING. */
862 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
865 ptrdiff_t best_below
, best_below_byte
;
866 ptrdiff_t best_above
, best_above_byte
;
868 best_below
= best_below_byte
= 0;
869 best_above
= SCHARS (string
);
870 best_above_byte
= SBYTES (string
);
871 if (best_above
== best_above_byte
)
874 if (EQ (string
, string_char_byte_cache_string
))
876 if (string_char_byte_cache_bytepos
< byte_index
)
878 best_below
= string_char_byte_cache_charpos
;
879 best_below_byte
= string_char_byte_cache_bytepos
;
883 best_above
= string_char_byte_cache_charpos
;
884 best_above_byte
= string_char_byte_cache_bytepos
;
888 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
890 unsigned char *p
= SDATA (string
) + best_below_byte
;
891 unsigned char *pend
= SDATA (string
) + byte_index
;
895 p
+= BYTES_BY_CHAR_HEAD (*p
);
899 i_byte
= p
- SDATA (string
);
903 unsigned char *p
= SDATA (string
) + best_above_byte
;
904 unsigned char *pbeg
= SDATA (string
) + byte_index
;
909 while (!CHAR_HEAD_P (*p
)) p
--;
913 i_byte
= p
- SDATA (string
);
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Convert STRING to a multibyte string. */
926 string_make_multibyte (Lisp_Object string
)
933 if (STRING_MULTIBYTE (string
))
936 nbytes
= count_size_as_multibyte (SDATA (string
),
938 /* If all the chars are ASCII, they won't need any more bytes
939 once converted. In that case, we can return STRING itself. */
940 if (nbytes
== SBYTES (string
))
943 buf
= SAFE_ALLOCA (nbytes
);
944 copy_text (SDATA (string
), buf
, SBYTES (string
),
947 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
954 /* Convert STRING (if unibyte) to a multibyte string without changing
955 the number of characters. Characters 0200 trough 0237 are
956 converted to eight-bit characters. */
959 string_to_multibyte (Lisp_Object string
)
966 if (STRING_MULTIBYTE (string
))
969 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
970 /* If all the chars are ASCII, they won't need any more bytes once
972 if (nbytes
== SBYTES (string
))
973 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
975 buf
= SAFE_ALLOCA (nbytes
);
976 memcpy (buf
, SDATA (string
), SBYTES (string
));
977 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
979 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
986 /* Convert STRING to a single-byte string. */
989 string_make_unibyte (Lisp_Object string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 buf
= SAFE_ALLOCA (nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string ((char *) buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 (When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1022 (Lisp_Object string
)
1024 CHECK_STRING (string
);
1026 return string_make_multibyte (string
);
1029 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1031 doc
: /* Return the unibyte equivalent of STRING.
1032 Multibyte character codes are converted to unibyte according to
1033 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1034 If the lookup in the translation table fails, this function takes just
1035 the low 8 bits of each character. */)
1036 (Lisp_Object string
)
1038 CHECK_STRING (string
);
1040 return string_make_unibyte (string
);
1043 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1045 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1046 If STRING is unibyte, the result is STRING itself.
1047 Otherwise it is a newly created string, with no text properties.
1048 If STRING is multibyte and contains a character of charset
1049 `eight-bit', it is converted to the corresponding single byte. */)
1050 (Lisp_Object string
)
1052 CHECK_STRING (string
);
1054 if (STRING_MULTIBYTE (string
))
1056 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1057 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1059 string
= make_unibyte_string ((char *) str
, bytes
);
1065 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1067 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1068 If STRING is multibyte, the result is STRING itself.
1069 Otherwise it is a newly created string, with no text properties.
1071 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1072 part of a correct utf-8 sequence), it is converted to the corresponding
1073 multibyte character of charset `eight-bit'.
1074 See also `string-to-multibyte'.
1076 Beware, this often doesn't really do what you think it does.
1077 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1078 If you're not sure, whether to use `string-as-multibyte' or
1079 `string-to-multibyte', use `string-to-multibyte'. */)
1080 (Lisp_Object string
)
1082 CHECK_STRING (string
);
1084 if (! STRING_MULTIBYTE (string
))
1086 Lisp_Object new_string
;
1087 ptrdiff_t nchars
, nbytes
;
1089 parse_str_as_multibyte (SDATA (string
),
1092 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1093 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1094 if (nbytes
!= SBYTES (string
))
1095 str_as_multibyte (SDATA (new_string
), nbytes
,
1096 SBYTES (string
), NULL
);
1097 string
= new_string
;
1098 set_string_intervals (string
, NULL
);
1103 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1105 doc
: /* Return a multibyte string with the same individual chars as STRING.
1106 If STRING is multibyte, the result is STRING itself.
1107 Otherwise it is a newly created string, with no text properties.
1109 If STRING is unibyte and contains an 8-bit byte, it is converted to
1110 the corresponding multibyte character of charset `eight-bit'.
1112 This differs from `string-as-multibyte' by converting each byte of a correct
1113 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1114 correct sequence. */)
1115 (Lisp_Object string
)
1117 CHECK_STRING (string
);
1119 return string_to_multibyte (string
);
1122 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1124 doc
: /* Return a unibyte string with the same individual chars as STRING.
1125 If STRING is unibyte, the result is STRING itself.
1126 Otherwise it is a newly created string, with no text properties,
1127 where each `eight-bit' character is converted to the corresponding byte.
1128 If STRING contains a non-ASCII, non-`eight-bit' character,
1129 an error is signaled. */)
1130 (Lisp_Object string
)
1132 CHECK_STRING (string
);
1134 if (STRING_MULTIBYTE (string
))
1136 ptrdiff_t chars
= SCHARS (string
);
1137 unsigned char *str
= xmalloc (chars
);
1138 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1140 if (converted
< chars
)
1141 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1142 string
= make_unibyte_string ((char *) str
, chars
);
1149 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1150 doc
: /* Return a copy of ALIST.
1151 This is an alist which represents the same mapping from objects to objects,
1152 but does not share the alist structure with ALIST.
1153 The objects mapped (cars and cdrs of elements of the alist)
1154 are shared, however.
1155 Elements of ALIST that are not conses are also shared. */)
1158 register Lisp_Object tem
;
1163 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1164 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1166 register Lisp_Object car
;
1170 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1175 /* Check that ARRAY can have a valid subarray [FROM..TO),
1176 given that its size is SIZE.
1177 If FROM is nil, use 0; if TO is nil, use SIZE.
1178 Count negative values backwards from the end.
1179 Set *IFROM and *ITO to the two indexes used. */
1182 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1183 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1187 if (INTEGERP (from
))
1193 else if (NILP (from
))
1196 wrong_type_argument (Qintegerp
, from
);
1207 wrong_type_argument (Qintegerp
, to
);
1209 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1210 args_out_of_range_3 (array
, from
, to
);
1216 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1217 doc
: /* Return a new string whose contents are a substring of STRING.
1218 The returned string consists of the characters between index FROM
1219 (inclusive) and index TO (exclusive) of STRING. FROM and TO are
1220 zero-indexed: 0 means the first character of STRING. Negative values
1221 are counted from the end of STRING. If TO is nil, the substring runs
1222 to the end of STRING.
1224 The STRING argument may also be a vector. In that case, the return
1225 value is a new vector that contains the elements between index FROM
1226 (inclusive) and index TO (exclusive) of that vector argument.
1228 With one argument, just copy STRING (with properties, if any). */)
1229 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1232 ptrdiff_t size
, ifrom
, ito
;
1234 size
= CHECK_VECTOR_OR_STRING (string
);
1235 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1237 if (STRINGP (string
))
1240 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1242 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1243 res
= make_specified_string (SSDATA (string
) + from_byte
,
1244 ito
- ifrom
, to_byte
- from_byte
,
1245 STRING_MULTIBYTE (string
));
1246 copy_text_properties (make_number (ifrom
), make_number (ito
),
1247 string
, make_number (0), res
, Qnil
);
1250 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1256 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1257 doc
: /* Return a substring of STRING, without text properties.
1258 It starts at index FROM and ends before TO.
1259 TO may be nil or omitted; then the substring runs to the end of STRING.
1260 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1261 If FROM or TO is negative, it counts from the end.
1263 With one argument, just copy STRING without its properties. */)
1264 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1266 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1268 CHECK_STRING (string
);
1270 size
= SCHARS (string
);
1271 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1273 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1275 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1276 return make_specified_string (SSDATA (string
) + from_byte
,
1277 to_char
- from_char
, to_byte
- from_byte
,
1278 STRING_MULTIBYTE (string
));
1281 /* Extract a substring of STRING, giving start and end positions
1282 both in characters and in bytes. */
1285 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1286 ptrdiff_t to
, ptrdiff_t to_byte
)
1289 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1291 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1292 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1294 if (STRINGP (string
))
1296 res
= make_specified_string (SSDATA (string
) + from_byte
,
1297 to
- from
, to_byte
- from_byte
,
1298 STRING_MULTIBYTE (string
));
1299 copy_text_properties (make_number (from
), make_number (to
),
1300 string
, make_number (0), res
, Qnil
);
1303 res
= Fvector (to
- from
, aref_addr (string
, from
));
1308 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1309 doc
: /* Take cdr N times on LIST, return the result. */)
1310 (Lisp_Object n
, Lisp_Object list
)
1315 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1318 CHECK_LIST_CONS (list
, list
);
1324 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1325 doc
: /* Return the Nth element of LIST.
1326 N counts from zero. If LIST is not that long, nil is returned. */)
1327 (Lisp_Object n
, Lisp_Object list
)
1329 return Fcar (Fnthcdr (n
, list
));
1332 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1333 doc
: /* Return element of SEQUENCE at index N. */)
1334 (register Lisp_Object sequence
, Lisp_Object n
)
1337 if (CONSP (sequence
) || NILP (sequence
))
1338 return Fcar (Fnthcdr (n
, sequence
));
1340 /* Faref signals a "not array" error, so check here. */
1341 CHECK_ARRAY (sequence
, Qsequencep
);
1342 return Faref (sequence
, n
);
1345 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1346 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1347 The value is actually the tail of LIST whose car is ELT. */)
1348 (register Lisp_Object elt
, Lisp_Object list
)
1350 register Lisp_Object tail
;
1351 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1353 register Lisp_Object tem
;
1354 CHECK_LIST_CONS (tail
, list
);
1356 if (! NILP (Fequal (elt
, tem
)))
1363 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1364 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1365 The value is actually the tail of LIST whose car is ELT. */)
1366 (register Lisp_Object elt
, Lisp_Object list
)
1370 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1374 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1378 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1389 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1390 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1391 The value is actually the tail of LIST whose car is ELT. */)
1392 (register Lisp_Object elt
, Lisp_Object list
)
1394 register Lisp_Object tail
;
1397 return Fmemq (elt
, list
);
1399 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1401 register Lisp_Object tem
;
1402 CHECK_LIST_CONS (tail
, list
);
1404 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1411 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1412 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1413 The value is actually the first element of LIST whose car is KEY.
1414 Elements of LIST that are not conses are ignored. */)
1415 (Lisp_Object key
, Lisp_Object list
)
1420 || (CONSP (XCAR (list
))
1421 && EQ (XCAR (XCAR (list
)), key
)))
1426 || (CONSP (XCAR (list
))
1427 && EQ (XCAR (XCAR (list
)), key
)))
1432 || (CONSP (XCAR (list
))
1433 && EQ (XCAR (XCAR (list
)), key
)))
1443 /* Like Fassq but never report an error and do not allow quits.
1444 Use only on lists known never to be circular. */
1447 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1450 && (!CONSP (XCAR (list
))
1451 || !EQ (XCAR (XCAR (list
)), key
)))
1454 return CAR_SAFE (list
);
1457 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1458 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1459 The value is actually the first element of LIST whose car equals KEY. */)
1460 (Lisp_Object key
, Lisp_Object list
)
1467 || (CONSP (XCAR (list
))
1468 && (car
= XCAR (XCAR (list
)),
1469 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1474 || (CONSP (XCAR (list
))
1475 && (car
= XCAR (XCAR (list
)),
1476 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1481 || (CONSP (XCAR (list
))
1482 && (car
= XCAR (XCAR (list
)),
1483 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1493 /* Like Fassoc but never report an error and do not allow quits.
1494 Use only on lists known never to be circular. */
1497 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1500 && (!CONSP (XCAR (list
))
1501 || (!EQ (XCAR (XCAR (list
)), key
)
1502 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1505 return CONSP (list
) ? XCAR (list
) : Qnil
;
1508 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1509 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1510 The value is actually the first element of LIST whose cdr is KEY. */)
1511 (register Lisp_Object key
, Lisp_Object list
)
1516 || (CONSP (XCAR (list
))
1517 && EQ (XCDR (XCAR (list
)), key
)))
1522 || (CONSP (XCAR (list
))
1523 && EQ (XCDR (XCAR (list
)), key
)))
1528 || (CONSP (XCAR (list
))
1529 && EQ (XCDR (XCAR (list
)), key
)))
1539 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1540 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1541 The value is actually the first element of LIST whose cdr equals KEY. */)
1542 (Lisp_Object key
, Lisp_Object list
)
1549 || (CONSP (XCAR (list
))
1550 && (cdr
= XCDR (XCAR (list
)),
1551 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1556 || (CONSP (XCAR (list
))
1557 && (cdr
= XCDR (XCAR (list
)),
1558 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1563 || (CONSP (XCAR (list
))
1564 && (cdr
= XCDR (XCAR (list
)),
1565 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1575 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1576 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1577 More precisely, this function skips any members `eq' to ELT at the
1578 front of LIST, then removes members `eq' to ELT from the remaining
1579 sublist by modifying its list structure, then returns the resulting
1582 Write `(setq foo (delq element foo))' to be sure of correctly changing
1583 the value of a list `foo'. See also `remq', which does not modify the
1585 (register Lisp_Object elt
, Lisp_Object list
)
1587 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1590 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1592 Lisp_Object tem
= XCAR (tail
);
1598 Fsetcdr (prev
, XCDR (tail
));
1606 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1607 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1608 SEQ must be a sequence (i.e. a list, a vector, or a string).
1609 The return value is a sequence of the same type.
1611 If SEQ is a list, this behaves like `delq', except that it compares
1612 with `equal' instead of `eq'. In particular, it may remove elements
1613 by altering the list structure.
1615 If SEQ is not a list, deletion is never performed destructively;
1616 instead this function creates and returns a new vector or string.
1618 Write `(setq foo (delete element foo))' to be sure of correctly
1619 changing the value of a sequence `foo'. */)
1620 (Lisp_Object elt
, Lisp_Object seq
)
1626 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1627 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1630 if (n
!= ASIZE (seq
))
1632 struct Lisp_Vector
*p
= allocate_vector (n
);
1634 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1635 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1636 p
->contents
[n
++] = AREF (seq
, i
);
1638 XSETVECTOR (seq
, p
);
1641 else if (STRINGP (seq
))
1643 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1646 for (i
= nchars
= nbytes
= ibyte
= 0;
1648 ++i
, ibyte
+= cbytes
)
1650 if (STRING_MULTIBYTE (seq
))
1652 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1653 cbytes
= CHAR_BYTES (c
);
1661 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1668 if (nchars
!= SCHARS (seq
))
1672 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1673 if (!STRING_MULTIBYTE (seq
))
1674 STRING_SET_UNIBYTE (tem
);
1676 for (i
= nchars
= nbytes
= ibyte
= 0;
1678 ++i
, ibyte
+= cbytes
)
1680 if (STRING_MULTIBYTE (seq
))
1682 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1683 cbytes
= CHAR_BYTES (c
);
1691 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1693 unsigned char *from
= SDATA (seq
) + ibyte
;
1694 unsigned char *to
= SDATA (tem
) + nbytes
;
1700 for (n
= cbytes
; n
--; )
1710 Lisp_Object tail
, prev
;
1712 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1714 CHECK_LIST_CONS (tail
, seq
);
1716 if (!NILP (Fequal (elt
, XCAR (tail
))))
1721 Fsetcdr (prev
, XCDR (tail
));
1732 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1733 doc
: /* Reverse order of items in a list, vector or string SEQ.
1734 If SEQ is a list, it should be nil-terminated.
1735 This function may destructively modify SEQ to produce the value. */)
1740 else if (STRINGP (seq
))
1741 return Freverse (seq
);
1742 else if (CONSP (seq
))
1744 Lisp_Object prev
, tail
, next
;
1746 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1749 CHECK_LIST_CONS (tail
, tail
);
1751 Fsetcdr (tail
, prev
);
1756 else if (VECTORP (seq
))
1758 ptrdiff_t i
, size
= ASIZE (seq
);
1760 for (i
= 0; i
< size
/ 2; i
++)
1762 Lisp_Object tem
= AREF (seq
, i
);
1763 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1764 ASET (seq
, size
- i
- 1, tem
);
1767 else if (BOOL_VECTOR_P (seq
))
1769 ptrdiff_t i
, size
= bool_vector_size (seq
);
1771 for (i
= 0; i
< size
/ 2; i
++)
1773 bool tem
= bool_vector_bitref (seq
, i
);
1774 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1775 bool_vector_set (seq
, size
- i
- 1, tem
);
1779 wrong_type_argument (Qarrayp
, seq
);
1783 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1784 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1785 See also the function `nreverse', which is used more often. */)
1792 else if (CONSP (seq
))
1794 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1797 new = Fcons (XCAR (seq
), new);
1799 CHECK_LIST_END (seq
, seq
);
1801 else if (VECTORP (seq
))
1803 ptrdiff_t i
, size
= ASIZE (seq
);
1805 new = make_uninit_vector (size
);
1806 for (i
= 0; i
< size
; i
++)
1807 ASET (new, i
, AREF (seq
, size
- i
- 1));
1809 else if (BOOL_VECTOR_P (seq
))
1812 EMACS_INT nbits
= bool_vector_size (seq
);
1814 new = make_uninit_bool_vector (nbits
);
1815 for (i
= 0; i
< nbits
; i
++)
1816 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1818 else if (STRINGP (seq
))
1820 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1826 new = make_uninit_string (size
);
1827 for (i
= 0; i
< size
; i
++)
1828 SSET (new, i
, SREF (seq
, size
- i
- 1));
1832 unsigned char *p
, *q
;
1834 new = make_uninit_multibyte_string (size
, bytes
);
1835 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1836 while (q
> SDATA (new))
1840 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1842 CHAR_STRING (ch
, q
);
1847 wrong_type_argument (Qsequencep
, seq
);
1851 /* Sort LIST using PREDICATE, preserving original order of elements
1852 considered as equal. */
1855 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1857 Lisp_Object front
, back
;
1858 Lisp_Object len
, tem
;
1862 len
= Flength (list
);
1863 length
= XINT (len
);
1867 XSETINT (len
, (length
/ 2) - 1);
1868 tem
= Fnthcdr (len
, list
);
1870 Fsetcdr (tem
, Qnil
);
1872 front
= Fsort (front
, predicate
);
1873 back
= Fsort (back
, predicate
);
1874 return merge (front
, back
, predicate
);
1877 /* Using PRED to compare, return whether A and B are in order.
1878 Compare stably when A appeared before B in the input. */
1880 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1882 return NILP (call2 (pred
, b
, a
));
1885 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1886 into DEST. Argument arrays must be nonempty and must not overlap,
1887 except that B might be the last part of DEST. */
1889 merge_vectors (Lisp_Object pred
,
1890 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1891 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1892 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1894 eassume (0 < alen
&& 0 < blen
);
1895 Lisp_Object
const *alim
= a
+ alen
;
1896 Lisp_Object
const *blim
= b
+ blen
;
1900 if (inorder (pred
, a
[0], b
[0]))
1906 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1915 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1922 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1923 temporary storage. LEN must be at least 2. */
1925 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1926 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1927 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1930 ptrdiff_t halflen
= len
>> 1;
1931 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1932 if (1 < len
- halflen
)
1933 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1934 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1937 /* Using PRED to compare, sort from LEN-length SRC into DST.
1938 Len must be positive. */
1940 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1941 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1942 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1945 ptrdiff_t halflen
= len
>> 1;
1951 sort_vector_inplace (pred
, halflen
, src
, dest
);
1952 if (1 < len
- halflen
)
1953 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1954 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1958 /* Sort VECTOR in place using PREDICATE, preserving original order of
1959 elements considered as equal. */
1962 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1964 ptrdiff_t len
= ASIZE (vector
);
1967 ptrdiff_t halflen
= len
>> 1;
1970 SAFE_ALLOCA_LISP (tmp
, halflen
);
1971 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1972 tmp
[i
] = make_number (0);
1973 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1977 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1978 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1979 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1980 modified by side effects. PREDICATE is called with two elements of
1981 SEQ, and should return non-nil if the first element should sort before
1983 (Lisp_Object seq
, Lisp_Object predicate
)
1986 seq
= sort_list (seq
, predicate
);
1987 else if (VECTORP (seq
))
1988 sort_vector (seq
, predicate
);
1989 else if (!NILP (seq
))
1990 wrong_type_argument (Qsequencep
, seq
);
1995 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1997 Lisp_Object l1
= org_l1
;
1998 Lisp_Object l2
= org_l2
;
1999 Lisp_Object tail
= Qnil
;
2000 Lisp_Object value
= Qnil
;
2020 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2035 Fsetcdr (tail
, tem
);
2041 /* This does not check for quits. That is safe since it must terminate. */
2043 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2044 doc
: /* Extract a value from a property list.
2045 PLIST is a property list, which is a list of the form
2046 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2047 corresponding to the given PROP, or nil if PROP is not one of the
2048 properties on the list. This function never signals an error. */)
2049 (Lisp_Object plist
, Lisp_Object prop
)
2051 Lisp_Object tail
, halftail
;
2053 /* halftail is used to detect circular lists. */
2054 tail
= halftail
= plist
;
2055 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2057 if (EQ (prop
, XCAR (tail
)))
2058 return XCAR (XCDR (tail
));
2060 tail
= XCDR (XCDR (tail
));
2061 halftail
= XCDR (halftail
);
2062 if (EQ (tail
, halftail
))
2069 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2070 doc
: /* Return the value of SYMBOL's PROPNAME property.
2071 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2072 (Lisp_Object symbol
, Lisp_Object propname
)
2074 CHECK_SYMBOL (symbol
);
2075 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2078 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2079 doc
: /* Change value in PLIST of PROP to VAL.
2080 PLIST is a property list, which is a list of the form
2081 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2082 If PROP is already a property on the list, its value is set to VAL,
2083 otherwise the new PROP VAL pair is added. The new plist is returned;
2084 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2085 The PLIST is modified by side effects. */)
2086 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2088 register Lisp_Object tail
, prev
;
2089 Lisp_Object newcell
;
2091 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2092 tail
= XCDR (XCDR (tail
)))
2094 if (EQ (prop
, XCAR (tail
)))
2096 Fsetcar (XCDR (tail
), val
);
2103 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2107 Fsetcdr (XCDR (prev
), newcell
);
2111 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2112 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2113 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2114 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2116 CHECK_SYMBOL (symbol
);
2118 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2122 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2123 doc
: /* Extract a value from a property list, comparing with `equal'.
2124 PLIST is a property list, which is a list of the form
2125 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2126 corresponding to the given PROP, or nil if PROP is not
2127 one of the properties on the list. */)
2128 (Lisp_Object plist
, Lisp_Object prop
)
2133 CONSP (tail
) && CONSP (XCDR (tail
));
2134 tail
= XCDR (XCDR (tail
)))
2136 if (! NILP (Fequal (prop
, XCAR (tail
))))
2137 return XCAR (XCDR (tail
));
2142 CHECK_LIST_END (tail
, prop
);
2147 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2148 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2149 PLIST is a property list, which is a list of the form
2150 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2151 If PROP is already a property on the list, its value is set to VAL,
2152 otherwise the new PROP VAL pair is added. The new plist is returned;
2153 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2154 The PLIST is modified by side effects. */)
2155 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2157 register Lisp_Object tail
, prev
;
2158 Lisp_Object newcell
;
2160 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2161 tail
= XCDR (XCDR (tail
)))
2163 if (! NILP (Fequal (prop
, XCAR (tail
))))
2165 Fsetcar (XCDR (tail
), val
);
2172 newcell
= list2 (prop
, val
);
2176 Fsetcdr (XCDR (prev
), newcell
);
2180 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2181 doc
: /* Return t if the two args are the same Lisp object.
2182 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2183 (Lisp_Object obj1
, Lisp_Object obj2
)
2186 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2188 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2191 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2192 doc
: /* Return t if two Lisp objects have similar structure and contents.
2193 They must have the same data type.
2194 Conses are compared by comparing the cars and the cdrs.
2195 Vectors and strings are compared element by element.
2196 Numbers are compared by value, but integers cannot equal floats.
2197 (Use `=' if you want integers and floats to be able to be equal.)
2198 Symbols must match exactly. */)
2199 (register Lisp_Object o1
, Lisp_Object o2
)
2201 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2204 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2205 doc
: /* Return t if two Lisp objects have similar structure and contents.
2206 This is like `equal' except that it compares the text properties
2207 of strings. (`equal' ignores text properties.) */)
2208 (register Lisp_Object o1
, Lisp_Object o2
)
2210 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2213 /* DEPTH is current depth of recursion. Signal an error if it
2215 PROPS means compare string text properties too. */
2218 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2224 error ("Stack overflow in equal");
2226 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2229 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2231 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2233 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2235 { /* `o1' was seen already. */
2236 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2237 if (!NILP (Fmemq (o2
, o2s
)))
2240 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2243 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2253 if (XTYPE (o1
) != XTYPE (o2
))
2262 d1
= extract_float (o1
);
2263 d2
= extract_float (o2
);
2264 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2265 though they are not =. */
2266 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2270 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2274 /* FIXME: This inf-loops in a circular list! */
2278 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2282 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2283 depth
+ 1, props
, ht
)
2284 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2285 depth
+ 1, props
, ht
))
2287 o1
= XOVERLAY (o1
)->plist
;
2288 o2
= XOVERLAY (o2
)->plist
;
2293 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2294 && (XMARKER (o1
)->buffer
== 0
2295 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2299 case Lisp_Vectorlike
:
2302 ptrdiff_t size
= ASIZE (o1
);
2303 /* Pseudovectors have the type encoded in the size field, so this test
2304 actually checks that the objects have the same type as well as the
2306 if (ASIZE (o2
) != size
)
2308 /* Boolvectors are compared much like strings. */
2309 if (BOOL_VECTOR_P (o1
))
2311 EMACS_INT size
= bool_vector_size (o1
);
2312 if (size
!= bool_vector_size (o2
))
2314 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2315 bool_vector_bytes (size
)))
2319 if (WINDOW_CONFIGURATIONP (o1
))
2320 return compare_window_configurations (o1
, o2
, 0);
2322 /* Aside from them, only true vectors, char-tables, compiled
2323 functions, and fonts (font-spec, font-entity, font-object)
2324 are sensible to compare, so eliminate the others now. */
2325 if (size
& PSEUDOVECTOR_FLAG
)
2327 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2330 size
&= PSEUDOVECTOR_SIZE_MASK
;
2332 for (i
= 0; i
< size
; i
++)
2337 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2345 if (SCHARS (o1
) != SCHARS (o2
))
2347 if (SBYTES (o1
) != SBYTES (o2
))
2349 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2351 if (props
&& !compare_string_intervals (o1
, o2
))
2363 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2364 doc
: /* Store each element of ARRAY with ITEM.
2365 ARRAY is a vector, string, char-table, or bool-vector. */)
2366 (Lisp_Object array
, Lisp_Object item
)
2368 register ptrdiff_t size
, idx
;
2370 if (VECTORP (array
))
2371 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2372 ASET (array
, idx
, item
);
2373 else if (CHAR_TABLE_P (array
))
2377 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2378 set_char_table_contents (array
, i
, item
);
2379 set_char_table_defalt (array
, item
);
2381 else if (STRINGP (array
))
2383 register unsigned char *p
= SDATA (array
);
2385 CHECK_CHARACTER (item
);
2386 charval
= XFASTINT (item
);
2387 size
= SCHARS (array
);
2388 if (STRING_MULTIBYTE (array
))
2390 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2391 int len
= CHAR_STRING (charval
, str
);
2392 ptrdiff_t size_byte
= SBYTES (array
);
2395 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2396 error ("Attempt to change byte length of a string");
2397 for (idx
= 0; idx
< size_byte
; idx
++)
2398 *p
++ = str
[idx
% len
];
2401 for (idx
= 0; idx
< size
; idx
++)
2404 else if (BOOL_VECTOR_P (array
))
2405 return bool_vector_fill (array
, item
);
2407 wrong_type_argument (Qarrayp
, array
);
2411 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2413 doc
: /* Clear the contents of STRING.
2414 This makes STRING unibyte and may change its length. */)
2415 (Lisp_Object string
)
2418 CHECK_STRING (string
);
2419 len
= SBYTES (string
);
2420 memset (SDATA (string
), 0, len
);
2421 STRING_SET_CHARS (string
, len
);
2422 STRING_SET_UNIBYTE (string
);
2428 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2430 return CALLN (Fnconc
, s1
, s2
);
2433 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2434 doc
: /* Concatenate any number of lists by altering them.
2435 Only the last argument is not altered, and need not be a list.
2436 usage: (nconc &rest LISTS) */)
2437 (ptrdiff_t nargs
, Lisp_Object
*args
)
2440 register Lisp_Object tail
, tem
, val
;
2444 for (argnum
= 0; argnum
< nargs
; argnum
++)
2447 if (NILP (tem
)) continue;
2452 if (argnum
+ 1 == nargs
) break;
2454 CHECK_LIST_CONS (tem
, tem
);
2463 tem
= args
[argnum
+ 1];
2464 Fsetcdr (tail
, tem
);
2466 args
[argnum
+ 1] = tail
;
2472 /* This is the guts of all mapping functions.
2473 Apply FN to each element of SEQ, one by one,
2474 storing the results into elements of VALS, a C vector of Lisp_Objects.
2475 LENI is the length of VALS, which should also be the length of SEQ. */
2478 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2480 Lisp_Object tail
, dummy
;
2483 if (VECTORP (seq
) || COMPILEDP (seq
))
2485 for (i
= 0; i
< leni
; i
++)
2487 dummy
= call1 (fn
, AREF (seq
, i
));
2492 else if (BOOL_VECTOR_P (seq
))
2494 for (i
= 0; i
< leni
; i
++)
2496 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2501 else if (STRINGP (seq
))
2505 for (i
= 0, i_byte
= 0; i
< leni
;)
2508 ptrdiff_t i_before
= i
;
2510 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2511 XSETFASTINT (dummy
, c
);
2512 dummy
= call1 (fn
, dummy
);
2514 vals
[i_before
] = dummy
;
2517 else /* Must be a list, since Flength did not get an error */
2520 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2522 dummy
= call1 (fn
, XCAR (tail
));
2530 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2531 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2532 In between each pair of results, stick in SEPARATOR. Thus, " " as
2533 SEPARATOR results in spaces between the values returned by FUNCTION.
2534 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2535 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2545 len
= Flength (sequence
);
2546 if (CHAR_TABLE_P (sequence
))
2547 wrong_type_argument (Qlistp
, sequence
);
2549 nargs
= leni
+ leni
- 1;
2550 if (nargs
< 0) return empty_unibyte_string
;
2552 SAFE_ALLOCA_LISP (args
, nargs
);
2554 mapcar1 (leni
, args
, function
, sequence
);
2556 for (i
= leni
- 1; i
> 0; i
--)
2557 args
[i
+ i
] = args
[i
];
2559 for (i
= 1; i
< nargs
; i
+= 2)
2560 args
[i
] = separator
;
2562 ret
= Fconcat (nargs
, args
);
2568 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2569 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2570 The result is a list just as long as SEQUENCE.
2571 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2572 (Lisp_Object function
, Lisp_Object sequence
)
2574 register Lisp_Object len
;
2575 register EMACS_INT leni
;
2576 register Lisp_Object
*args
;
2580 len
= Flength (sequence
);
2581 if (CHAR_TABLE_P (sequence
))
2582 wrong_type_argument (Qlistp
, sequence
);
2583 leni
= XFASTINT (len
);
2585 SAFE_ALLOCA_LISP (args
, leni
);
2587 mapcar1 (leni
, args
, function
, sequence
);
2589 ret
= Flist (leni
, args
);
2595 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2596 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2597 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2598 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2599 (Lisp_Object function
, Lisp_Object sequence
)
2601 register EMACS_INT leni
;
2603 leni
= XFASTINT (Flength (sequence
));
2604 if (CHAR_TABLE_P (sequence
))
2605 wrong_type_argument (Qlistp
, sequence
);
2606 mapcar1 (leni
, 0, function
, sequence
);
2611 /* This is how C code calls `yes-or-no-p' and allows the user
2615 do_yes_or_no_p (Lisp_Object prompt
)
2617 return call1 (intern ("yes-or-no-p"), prompt
);
2620 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2621 doc
: /* Ask user a yes-or-no question.
2622 Return t if answer is yes, and nil if the answer is no.
2623 PROMPT is the string to display to ask the question. It should end in
2624 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2626 The user must confirm the answer with RET, and can edit it until it
2629 If dialog boxes are supported, a dialog box will be used
2630 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2631 (Lisp_Object prompt
)
2635 CHECK_STRING (prompt
);
2637 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2638 && use_dialog_box
&& ! NILP (last_input_event
))
2640 Lisp_Object pane
, menu
, obj
;
2641 redisplay_preserve_echo_area (4);
2642 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2643 Fcons (build_string ("No"), Qnil
));
2644 menu
= Fcons (prompt
, pane
);
2645 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2649 AUTO_STRING (yes_or_no
, "(yes or no) ");
2650 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2654 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2655 Qyes_or_no_p_history
, Qnil
,
2657 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2659 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2664 message1 ("Please answer yes or no.");
2665 Fsleep_for (make_number (2), Qnil
);
2669 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2670 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2672 Each of the three load averages is multiplied by 100, then converted
2675 When USE-FLOATS is non-nil, floats will be used instead of integers.
2676 These floats are not multiplied by 100.
2678 If the 5-minute or 15-minute load averages are not available, return a
2679 shortened list, containing only those averages which are available.
2681 An error is thrown if the load average can't be obtained. In some
2682 cases making it work would require Emacs being installed setuid or
2683 setgid so that it can read kernel information, and that usually isn't
2685 (Lisp_Object use_floats
)
2688 int loads
= getloadavg (load_ave
, 3);
2689 Lisp_Object ret
= Qnil
;
2692 error ("load-average not implemented for this operating system");
2696 Lisp_Object load
= (NILP (use_floats
)
2697 ? make_number (100.0 * load_ave
[loads
])
2698 : make_float (load_ave
[loads
]));
2699 ret
= Fcons (load
, ret
);
2705 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2706 doc
: /* Return t if FEATURE is present in this Emacs.
2708 Use this to conditionalize execution of lisp code based on the
2709 presence or absence of Emacs or environment extensions.
2710 Use `provide' to declare that a feature is available. This function
2711 looks at the value of the variable `features'. The optional argument
2712 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2713 (Lisp_Object feature
, Lisp_Object subfeature
)
2715 register Lisp_Object tem
;
2716 CHECK_SYMBOL (feature
);
2717 tem
= Fmemq (feature
, Vfeatures
);
2718 if (!NILP (tem
) && !NILP (subfeature
))
2719 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2720 return (NILP (tem
)) ? Qnil
: Qt
;
2723 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2724 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2725 The optional argument SUBFEATURES should be a list of symbols listing
2726 particular subfeatures supported in this version of FEATURE. */)
2727 (Lisp_Object feature
, Lisp_Object subfeatures
)
2729 register Lisp_Object tem
;
2730 CHECK_SYMBOL (feature
);
2731 CHECK_LIST (subfeatures
);
2732 if (!NILP (Vautoload_queue
))
2733 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2735 tem
= Fmemq (feature
, Vfeatures
);
2737 Vfeatures
= Fcons (feature
, Vfeatures
);
2738 if (!NILP (subfeatures
))
2739 Fput (feature
, Qsubfeatures
, subfeatures
);
2740 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2742 /* Run any load-hooks for this file. */
2743 tem
= Fassq (feature
, Vafter_load_alist
);
2745 Fmapc (Qfuncall
, XCDR (tem
));
2750 /* `require' and its subroutines. */
2752 /* List of features currently being require'd, innermost first. */
2754 static Lisp_Object require_nesting_list
;
2757 require_unwind (Lisp_Object old_value
)
2759 require_nesting_list
= old_value
;
2762 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2763 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2764 If FEATURE is not a member of the list `features', then the feature
2765 is not loaded; so load the file FILENAME.
2766 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2767 and `load' will try to load this name appended with the suffix `.elc' or
2768 `.el', in that order. The name without appended suffix will not be used.
2769 See `get-load-suffixes' for the complete list of suffixes.
2770 If the optional third argument NOERROR is non-nil,
2771 then return nil if the file is not found instead of signaling an error.
2772 Normally the return value is FEATURE.
2773 The normal messages at start and end of loading FILENAME are suppressed. */)
2774 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2777 bool from_file
= load_in_progress
;
2779 CHECK_SYMBOL (feature
);
2781 /* Record the presence of `require' in this file
2782 even if the feature specified is already loaded.
2783 But not more than once in any file,
2784 and not when we aren't loading or reading from a file. */
2786 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2787 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2792 tem
= Fcons (Qrequire
, feature
);
2793 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2794 LOADHIST_ATTACH (tem
);
2796 tem
= Fmemq (feature
, Vfeatures
);
2800 ptrdiff_t count
= SPECPDL_INDEX ();
2803 /* This is to make sure that loadup.el gives a clear picture
2804 of what files are preloaded and when. */
2805 if (! NILP (Vpurify_flag
))
2806 error ("(require %s) while preparing to dump",
2807 SDATA (SYMBOL_NAME (feature
)));
2809 /* A certain amount of recursive `require' is legitimate,
2810 but if we require the same feature recursively 3 times,
2812 tem
= require_nesting_list
;
2813 while (! NILP (tem
))
2815 if (! NILP (Fequal (feature
, XCAR (tem
))))
2820 error ("Recursive `require' for feature `%s'",
2821 SDATA (SYMBOL_NAME (feature
)));
2823 /* Update the list for any nested `require's that occur. */
2824 record_unwind_protect (require_unwind
, require_nesting_list
);
2825 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2827 /* Value saved here is to be restored into Vautoload_queue */
2828 record_unwind_protect (un_autoload
, Vautoload_queue
);
2829 Vautoload_queue
= Qt
;
2831 /* Load the file. */
2832 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2833 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2835 /* If load failed entirely, return nil. */
2837 return unbind_to (count
, Qnil
);
2839 tem
= Fmemq (feature
, Vfeatures
);
2841 error ("Required feature `%s' was not provided",
2842 SDATA (SYMBOL_NAME (feature
)));
2844 /* Once loading finishes, don't undo it. */
2845 Vautoload_queue
= Qt
;
2846 feature
= unbind_to (count
, feature
);
2852 /* Primitives for work of the "widget" library.
2853 In an ideal world, this section would not have been necessary.
2854 However, lisp function calls being as slow as they are, it turns
2855 out that some functions in the widget library (wid-edit.el) are the
2856 bottleneck of Widget operation. Here is their translation to C,
2857 for the sole reason of efficiency. */
2859 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2860 doc
: /* Return non-nil if PLIST has the property PROP.
2861 PLIST is a property list, which is a list of the form
2862 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2863 Unlike `plist-get', this allows you to distinguish between a missing
2864 property and a property with the value nil.
2865 The value is actually the tail of PLIST whose car is PROP. */)
2866 (Lisp_Object plist
, Lisp_Object prop
)
2868 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2870 plist
= XCDR (plist
);
2871 plist
= CDR (plist
);
2877 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2878 doc
: /* In WIDGET, set PROPERTY to VALUE.
2879 The value can later be retrieved with `widget-get'. */)
2880 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2882 CHECK_CONS (widget
);
2883 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2887 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2888 doc
: /* In WIDGET, get the value of PROPERTY.
2889 The value could either be specified when the widget was created, or
2890 later with `widget-put'. */)
2891 (Lisp_Object widget
, Lisp_Object property
)
2899 CHECK_CONS (widget
);
2900 tmp
= Fplist_member (XCDR (widget
), property
);
2906 tmp
= XCAR (widget
);
2909 widget
= Fget (tmp
, Qwidget_type
);
2913 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2914 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2915 ARGS are passed as extra arguments to the function.
2916 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2917 (ptrdiff_t nargs
, Lisp_Object
*args
)
2919 Lisp_Object widget
= args
[0];
2920 Lisp_Object property
= args
[1];
2921 Lisp_Object propval
= Fwidget_get (widget
, property
);
2922 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2923 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2927 #ifdef HAVE_LANGINFO_CODESET
2928 #include <langinfo.h>
2931 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2932 doc
: /* Access locale data ITEM for the current C locale, if available.
2933 ITEM should be one of the following:
2935 `codeset', returning the character set as a string (locale item CODESET);
2937 `days', returning a 7-element vector of day names (locale items DAY_n);
2939 `months', returning a 12-element vector of month names (locale items MON_n);
2941 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2942 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2944 If the system can't provide such information through a call to
2945 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2947 See also Info node `(libc)Locales'.
2949 The data read from the system are decoded using `locale-coding-system'. */)
2953 #ifdef HAVE_LANGINFO_CODESET
2955 if (EQ (item
, Qcodeset
))
2957 str
= nl_langinfo (CODESET
);
2958 return build_string (str
);
2961 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2963 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2964 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2966 synchronize_system_time_locale ();
2967 for (i
= 0; i
< 7; i
++)
2969 str
= nl_langinfo (days
[i
]);
2970 val
= build_unibyte_string (str
);
2971 /* Fixme: Is this coding system necessarily right, even if
2972 it is consistent with CODESET? If not, what to do? */
2973 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2980 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2982 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2983 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2984 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2986 synchronize_system_time_locale ();
2987 for (i
= 0; i
< 12; i
++)
2989 str
= nl_langinfo (months
[i
]);
2990 val
= build_unibyte_string (str
);
2991 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2997 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2998 but is in the locale files. This could be used by ps-print. */
3000 else if (EQ (item
, Qpaper
))
3001 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3002 #endif /* PAPER_WIDTH */
3003 #endif /* HAVE_LANGINFO_CODESET*/
3007 /* base64 encode/decode functions (RFC 2045).
3008 Based on code from GNU recode. */
3010 #define MIME_LINE_LENGTH 76
3012 #define IS_ASCII(Character) \
3014 #define IS_BASE64(Character) \
3015 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3016 #define IS_BASE64_IGNORABLE(Character) \
3017 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3018 || (Character) == '\f' || (Character) == '\r')
3020 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3021 character or return retval if there are no characters left to
3023 #define READ_QUADRUPLET_BYTE(retval) \
3028 if (nchars_return) \
3029 *nchars_return = nchars; \
3034 while (IS_BASE64_IGNORABLE (c))
3036 /* Table of characters coding the 64 values. */
3037 static const char base64_value_to_char
[64] =
3039 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3040 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3041 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3042 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3043 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3044 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3045 '8', '9', '+', '/' /* 60-63 */
3048 /* Table of base64 values for first 128 characters. */
3049 static const short base64_char_to_value
[128] =
3051 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3052 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3053 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3054 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3055 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3056 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3057 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3058 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3059 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3060 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3061 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3062 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3063 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3066 /* The following diagram shows the logical steps by which three octets
3067 get transformed into four base64 characters.
3069 .--------. .--------. .--------.
3070 |aaaaaabb| |bbbbcccc| |ccdddddd|
3071 `--------' `--------' `--------'
3073 .--------+--------+--------+--------.
3074 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3075 `--------+--------+--------+--------'
3077 .--------+--------+--------+--------.
3078 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3079 `--------+--------+--------+--------'
3081 The octets are divided into 6 bit chunks, which are then encoded into
3082 base64 characters. */
3085 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3086 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3089 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3091 doc
: /* Base64-encode the region between BEG and END.
3092 Return the length of the encoded text.
3093 Optional third argument NO-LINE-BREAK means do not break long lines
3094 into shorter lines. */)
3095 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3098 ptrdiff_t allength
, length
;
3099 ptrdiff_t ibeg
, iend
, encoded_length
;
3100 ptrdiff_t old_pos
= PT
;
3103 validate_region (&beg
, &end
);
3105 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3106 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3107 move_gap_both (XFASTINT (beg
), ibeg
);
3109 /* We need to allocate enough room for encoding the text.
3110 We need 33 1/3% more space, plus a newline every 76
3111 characters, and then we round up. */
3112 length
= iend
- ibeg
;
3113 allength
= length
+ length
/3 + 1;
3114 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3116 encoded
= SAFE_ALLOCA (allength
);
3117 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3118 encoded
, length
, NILP (no_line_break
),
3119 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3120 if (encoded_length
> allength
)
3123 if (encoded_length
< 0)
3125 /* The encoding wasn't possible. */
3127 error ("Multibyte character in data for base64 encoding");
3130 /* Now we have encoded the region, so we insert the new contents
3131 and delete the old. (Insert first in order to preserve markers.) */
3132 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3133 insert (encoded
, encoded_length
);
3135 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3137 /* If point was outside of the region, restore it exactly; else just
3138 move to the beginning of the region. */
3139 if (old_pos
>= XFASTINT (end
))
3140 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3141 else if (old_pos
> XFASTINT (beg
))
3142 old_pos
= XFASTINT (beg
);
3145 /* We return the length of the encoded text. */
3146 return make_number (encoded_length
);
3149 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3151 doc
: /* Base64-encode STRING and return the result.
3152 Optional second argument NO-LINE-BREAK means do not break long lines
3153 into shorter lines. */)
3154 (Lisp_Object string
, Lisp_Object no_line_break
)
3156 ptrdiff_t allength
, length
, encoded_length
;
3158 Lisp_Object encoded_string
;
3161 CHECK_STRING (string
);
3163 /* We need to allocate enough room for encoding the text.
3164 We need 33 1/3% more space, plus a newline every 76
3165 characters, and then we round up. */
3166 length
= SBYTES (string
);
3167 allength
= length
+ length
/3 + 1;
3168 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3170 /* We need to allocate enough room for decoding the text. */
3171 encoded
= SAFE_ALLOCA (allength
);
3173 encoded_length
= base64_encode_1 (SSDATA (string
),
3174 encoded
, length
, NILP (no_line_break
),
3175 STRING_MULTIBYTE (string
));
3176 if (encoded_length
> allength
)
3179 if (encoded_length
< 0)
3181 /* The encoding wasn't possible. */
3182 error ("Multibyte character in data for base64 encoding");
3185 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3188 return encoded_string
;
3192 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3193 bool line_break
, bool multibyte
)
3206 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3207 if (CHAR_BYTE8_P (c
))
3208 c
= CHAR_TO_BYTE8 (c
);
3216 /* Wrap line every 76 characters. */
3220 if (counter
< MIME_LINE_LENGTH
/ 4)
3229 /* Process first byte of a triplet. */
3231 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3232 value
= (0x03 & c
) << 4;
3234 /* Process second byte of a triplet. */
3238 *e
++ = base64_value_to_char
[value
];
3246 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3247 if (CHAR_BYTE8_P (c
))
3248 c
= CHAR_TO_BYTE8 (c
);
3256 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3257 value
= (0x0f & c
) << 2;
3259 /* Process third byte of a triplet. */
3263 *e
++ = base64_value_to_char
[value
];
3270 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3271 if (CHAR_BYTE8_P (c
))
3272 c
= CHAR_TO_BYTE8 (c
);
3280 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3281 *e
++ = base64_value_to_char
[0x3f & c
];
3288 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3290 doc
: /* Base64-decode the region between BEG and END.
3291 Return the length of the decoded text.
3292 If the region can't be decoded, signal an error and don't modify the buffer. */)
3293 (Lisp_Object beg
, Lisp_Object end
)
3295 ptrdiff_t ibeg
, iend
, length
, allength
;
3297 ptrdiff_t old_pos
= PT
;
3298 ptrdiff_t decoded_length
;
3299 ptrdiff_t inserted_chars
;
3300 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3303 validate_region (&beg
, &end
);
3305 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3306 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3308 length
= iend
- ibeg
;
3310 /* We need to allocate enough room for decoding the text. If we are
3311 working on a multibyte buffer, each decoded code may occupy at
3313 allength
= multibyte
? length
* 2 : length
;
3314 decoded
= SAFE_ALLOCA (allength
);
3316 move_gap_both (XFASTINT (beg
), ibeg
);
3317 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3319 multibyte
, &inserted_chars
);
3320 if (decoded_length
> allength
)
3323 if (decoded_length
< 0)
3325 /* The decoding wasn't possible. */
3326 error ("Invalid base64 data");
3329 /* Now we have decoded the region, so we insert the new contents
3330 and delete the old. (Insert first in order to preserve markers.) */
3331 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3332 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3335 /* Delete the original text. */
3336 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3337 iend
+ decoded_length
, 1);
3339 /* If point was outside of the region, restore it exactly; else just
3340 move to the beginning of the region. */
3341 if (old_pos
>= XFASTINT (end
))
3342 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3343 else if (old_pos
> XFASTINT (beg
))
3344 old_pos
= XFASTINT (beg
);
3345 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3347 return make_number (inserted_chars
);
3350 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3352 doc
: /* Base64-decode STRING and return the result. */)
3353 (Lisp_Object string
)
3356 ptrdiff_t length
, decoded_length
;
3357 Lisp_Object decoded_string
;
3360 CHECK_STRING (string
);
3362 length
= SBYTES (string
);
3363 /* We need to allocate enough room for decoding the text. */
3364 decoded
= SAFE_ALLOCA (length
);
3366 /* The decoded result should be unibyte. */
3367 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3369 if (decoded_length
> length
)
3371 else if (decoded_length
>= 0)
3372 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3374 decoded_string
= Qnil
;
3377 if (!STRINGP (decoded_string
))
3378 error ("Invalid base64 data");
3380 return decoded_string
;
3383 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3384 MULTIBYTE, the decoded result should be in multibyte
3385 form. If NCHARS_RETURN is not NULL, store the number of produced
3386 characters in *NCHARS_RETURN. */
3389 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3390 bool multibyte
, ptrdiff_t *nchars_return
)
3392 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3395 unsigned long value
;
3396 ptrdiff_t nchars
= 0;
3400 /* Process first byte of a quadruplet. */
3402 READ_QUADRUPLET_BYTE (e
-to
);
3406 value
= base64_char_to_value
[c
] << 18;
3408 /* Process second byte of a quadruplet. */
3410 READ_QUADRUPLET_BYTE (-1);
3414 value
|= base64_char_to_value
[c
] << 12;
3416 c
= (unsigned char) (value
>> 16);
3417 if (multibyte
&& c
>= 128)
3418 e
+= BYTE8_STRING (c
, e
);
3423 /* Process third byte of a quadruplet. */
3425 READ_QUADRUPLET_BYTE (-1);
3429 READ_QUADRUPLET_BYTE (-1);
3438 value
|= base64_char_to_value
[c
] << 6;
3440 c
= (unsigned char) (0xff & value
>> 8);
3441 if (multibyte
&& c
>= 128)
3442 e
+= BYTE8_STRING (c
, e
);
3447 /* Process fourth byte of a quadruplet. */
3449 READ_QUADRUPLET_BYTE (-1);
3456 value
|= base64_char_to_value
[c
];
3458 c
= (unsigned char) (0xff & value
);
3459 if (multibyte
&& c
>= 128)
3460 e
+= BYTE8_STRING (c
, e
);
3469 /***********************************************************************
3471 ***** Hash Tables *****
3473 ***********************************************************************/
3475 /* Implemented by gerd@gnu.org. This hash table implementation was
3476 inspired by CMUCL hash tables. */
3480 1. For small tables, association lists are probably faster than
3481 hash tables because they have lower overhead.
3483 For uses of hash tables where the O(1) behavior of table
3484 operations is not a requirement, it might therefore be a good idea
3485 not to hash. Instead, we could just do a linear search in the
3486 key_and_value vector of the hash table. This could be done
3487 if a `:linear-search t' argument is given to make-hash-table. */
3490 /* The list of all weak hash tables. Don't staticpro this one. */
3492 static struct Lisp_Hash_Table
*weak_hash_tables
;
3495 /***********************************************************************
3497 ***********************************************************************/
3500 CHECK_HASH_TABLE (Lisp_Object x
)
3502 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3506 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3508 h
->key_and_value
= key_and_value
;
3511 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3516 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3518 gc_aset (h
->next
, idx
, val
);
3521 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3526 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3528 gc_aset (h
->hash
, idx
, val
);
3531 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3536 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3538 gc_aset (h
->index
, idx
, val
);
3541 /* If OBJ is a Lisp hash table, return a pointer to its struct
3542 Lisp_Hash_Table. Otherwise, signal an error. */
3544 static struct Lisp_Hash_Table
*
3545 check_hash_table (Lisp_Object obj
)
3547 CHECK_HASH_TABLE (obj
);
3548 return XHASH_TABLE (obj
);
3552 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3553 number. A number is "almost" a prime number if it is not divisible
3554 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3557 next_almost_prime (EMACS_INT n
)
3559 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3560 for (n
|= 1; ; n
+= 2)
3561 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3566 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3567 which USED[I] is non-zero. If found at index I in ARGS, set
3568 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3569 0. This function is used to extract a keyword/argument pair from
3570 a DEFUN parameter list. */
3573 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3577 for (i
= 1; i
< nargs
; i
++)
3578 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3589 /* Return a Lisp vector which has the same contents as VEC but has
3590 at least INCR_MIN more entries, where INCR_MIN is positive.
3591 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3592 than NITEMS_MAX. Entries in the resulting
3593 vector that are not copied from VEC are set to nil. */
3596 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3598 struct Lisp_Vector
*v
;
3599 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3600 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3601 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3602 ? nitems_max
: C_language_max
);
3603 eassert (VECTORP (vec
));
3604 eassert (0 < incr_min
&& -1 <= nitems_max
);
3605 old_size
= ASIZE (vec
);
3606 incr_max
= n_max
- old_size
;
3607 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3608 if (incr_max
< incr
)
3609 memory_full (SIZE_MAX
);
3610 new_size
= old_size
+ incr
;
3611 v
= allocate_vector (new_size
);
3612 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3613 memclear (v
->contents
+ old_size
, incr
* word_size
);
3614 XSETVECTOR (vec
, v
);
3619 /***********************************************************************
3621 ***********************************************************************/
3623 static struct hash_table_test hashtest_eq
;
3624 struct hash_table_test hashtest_eql
, hashtest_equal
;
3626 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3627 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3628 KEY2 are the same. */
3631 cmpfn_eql (struct hash_table_test
*ht
,
3635 return (FLOATP (key1
)
3637 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3641 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3642 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3643 KEY2 are the same. */
3646 cmpfn_equal (struct hash_table_test
*ht
,
3650 return !NILP (Fequal (key1
, key2
));
3654 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3655 HASH2 in hash table H using H->user_cmp_function. Value is true
3656 if KEY1 and KEY2 are the same. */
3659 cmpfn_user_defined (struct hash_table_test
*ht
,
3663 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3667 /* Value is a hash code for KEY for use in hash table H which uses
3668 `eq' to compare keys. The hash code returned is guaranteed to fit
3669 in a Lisp integer. */
3672 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3674 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3678 /* Value is a hash code for KEY for use in hash table H which uses
3679 `eql' to compare keys. The hash code returned is guaranteed to fit
3680 in a Lisp integer. */
3683 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3687 hash
= sxhash (key
, 0);
3689 hash
= XHASH (key
) ^ XTYPE (key
);
3693 /* Value is a hash code for KEY for use in hash table H which uses
3694 `equal' to compare keys. The hash code returned is guaranteed to fit
3695 in a Lisp integer. */
3698 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3700 EMACS_UINT hash
= sxhash (key
, 0);
3704 /* Value is a hash code for KEY for use in hash table H which uses as
3705 user-defined function to compare keys. The hash code returned is
3706 guaranteed to fit in a Lisp integer. */
3709 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3711 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3712 return hashfn_eq (ht
, hash
);
3715 /* Allocate basically initialized hash table. */
3717 static struct Lisp_Hash_Table
*
3718 allocate_hash_table (void)
3720 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3721 count
, PVEC_HASH_TABLE
);
3724 /* An upper bound on the size of a hash table index. It must fit in
3725 ptrdiff_t and be a valid Emacs fixnum. */
3726 #define INDEX_SIZE_BOUND \
3727 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3729 /* Create and initialize a new hash table.
3731 TEST specifies the test the hash table will use to compare keys.
3732 It must be either one of the predefined tests `eq', `eql' or
3733 `equal' or a symbol denoting a user-defined test named TEST with
3734 test and hash functions USER_TEST and USER_HASH.
3736 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3738 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3739 new size when it becomes full is computed by adding REHASH_SIZE to
3740 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3741 table's new size is computed by multiplying its old size with
3744 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3745 be resized when the ratio of (number of entries in the table) /
3746 (table size) is >= REHASH_THRESHOLD.
3748 WEAK specifies the weakness of the table. If non-nil, it must be
3749 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3752 make_hash_table (struct hash_table_test test
,
3753 Lisp_Object size
, Lisp_Object rehash_size
,
3754 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3756 struct Lisp_Hash_Table
*h
;
3758 EMACS_INT index_size
, sz
;
3762 /* Preconditions. */
3763 eassert (SYMBOLP (test
.name
));
3764 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3765 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3766 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3767 eassert (FLOATP (rehash_threshold
)
3768 && 0 < XFLOAT_DATA (rehash_threshold
)
3769 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3771 if (XFASTINT (size
) == 0)
3772 size
= make_number (1);
3774 sz
= XFASTINT (size
);
3775 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3776 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3777 ? next_almost_prime (index_float
)
3778 : INDEX_SIZE_BOUND
+ 1);
3779 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3780 error ("Hash table too large");
3782 /* Allocate a table and initialize it. */
3783 h
= allocate_hash_table ();
3785 /* Initialize hash table slots. */
3788 h
->rehash_threshold
= rehash_threshold
;
3789 h
->rehash_size
= rehash_size
;
3791 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3792 h
->hash
= Fmake_vector (size
, Qnil
);
3793 h
->next
= Fmake_vector (size
, Qnil
);
3794 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3796 /* Set up the free list. */
3797 for (i
= 0; i
< sz
- 1; ++i
)
3798 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3799 h
->next_free
= make_number (0);
3801 XSET_HASH_TABLE (table
, h
);
3802 eassert (HASH_TABLE_P (table
));
3803 eassert (XHASH_TABLE (table
) == h
);
3805 /* Maybe add this hash table to the list of all weak hash tables. */
3807 h
->next_weak
= NULL
;
3810 h
->next_weak
= weak_hash_tables
;
3811 weak_hash_tables
= h
;
3818 /* Return a copy of hash table H1. Keys and values are not copied,
3819 only the table itself is. */
3822 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3825 struct Lisp_Hash_Table
*h2
;
3827 h2
= allocate_hash_table ();
3829 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3830 h2
->hash
= Fcopy_sequence (h1
->hash
);
3831 h2
->next
= Fcopy_sequence (h1
->next
);
3832 h2
->index
= Fcopy_sequence (h1
->index
);
3833 XSET_HASH_TABLE (table
, h2
);
3835 /* Maybe add this hash table to the list of all weak hash tables. */
3836 if (!NILP (h2
->weak
))
3838 h2
->next_weak
= weak_hash_tables
;
3839 weak_hash_tables
= h2
;
3846 /* Resize hash table H if it's too full. If H cannot be resized
3847 because it's already too large, throw an error. */
3850 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3852 if (NILP (h
->next_free
))
3854 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3855 EMACS_INT new_size
, index_size
, nsize
;
3859 if (INTEGERP (h
->rehash_size
))
3860 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3863 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3864 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3866 new_size
= float_new_size
;
3867 if (new_size
<= old_size
)
3868 new_size
= old_size
+ 1;
3871 new_size
= INDEX_SIZE_BOUND
+ 1;
3873 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3874 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3875 ? next_almost_prime (index_float
)
3876 : INDEX_SIZE_BOUND
+ 1);
3877 nsize
= max (index_size
, 2 * new_size
);
3878 if (INDEX_SIZE_BOUND
< nsize
)
3879 error ("Hash table too large to resize");
3881 #ifdef ENABLE_CHECKING
3882 if (HASH_TABLE_P (Vpurify_flag
)
3883 && XHASH_TABLE (Vpurify_flag
) == h
)
3884 message ("Growing hash table to: %"pI
"d", new_size
);
3887 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3888 2 * (new_size
- old_size
), -1));
3889 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3890 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3891 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3893 /* Update the free list. Do it so that new entries are added at
3894 the end of the free list. This makes some operations like
3896 for (i
= old_size
; i
< new_size
- 1; ++i
)
3897 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3899 if (!NILP (h
->next_free
))
3901 Lisp_Object last
, next
;
3903 last
= h
->next_free
;
3904 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3908 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3911 XSETFASTINT (h
->next_free
, old_size
);
3914 for (i
= 0; i
< old_size
; ++i
)
3915 if (!NILP (HASH_HASH (h
, i
)))
3917 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3918 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3919 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3920 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3926 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3927 the hash code of KEY. Value is the index of the entry in H
3928 matching KEY, or -1 if not found. */
3931 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3933 EMACS_UINT hash_code
;
3934 ptrdiff_t start_of_bucket
;
3937 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3938 eassert ((hash_code
& ~INTMASK
) == 0);
3942 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3943 idx
= HASH_INDEX (h
, start_of_bucket
);
3947 ptrdiff_t i
= XFASTINT (idx
);
3948 if (EQ (key
, HASH_KEY (h
, i
))
3950 && hash_code
== XUINT (HASH_HASH (h
, i
))
3951 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3953 idx
= HASH_NEXT (h
, i
);
3956 return NILP (idx
) ? -1 : XFASTINT (idx
);
3960 /* Put an entry into hash table H that associates KEY with VALUE.
3961 HASH is a previously computed hash code of KEY.
3962 Value is the index of the entry in H matching KEY. */
3965 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3968 ptrdiff_t start_of_bucket
, i
;
3970 eassert ((hash
& ~INTMASK
) == 0);
3972 /* Increment count after resizing because resizing may fail. */
3973 maybe_resize_hash_table (h
);
3976 /* Store key/value in the key_and_value vector. */
3977 i
= XFASTINT (h
->next_free
);
3978 h
->next_free
= HASH_NEXT (h
, i
);
3979 set_hash_key_slot (h
, i
, key
);
3980 set_hash_value_slot (h
, i
, value
);
3982 /* Remember its hash code. */
3983 set_hash_hash_slot (h
, i
, make_number (hash
));
3985 /* Add new entry to its collision chain. */
3986 start_of_bucket
= hash
% ASIZE (h
->index
);
3987 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3988 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3993 /* Remove the entry matching KEY from hash table H, if there is one. */
3996 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3998 EMACS_UINT hash_code
;
3999 ptrdiff_t start_of_bucket
;
4000 Lisp_Object idx
, prev
;
4002 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4003 eassert ((hash_code
& ~INTMASK
) == 0);
4004 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4005 idx
= HASH_INDEX (h
, start_of_bucket
);
4010 ptrdiff_t i
= XFASTINT (idx
);
4012 if (EQ (key
, HASH_KEY (h
, i
))
4014 && hash_code
== XUINT (HASH_HASH (h
, i
))
4015 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4017 /* Take entry out of collision chain. */
4019 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4021 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4023 /* Clear slots in key_and_value and add the slots to
4025 set_hash_key_slot (h
, i
, Qnil
);
4026 set_hash_value_slot (h
, i
, Qnil
);
4027 set_hash_hash_slot (h
, i
, Qnil
);
4028 set_hash_next_slot (h
, i
, h
->next_free
);
4029 h
->next_free
= make_number (i
);
4031 eassert (h
->count
>= 0);
4037 idx
= HASH_NEXT (h
, i
);
4043 /* Clear hash table H. */
4046 hash_clear (struct Lisp_Hash_Table
*h
)
4050 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4052 for (i
= 0; i
< size
; ++i
)
4054 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4055 set_hash_key_slot (h
, i
, Qnil
);
4056 set_hash_value_slot (h
, i
, Qnil
);
4057 set_hash_hash_slot (h
, i
, Qnil
);
4060 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4061 ASET (h
->index
, i
, Qnil
);
4063 h
->next_free
= make_number (0);
4070 /************************************************************************
4072 ************************************************************************/
4074 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4075 entries from the table that don't survive the current GC.
4076 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4077 true if anything was marked. */
4080 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4082 ptrdiff_t bucket
, n
;
4085 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4088 for (bucket
= 0; bucket
< n
; ++bucket
)
4090 Lisp_Object idx
, next
, prev
;
4092 /* Follow collision chain, removing entries that
4093 don't survive this garbage collection. */
4095 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4097 ptrdiff_t i
= XFASTINT (idx
);
4098 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4099 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4102 if (EQ (h
->weak
, Qkey
))
4103 remove_p
= !key_known_to_survive_p
;
4104 else if (EQ (h
->weak
, Qvalue
))
4105 remove_p
= !value_known_to_survive_p
;
4106 else if (EQ (h
->weak
, Qkey_or_value
))
4107 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4108 else if (EQ (h
->weak
, Qkey_and_value
))
4109 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4113 next
= HASH_NEXT (h
, i
);
4115 if (remove_entries_p
)
4119 /* Take out of collision chain. */
4121 set_hash_index_slot (h
, bucket
, next
);
4123 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4125 /* Add to free list. */
4126 set_hash_next_slot (h
, i
, h
->next_free
);
4129 /* Clear key, value, and hash. */
4130 set_hash_key_slot (h
, i
, Qnil
);
4131 set_hash_value_slot (h
, i
, Qnil
);
4132 set_hash_hash_slot (h
, i
, Qnil
);
4145 /* Make sure key and value survive. */
4146 if (!key_known_to_survive_p
)
4148 mark_object (HASH_KEY (h
, i
));
4152 if (!value_known_to_survive_p
)
4154 mark_object (HASH_VALUE (h
, i
));
4165 /* Remove elements from weak hash tables that don't survive the
4166 current garbage collection. Remove weak tables that don't survive
4167 from Vweak_hash_tables. Called from gc_sweep. */
4169 NO_INLINE
/* For better stack traces */
4171 sweep_weak_hash_tables (void)
4173 struct Lisp_Hash_Table
*h
, *used
, *next
;
4176 /* Mark all keys and values that are in use. Keep on marking until
4177 there is no more change. This is necessary for cases like
4178 value-weak table A containing an entry X -> Y, where Y is used in a
4179 key-weak table B, Z -> Y. If B comes after A in the list of weak
4180 tables, X -> Y might be removed from A, although when looking at B
4181 one finds that it shouldn't. */
4185 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4187 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4188 marked
|= sweep_weak_table (h
, 0);
4193 /* Remove tables and entries that aren't used. */
4194 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4196 next
= h
->next_weak
;
4198 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4200 /* TABLE is marked as used. Sweep its contents. */
4202 sweep_weak_table (h
, 1);
4204 /* Add table to the list of used weak hash tables. */
4205 h
->next_weak
= used
;
4210 weak_hash_tables
= used
;
4215 /***********************************************************************
4216 Hash Code Computation
4217 ***********************************************************************/
4219 /* Maximum depth up to which to dive into Lisp structures. */
4221 #define SXHASH_MAX_DEPTH 3
4223 /* Maximum length up to which to take list and vector elements into
4226 #define SXHASH_MAX_LEN 7
4228 /* Return a hash for string PTR which has length LEN. The hash value
4229 can be any EMACS_UINT value. */
4232 hash_string (char const *ptr
, ptrdiff_t len
)
4234 char const *p
= ptr
;
4235 char const *end
= p
+ len
;
4237 EMACS_UINT hash
= 0;
4242 hash
= sxhash_combine (hash
, c
);
4248 /* Return a hash for string PTR which has length LEN. The hash
4249 code returned is guaranteed to fit in a Lisp integer. */
4252 sxhash_string (char const *ptr
, ptrdiff_t len
)
4254 EMACS_UINT hash
= hash_string (ptr
, len
);
4255 return SXHASH_REDUCE (hash
);
4258 /* Return a hash for the floating point value VAL. */
4261 sxhash_float (double val
)
4263 EMACS_UINT hash
= 0;
4265 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4266 + (sizeof val
% sizeof hash
!= 0))
4270 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4274 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4275 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4276 hash
= sxhash_combine (hash
, u
.word
[i
]);
4277 return SXHASH_REDUCE (hash
);
4280 /* Return a hash for list LIST. DEPTH is the current depth in the
4281 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4284 sxhash_list (Lisp_Object list
, int depth
)
4286 EMACS_UINT hash
= 0;
4289 if (depth
< SXHASH_MAX_DEPTH
)
4291 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4292 list
= XCDR (list
), ++i
)
4294 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4295 hash
= sxhash_combine (hash
, hash2
);
4300 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4301 hash
= sxhash_combine (hash
, hash2
);
4304 return SXHASH_REDUCE (hash
);
4308 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4309 the Lisp structure. */
4312 sxhash_vector (Lisp_Object vec
, int depth
)
4314 EMACS_UINT hash
= ASIZE (vec
);
4317 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4318 for (i
= 0; i
< n
; ++i
)
4320 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4321 hash
= sxhash_combine (hash
, hash2
);
4324 return SXHASH_REDUCE (hash
);
4327 /* Return a hash for bool-vector VECTOR. */
4330 sxhash_bool_vector (Lisp_Object vec
)
4332 EMACS_INT size
= bool_vector_size (vec
);
4333 EMACS_UINT hash
= size
;
4336 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4337 for (i
= 0; i
< n
; ++i
)
4338 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4340 return SXHASH_REDUCE (hash
);
4344 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4345 structure. Value is an unsigned integer clipped to INTMASK. */
4348 sxhash (Lisp_Object obj
, int depth
)
4352 if (depth
> SXHASH_MAX_DEPTH
)
4355 switch (XTYPE (obj
))
4367 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4370 /* This can be everything from a vector to an overlay. */
4371 case Lisp_Vectorlike
:
4373 /* According to the CL HyperSpec, two arrays are equal only if
4374 they are `eq', except for strings and bit-vectors. In
4375 Emacs, this works differently. We have to compare element
4377 hash
= sxhash_vector (obj
, depth
);
4378 else if (BOOL_VECTOR_P (obj
))
4379 hash
= sxhash_bool_vector (obj
);
4381 /* Others are `equal' if they are `eq', so let's take their
4387 hash
= sxhash_list (obj
, depth
);
4391 hash
= sxhash_float (XFLOAT_DATA (obj
));
4403 /***********************************************************************
4405 ***********************************************************************/
4408 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4409 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4412 EMACS_UINT hash
= sxhash (obj
, 0);
4413 return make_number (hash
);
4417 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4418 doc
: /* Create and return a new hash table.
4420 Arguments are specified as keyword/argument pairs. The following
4421 arguments are defined:
4423 :test TEST -- TEST must be a symbol that specifies how to compare
4424 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4425 `equal'. User-supplied test and hash functions can be specified via
4426 `define-hash-table-test'.
4428 :size SIZE -- A hint as to how many elements will be put in the table.
4431 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4432 fills up. If REHASH-SIZE is an integer, increase the size by that
4433 amount. If it is a float, it must be > 1.0, and the new size is the
4434 old size multiplied by that factor. Default is 1.5.
4436 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4437 Resize the hash table when the ratio (number of entries / table size)
4438 is greater than or equal to THRESHOLD. Default is 0.8.
4440 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4441 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4442 returned is a weak table. Key/value pairs are removed from a weak
4443 hash table when there are no non-weak references pointing to their
4444 key, value, one of key or value, or both key and value, depending on
4445 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4448 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4449 (ptrdiff_t nargs
, Lisp_Object
*args
)
4451 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4452 struct hash_table_test testdesc
;
4456 /* The vector `used' is used to keep track of arguments that
4457 have been consumed. */
4458 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4459 memset (used
, 0, nargs
* sizeof *used
);
4461 /* See if there's a `:test TEST' among the arguments. */
4462 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4463 test
= i
? args
[i
] : Qeql
;
4465 testdesc
= hashtest_eq
;
4466 else if (EQ (test
, Qeql
))
4467 testdesc
= hashtest_eql
;
4468 else if (EQ (test
, Qequal
))
4469 testdesc
= hashtest_equal
;
4472 /* See if it is a user-defined test. */
4475 prop
= Fget (test
, Qhash_table_test
);
4476 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4477 signal_error ("Invalid hash table test", test
);
4478 testdesc
.name
= test
;
4479 testdesc
.user_cmp_function
= XCAR (prop
);
4480 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4481 testdesc
.hashfn
= hashfn_user_defined
;
4482 testdesc
.cmpfn
= cmpfn_user_defined
;
4485 /* See if there's a `:size SIZE' argument. */
4486 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4487 size
= i
? args
[i
] : Qnil
;
4489 size
= make_number (DEFAULT_HASH_SIZE
);
4490 else if (!INTEGERP (size
) || XINT (size
) < 0)
4491 signal_error ("Invalid hash table size", size
);
4493 /* Look for `:rehash-size SIZE'. */
4494 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4495 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4496 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4497 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4498 signal_error ("Invalid hash table rehash size", rehash_size
);
4500 /* Look for `:rehash-threshold THRESHOLD'. */
4501 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4502 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4503 if (! (FLOATP (rehash_threshold
)
4504 && 0 < XFLOAT_DATA (rehash_threshold
)
4505 && XFLOAT_DATA (rehash_threshold
) <= 1))
4506 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4508 /* Look for `:weakness WEAK'. */
4509 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4510 weak
= i
? args
[i
] : Qnil
;
4512 weak
= Qkey_and_value
;
4515 && !EQ (weak
, Qvalue
)
4516 && !EQ (weak
, Qkey_or_value
)
4517 && !EQ (weak
, Qkey_and_value
))
4518 signal_error ("Invalid hash table weakness", weak
);
4520 /* Now, all args should have been used up, or there's a problem. */
4521 for (i
= 0; i
< nargs
; ++i
)
4523 signal_error ("Invalid argument list", args
[i
]);
4526 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4530 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4531 doc
: /* Return a copy of hash table TABLE. */)
4534 return copy_hash_table (check_hash_table (table
));
4538 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4539 doc
: /* Return the number of elements in TABLE. */)
4542 return make_number (check_hash_table (table
)->count
);
4546 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4547 Shash_table_rehash_size
, 1, 1, 0,
4548 doc
: /* Return the current rehash size of TABLE. */)
4551 return check_hash_table (table
)->rehash_size
;
4555 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4556 Shash_table_rehash_threshold
, 1, 1, 0,
4557 doc
: /* Return the current rehash threshold of TABLE. */)
4560 return check_hash_table (table
)->rehash_threshold
;
4564 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4565 doc
: /* Return the size of TABLE.
4566 The size can be used as an argument to `make-hash-table' to create
4567 a hash table than can hold as many elements as TABLE holds
4568 without need for resizing. */)
4571 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4572 return make_number (HASH_TABLE_SIZE (h
));
4576 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4577 doc
: /* Return the test TABLE uses. */)
4580 return check_hash_table (table
)->test
.name
;
4584 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4586 doc
: /* Return the weakness of TABLE. */)
4589 return check_hash_table (table
)->weak
;
4593 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4594 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4597 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4601 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4602 doc
: /* Clear hash table TABLE and return it. */)
4605 hash_clear (check_hash_table (table
));
4606 /* Be compatible with XEmacs. */
4611 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4612 doc
: /* Look up KEY in TABLE and return its associated value.
4613 If KEY is not found, return DFLT which defaults to nil. */)
4614 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4616 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4617 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4618 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4622 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4623 doc
: /* Associate KEY with VALUE in hash table TABLE.
4624 If KEY is already present in table, replace its current value with
4625 VALUE. In any case, return VALUE. */)
4626 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4628 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4632 i
= hash_lookup (h
, key
, &hash
);
4634 set_hash_value_slot (h
, i
, value
);
4636 hash_put (h
, key
, value
, hash
);
4642 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4643 doc
: /* Remove KEY from TABLE. */)
4644 (Lisp_Object key
, Lisp_Object table
)
4646 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4647 hash_remove_from_table (h
, key
);
4652 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4653 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4654 FUNCTION is called with two arguments, KEY and VALUE.
4655 `maphash' always returns nil. */)
4656 (Lisp_Object function
, Lisp_Object table
)
4658 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4660 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4661 if (!NILP (HASH_HASH (h
, i
)))
4662 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4668 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4669 Sdefine_hash_table_test
, 3, 3, 0,
4670 doc
: /* Define a new hash table test with name NAME, a symbol.
4672 In hash tables created with NAME specified as test, use TEST to
4673 compare keys, and HASH for computing hash codes of keys.
4675 TEST must be a function taking two arguments and returning non-nil if
4676 both arguments are the same. HASH must be a function taking one
4677 argument and returning an object that is the hash code of the argument.
4678 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4679 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4680 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4682 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4687 /************************************************************************
4688 MD5, SHA-1, and SHA-2
4689 ************************************************************************/
4696 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4699 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4700 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4704 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4705 register EMACS_INT b
, e
;
4706 register struct buffer
*bp
;
4709 void *(*hash_func
) (const char *, size_t, void *);
4712 CHECK_SYMBOL (algorithm
);
4714 if (STRINGP (object
))
4716 if (NILP (coding_system
))
4718 /* Decide the coding-system to encode the data with. */
4720 if (STRING_MULTIBYTE (object
))
4721 /* use default, we can't guess correct value */
4722 coding_system
= preferred_coding_system ();
4724 coding_system
= Qraw_text
;
4727 if (NILP (Fcoding_system_p (coding_system
)))
4729 /* Invalid coding system. */
4731 if (!NILP (noerror
))
4732 coding_system
= Qraw_text
;
4734 xsignal1 (Qcoding_system_error
, coding_system
);
4737 if (STRING_MULTIBYTE (object
))
4738 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4740 size
= SCHARS (object
);
4741 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4743 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4744 end_byte
= (end_char
== size
4746 : string_char_to_byte (object
, end_char
));
4750 struct buffer
*prev
= current_buffer
;
4752 record_unwind_current_buffer ();
4754 CHECK_BUFFER (object
);
4756 bp
= XBUFFER (object
);
4757 set_buffer_internal (bp
);
4763 CHECK_NUMBER_COERCE_MARKER (start
);
4771 CHECK_NUMBER_COERCE_MARKER (end
);
4776 temp
= b
, b
= e
, e
= temp
;
4778 if (!(BEGV
<= b
&& e
<= ZV
))
4779 args_out_of_range (start
, end
);
4781 if (NILP (coding_system
))
4783 /* Decide the coding-system to encode the data with.
4784 See fileio.c:Fwrite-region */
4786 if (!NILP (Vcoding_system_for_write
))
4787 coding_system
= Vcoding_system_for_write
;
4790 bool force_raw_text
= 0;
4792 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4793 if (NILP (coding_system
)
4794 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4796 coding_system
= Qnil
;
4797 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4801 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4803 /* Check file-coding-system-alist. */
4804 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4805 Qwrite_region
, start
, end
,
4806 Fbuffer_file_name (object
));
4807 if (CONSP (val
) && !NILP (XCDR (val
)))
4808 coding_system
= XCDR (val
);
4811 if (NILP (coding_system
)
4812 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4814 /* If we still have not decided a coding system, use the
4815 default value of buffer-file-coding-system. */
4816 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4820 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4821 /* Confirm that VAL can surely encode the current region. */
4822 coding_system
= call4 (Vselect_safe_coding_system_function
,
4823 make_number (b
), make_number (e
),
4824 coding_system
, Qnil
);
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
);
4841 object
= make_buffer_string (b
, e
, 0);
4842 set_buffer_internal (prev
);
4843 /* Discard the unwind protect for recovering the current
4847 if (STRING_MULTIBYTE (object
))
4848 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4850 end_byte
= SBYTES (object
);
4853 if (EQ (algorithm
, Qmd5
))
4855 digest_size
= MD5_DIGEST_SIZE
;
4856 hash_func
= md5_buffer
;
4858 else if (EQ (algorithm
, Qsha1
))
4860 digest_size
= SHA1_DIGEST_SIZE
;
4861 hash_func
= sha1_buffer
;
4863 else if (EQ (algorithm
, Qsha224
))
4865 digest_size
= SHA224_DIGEST_SIZE
;
4866 hash_func
= sha224_buffer
;
4868 else if (EQ (algorithm
, Qsha256
))
4870 digest_size
= SHA256_DIGEST_SIZE
;
4871 hash_func
= sha256_buffer
;
4873 else if (EQ (algorithm
, Qsha384
))
4875 digest_size
= SHA384_DIGEST_SIZE
;
4876 hash_func
= sha384_buffer
;
4878 else if (EQ (algorithm
, Qsha512
))
4880 digest_size
= SHA512_DIGEST_SIZE
;
4881 hash_func
= sha512_buffer
;
4884 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4886 /* allocate 2 x digest_size so that it can be re-used to hold the
4888 digest
= make_uninit_string (digest_size
* 2);
4890 hash_func (SSDATA (object
) + start_byte
,
4891 end_byte
- start_byte
,
4896 unsigned char *p
= SDATA (digest
);
4897 for (i
= digest_size
- 1; i
>= 0; i
--)
4899 static char const hexdigit
[16] = "0123456789abcdef";
4901 p
[2 * i
] = hexdigit
[p_i
>> 4];
4902 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4907 return make_unibyte_string (SSDATA (digest
), digest_size
);
4910 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4911 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4913 A message digest is a cryptographic checksum of a document, and the
4914 algorithm to calculate it is defined in RFC 1321.
4916 The two optional arguments START and END are character positions
4917 specifying for which part of OBJECT the message digest should be
4918 computed. If nil or omitted, the digest is computed for the whole
4921 The MD5 message digest is computed from the result of encoding the
4922 text in a coding system, not directly from the internal Emacs form of
4923 the text. The optional fourth argument CODING-SYSTEM specifies which
4924 coding system to encode the text with. It should be the same coding
4925 system that you used or will use when actually writing the text into a
4928 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4929 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4930 system would be chosen by default for writing this text into a file.
4932 If OBJECT is a string, the most preferred coding system (see the
4933 command `prefer-coding-system') is used.
4935 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4936 guesswork fails. Normally, an error is signaled in such case. */)
4937 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4939 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4942 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4943 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4944 ALGORITHM is a symbol specifying the hash to use:
4945 md5, sha1, sha224, sha256, sha384 or sha512.
4947 The two optional arguments START and END are positions specifying for
4948 which part of OBJECT to compute the hash. If nil or omitted, uses the
4951 If BINARY is non-nil, returns a string in binary form. */)
4952 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4954 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4960 DEFSYM (Qmd5
, "md5");
4961 DEFSYM (Qsha1
, "sha1");
4962 DEFSYM (Qsha224
, "sha224");
4963 DEFSYM (Qsha256
, "sha256");
4964 DEFSYM (Qsha384
, "sha384");
4965 DEFSYM (Qsha512
, "sha512");
4967 /* Hash table stuff. */
4968 DEFSYM (Qhash_table_p
, "hash-table-p");
4970 DEFSYM (Qeql
, "eql");
4971 DEFSYM (Qequal
, "equal");
4972 DEFSYM (QCtest
, ":test");
4973 DEFSYM (QCsize
, ":size");
4974 DEFSYM (QCrehash_size
, ":rehash-size");
4975 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4976 DEFSYM (QCweakness
, ":weakness");
4977 DEFSYM (Qkey
, "key");
4978 DEFSYM (Qvalue
, "value");
4979 DEFSYM (Qhash_table_test
, "hash-table-test");
4980 DEFSYM (Qkey_or_value
, "key-or-value");
4981 DEFSYM (Qkey_and_value
, "key-and-value");
4984 defsubr (&Smake_hash_table
);
4985 defsubr (&Scopy_hash_table
);
4986 defsubr (&Shash_table_count
);
4987 defsubr (&Shash_table_rehash_size
);
4988 defsubr (&Shash_table_rehash_threshold
);
4989 defsubr (&Shash_table_size
);
4990 defsubr (&Shash_table_test
);
4991 defsubr (&Shash_table_weakness
);
4992 defsubr (&Shash_table_p
);
4993 defsubr (&Sclrhash
);
4994 defsubr (&Sgethash
);
4995 defsubr (&Sputhash
);
4996 defsubr (&Sremhash
);
4997 defsubr (&Smaphash
);
4998 defsubr (&Sdefine_hash_table_test
);
5000 DEFSYM (Qstring_lessp
, "string-lessp");
5001 DEFSYM (Qprovide
, "provide");
5002 DEFSYM (Qrequire
, "require");
5003 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5004 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5005 DEFSYM (Qwidget_type
, "widget-type");
5007 staticpro (&string_char_byte_cache_string
);
5008 string_char_byte_cache_string
= Qnil
;
5010 require_nesting_list
= Qnil
;
5011 staticpro (&require_nesting_list
);
5013 Fset (Qyes_or_no_p_history
, Qnil
);
5015 DEFVAR_LISP ("features", Vfeatures
,
5016 doc
: /* A list of symbols which are the features of the executing Emacs.
5017 Used by `featurep' and `require', and altered by `provide'. */);
5018 Vfeatures
= list1 (Qemacs
);
5019 DEFSYM (Qsubfeatures
, "subfeatures");
5020 DEFSYM (Qfuncall
, "funcall");
5022 #ifdef HAVE_LANGINFO_CODESET
5023 DEFSYM (Qcodeset
, "codeset");
5024 DEFSYM (Qdays
, "days");
5025 DEFSYM (Qmonths
, "months");
5026 DEFSYM (Qpaper
, "paper");
5027 #endif /* HAVE_LANGINFO_CODESET */
5029 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5030 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5031 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5032 invoked by mouse clicks and mouse menu items.
5034 On some platforms, file selection dialogs are also enabled if this is
5038 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5039 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5040 This applies to commands from menus and tool bar buttons even when
5041 they are initiated from the keyboard. If `use-dialog-box' is nil,
5042 that disables the use of a file dialog, regardless of the value of
5044 use_file_dialog
= 1;
5046 defsubr (&Sidentity
);
5049 defsubr (&Ssafe_length
);
5050 defsubr (&Sstring_bytes
);
5051 defsubr (&Sstring_equal
);
5052 defsubr (&Scompare_strings
);
5053 defsubr (&Sstring_lessp
);
5054 defsubr (&Sstring_collate_lessp
);
5055 defsubr (&Sstring_collate_equalp
);
5058 defsubr (&Svconcat
);
5059 defsubr (&Scopy_sequence
);
5060 defsubr (&Sstring_make_multibyte
);
5061 defsubr (&Sstring_make_unibyte
);
5062 defsubr (&Sstring_as_multibyte
);
5063 defsubr (&Sstring_as_unibyte
);
5064 defsubr (&Sstring_to_multibyte
);
5065 defsubr (&Sstring_to_unibyte
);
5066 defsubr (&Scopy_alist
);
5067 defsubr (&Ssubstring
);
5068 defsubr (&Ssubstring_no_properties
);
5081 defsubr (&Snreverse
);
5082 defsubr (&Sreverse
);
5084 defsubr (&Splist_get
);
5086 defsubr (&Splist_put
);
5088 defsubr (&Slax_plist_get
);
5089 defsubr (&Slax_plist_put
);
5092 defsubr (&Sequal_including_properties
);
5093 defsubr (&Sfillarray
);
5094 defsubr (&Sclear_string
);
5098 defsubr (&Smapconcat
);
5099 defsubr (&Syes_or_no_p
);
5100 defsubr (&Sload_average
);
5101 defsubr (&Sfeaturep
);
5102 defsubr (&Srequire
);
5103 defsubr (&Sprovide
);
5104 defsubr (&Splist_member
);
5105 defsubr (&Swidget_put
);
5106 defsubr (&Swidget_get
);
5107 defsubr (&Swidget_apply
);
5108 defsubr (&Sbase64_encode_region
);
5109 defsubr (&Sbase64_decode_region
);
5110 defsubr (&Sbase64_encode_string
);
5111 defsubr (&Sbase64_decode_string
);
5113 defsubr (&Ssecure_hash
);
5114 defsubr (&Slocale_info
);
5116 hashtest_eq
.name
= Qeq
;
5117 hashtest_eq
.user_hash_function
= Qnil
;
5118 hashtest_eq
.user_cmp_function
= Qnil
;
5119 hashtest_eq
.cmpfn
= 0;
5120 hashtest_eq
.hashfn
= hashfn_eq
;
5122 hashtest_eql
.name
= Qeql
;
5123 hashtest_eql
.user_hash_function
= Qnil
;
5124 hashtest_eql
.user_cmp_function
= Qnil
;
5125 hashtest_eql
.cmpfn
= cmpfn_eql
;
5126 hashtest_eql
.hashfn
= hashfn_eql
;
5128 hashtest_equal
.name
= Qequal
;
5129 hashtest_equal
.user_hash_function
= Qnil
;
5130 hashtest_equal
.user_cmp_function
= Qnil
;
5131 hashtest_equal
.cmpfn
= cmpfn_equal
;
5132 hashtest_equal
.hashfn
= hashfn_equal
;