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'. */)
1584 (register Lisp_Object elt
, Lisp_Object list
)
1586 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1589 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1591 Lisp_Object tem
= XCAR (tail
);
1597 Fsetcdr (prev
, XCDR (tail
));
1605 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1606 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1607 SEQ must be a sequence (i.e. a list, a vector, or a string).
1608 The return value is a sequence of the same type.
1610 If SEQ is a list, this behaves like `delq', except that it compares
1611 with `equal' instead of `eq'. In particular, it may remove elements
1612 by altering the list structure.
1614 If SEQ is not a list, deletion is never performed destructively;
1615 instead this function creates and returns a new vector or string.
1617 Write `(setq foo (delete element foo))' to be sure of correctly
1618 changing the value of a sequence `foo'. */)
1619 (Lisp_Object elt
, Lisp_Object seq
)
1625 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1626 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1629 if (n
!= ASIZE (seq
))
1631 struct Lisp_Vector
*p
= allocate_vector (n
);
1633 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1634 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1635 p
->contents
[n
++] = AREF (seq
, i
);
1637 XSETVECTOR (seq
, p
);
1640 else if (STRINGP (seq
))
1642 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1645 for (i
= nchars
= nbytes
= ibyte
= 0;
1647 ++i
, ibyte
+= cbytes
)
1649 if (STRING_MULTIBYTE (seq
))
1651 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1652 cbytes
= CHAR_BYTES (c
);
1660 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1667 if (nchars
!= SCHARS (seq
))
1671 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1672 if (!STRING_MULTIBYTE (seq
))
1673 STRING_SET_UNIBYTE (tem
);
1675 for (i
= nchars
= nbytes
= ibyte
= 0;
1677 ++i
, ibyte
+= cbytes
)
1679 if (STRING_MULTIBYTE (seq
))
1681 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1682 cbytes
= CHAR_BYTES (c
);
1690 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1692 unsigned char *from
= SDATA (seq
) + ibyte
;
1693 unsigned char *to
= SDATA (tem
) + nbytes
;
1699 for (n
= cbytes
; n
--; )
1709 Lisp_Object tail
, prev
;
1711 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1713 CHECK_LIST_CONS (tail
, seq
);
1715 if (!NILP (Fequal (elt
, XCAR (tail
))))
1720 Fsetcdr (prev
, XCDR (tail
));
1731 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1732 doc
: /* Reverse order of items in a list, vector or string SEQ.
1733 If SEQ is a list, it should be nil-terminated.
1734 This function may destructively modify SEQ to produce the value. */)
1739 else if (STRINGP (seq
))
1740 return Freverse (seq
);
1741 else if (CONSP (seq
))
1743 Lisp_Object prev
, tail
, next
;
1745 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1748 CHECK_LIST_CONS (tail
, tail
);
1750 Fsetcdr (tail
, prev
);
1755 else if (VECTORP (seq
))
1757 ptrdiff_t i
, size
= ASIZE (seq
);
1759 for (i
= 0; i
< size
/ 2; i
++)
1761 Lisp_Object tem
= AREF (seq
, i
);
1762 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1763 ASET (seq
, size
- i
- 1, tem
);
1766 else if (BOOL_VECTOR_P (seq
))
1768 ptrdiff_t i
, size
= bool_vector_size (seq
);
1770 for (i
= 0; i
< size
/ 2; i
++)
1772 bool tem
= bool_vector_bitref (seq
, i
);
1773 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1774 bool_vector_set (seq
, size
- i
- 1, tem
);
1778 wrong_type_argument (Qarrayp
, seq
);
1782 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1783 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1784 See also the function `nreverse', which is used more often. */)
1791 else if (CONSP (seq
))
1793 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1796 new = Fcons (XCAR (seq
), new);
1798 CHECK_LIST_END (seq
, seq
);
1800 else if (VECTORP (seq
))
1802 ptrdiff_t i
, size
= ASIZE (seq
);
1804 new = make_uninit_vector (size
);
1805 for (i
= 0; i
< size
; i
++)
1806 ASET (new, i
, AREF (seq
, size
- i
- 1));
1808 else if (BOOL_VECTOR_P (seq
))
1811 EMACS_INT nbits
= bool_vector_size (seq
);
1813 new = make_uninit_bool_vector (nbits
);
1814 for (i
= 0; i
< nbits
; i
++)
1815 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1817 else if (STRINGP (seq
))
1819 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1825 new = make_uninit_string (size
);
1826 for (i
= 0; i
< size
; i
++)
1827 SSET (new, i
, SREF (seq
, size
- i
- 1));
1831 unsigned char *p
, *q
;
1833 new = make_uninit_multibyte_string (size
, bytes
);
1834 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1835 while (q
> SDATA (new))
1839 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1841 CHAR_STRING (ch
, q
);
1846 wrong_type_argument (Qsequencep
, seq
);
1850 /* Sort LIST using PREDICATE, preserving original order of elements
1851 considered as equal. */
1854 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1856 Lisp_Object front
, back
;
1857 Lisp_Object len
, tem
;
1861 len
= Flength (list
);
1862 length
= XINT (len
);
1866 XSETINT (len
, (length
/ 2) - 1);
1867 tem
= Fnthcdr (len
, list
);
1869 Fsetcdr (tem
, Qnil
);
1871 front
= Fsort (front
, predicate
);
1872 back
= Fsort (back
, predicate
);
1873 return merge (front
, back
, predicate
);
1876 /* Using PRED to compare, return whether A and B are in order.
1877 Compare stably when A appeared before B in the input. */
1879 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1881 return NILP (call2 (pred
, b
, a
));
1884 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1885 into DEST. Argument arrays must be nonempty and must not overlap,
1886 except that B might be the last part of DEST. */
1888 merge_vectors (Lisp_Object pred
,
1889 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1890 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1891 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1893 eassume (0 < alen
&& 0 < blen
);
1894 Lisp_Object
const *alim
= a
+ alen
;
1895 Lisp_Object
const *blim
= b
+ blen
;
1899 if (inorder (pred
, a
[0], b
[0]))
1905 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1914 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1921 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1922 temporary storage. LEN must be at least 2. */
1924 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1925 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1926 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1929 ptrdiff_t halflen
= len
>> 1;
1930 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1931 if (1 < len
- halflen
)
1932 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1933 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1936 /* Using PRED to compare, sort from LEN-length SRC into DST.
1937 Len must be positive. */
1939 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1940 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1941 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1944 ptrdiff_t halflen
= len
>> 1;
1950 sort_vector_inplace (pred
, halflen
, src
, dest
);
1951 if (1 < len
- halflen
)
1952 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1953 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1957 /* Sort VECTOR in place using PREDICATE, preserving original order of
1958 elements considered as equal. */
1961 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1963 ptrdiff_t len
= ASIZE (vector
);
1966 ptrdiff_t halflen
= len
>> 1;
1969 SAFE_ALLOCA_LISP (tmp
, halflen
);
1970 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1971 tmp
[i
] = make_number (0);
1972 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1976 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1977 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1978 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1979 modified by side effects. PREDICATE is called with two elements of
1980 SEQ, and should return non-nil if the first element should sort before
1982 (Lisp_Object seq
, Lisp_Object predicate
)
1985 seq
= sort_list (seq
, predicate
);
1986 else if (VECTORP (seq
))
1987 sort_vector (seq
, predicate
);
1988 else if (!NILP (seq
))
1989 wrong_type_argument (Qsequencep
, seq
);
1994 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1996 Lisp_Object l1
= org_l1
;
1997 Lisp_Object l2
= org_l2
;
1998 Lisp_Object tail
= Qnil
;
1999 Lisp_Object value
= Qnil
;
2019 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2034 Fsetcdr (tail
, tem
);
2040 /* This does not check for quits. That is safe since it must terminate. */
2042 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2043 doc
: /* Extract a value from a property list.
2044 PLIST is a property list, which is a list of the form
2045 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2046 corresponding to the given PROP, or nil if PROP is not one of the
2047 properties on the list. This function never signals an error. */)
2048 (Lisp_Object plist
, Lisp_Object prop
)
2050 Lisp_Object tail
, halftail
;
2052 /* halftail is used to detect circular lists. */
2053 tail
= halftail
= plist
;
2054 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2056 if (EQ (prop
, XCAR (tail
)))
2057 return XCAR (XCDR (tail
));
2059 tail
= XCDR (XCDR (tail
));
2060 halftail
= XCDR (halftail
);
2061 if (EQ (tail
, halftail
))
2068 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2069 doc
: /* Return the value of SYMBOL's PROPNAME property.
2070 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2071 (Lisp_Object symbol
, Lisp_Object propname
)
2073 CHECK_SYMBOL (symbol
);
2074 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2077 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2078 doc
: /* Change value in PLIST of PROP to VAL.
2079 PLIST is a property list, which is a list of the form
2080 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2081 If PROP is already a property on the list, its value is set to VAL,
2082 otherwise the new PROP VAL pair is added. The new plist is returned;
2083 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2084 The PLIST is modified by side effects. */)
2085 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2087 register Lisp_Object tail
, prev
;
2088 Lisp_Object newcell
;
2090 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2091 tail
= XCDR (XCDR (tail
)))
2093 if (EQ (prop
, XCAR (tail
)))
2095 Fsetcar (XCDR (tail
), val
);
2102 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2106 Fsetcdr (XCDR (prev
), newcell
);
2110 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2111 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2112 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2113 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2115 CHECK_SYMBOL (symbol
);
2117 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2121 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2122 doc
: /* Extract a value from a property list, comparing with `equal'.
2123 PLIST is a property list, which is a list of the form
2124 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2125 corresponding to the given PROP, or nil if PROP is not
2126 one of the properties on the list. */)
2127 (Lisp_Object plist
, Lisp_Object prop
)
2132 CONSP (tail
) && CONSP (XCDR (tail
));
2133 tail
= XCDR (XCDR (tail
)))
2135 if (! NILP (Fequal (prop
, XCAR (tail
))))
2136 return XCAR (XCDR (tail
));
2141 CHECK_LIST_END (tail
, prop
);
2146 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2147 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2148 PLIST is a property list, which is a list of the form
2149 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2150 If PROP is already a property on the list, its value is set to VAL,
2151 otherwise the new PROP VAL pair is added. The new plist is returned;
2152 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2153 The PLIST is modified by side effects. */)
2154 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2156 register Lisp_Object tail
, prev
;
2157 Lisp_Object newcell
;
2159 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2160 tail
= XCDR (XCDR (tail
)))
2162 if (! NILP (Fequal (prop
, XCAR (tail
))))
2164 Fsetcar (XCDR (tail
), val
);
2171 newcell
= list2 (prop
, val
);
2175 Fsetcdr (XCDR (prev
), newcell
);
2179 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2180 doc
: /* Return t if the two args are the same Lisp object.
2181 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2182 (Lisp_Object obj1
, Lisp_Object obj2
)
2185 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2187 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2190 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2191 doc
: /* Return t if two Lisp objects have similar structure and contents.
2192 They must have the same data type.
2193 Conses are compared by comparing the cars and the cdrs.
2194 Vectors and strings are compared element by element.
2195 Numbers are compared by value, but integers cannot equal floats.
2196 (Use `=' if you want integers and floats to be able to be equal.)
2197 Symbols must match exactly. */)
2198 (register Lisp_Object o1
, Lisp_Object o2
)
2200 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2203 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2204 doc
: /* Return t if two Lisp objects have similar structure and contents.
2205 This is like `equal' except that it compares the text properties
2206 of strings. (`equal' ignores text properties.) */)
2207 (register Lisp_Object o1
, Lisp_Object o2
)
2209 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2212 /* DEPTH is current depth of recursion. Signal an error if it
2214 PROPS means compare string text properties too. */
2217 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2223 error ("Stack overflow in equal");
2225 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2228 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2230 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2232 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2234 { /* `o1' was seen already. */
2235 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2236 if (!NILP (Fmemq (o2
, o2s
)))
2239 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2242 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2252 if (XTYPE (o1
) != XTYPE (o2
))
2261 d1
= extract_float (o1
);
2262 d2
= extract_float (o2
);
2263 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2264 though they are not =. */
2265 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2269 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2273 /* FIXME: This inf-loops in a circular list! */
2277 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2281 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2282 depth
+ 1, props
, ht
)
2283 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2284 depth
+ 1, props
, ht
))
2286 o1
= XOVERLAY (o1
)->plist
;
2287 o2
= XOVERLAY (o2
)->plist
;
2292 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2293 && (XMARKER (o1
)->buffer
== 0
2294 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2298 case Lisp_Vectorlike
:
2301 ptrdiff_t size
= ASIZE (o1
);
2302 /* Pseudovectors have the type encoded in the size field, so this test
2303 actually checks that the objects have the same type as well as the
2305 if (ASIZE (o2
) != size
)
2307 /* Boolvectors are compared much like strings. */
2308 if (BOOL_VECTOR_P (o1
))
2310 EMACS_INT size
= bool_vector_size (o1
);
2311 if (size
!= bool_vector_size (o2
))
2313 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2314 bool_vector_bytes (size
)))
2318 if (WINDOW_CONFIGURATIONP (o1
))
2319 return compare_window_configurations (o1
, o2
, 0);
2321 /* Aside from them, only true vectors, char-tables, compiled
2322 functions, and fonts (font-spec, font-entity, font-object)
2323 are sensible to compare, so eliminate the others now. */
2324 if (size
& PSEUDOVECTOR_FLAG
)
2326 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2329 size
&= PSEUDOVECTOR_SIZE_MASK
;
2331 for (i
= 0; i
< size
; i
++)
2336 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2344 if (SCHARS (o1
) != SCHARS (o2
))
2346 if (SBYTES (o1
) != SBYTES (o2
))
2348 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2350 if (props
&& !compare_string_intervals (o1
, o2
))
2362 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2363 doc
: /* Store each element of ARRAY with ITEM.
2364 ARRAY is a vector, string, char-table, or bool-vector. */)
2365 (Lisp_Object array
, Lisp_Object item
)
2367 register ptrdiff_t size
, idx
;
2369 if (VECTORP (array
))
2370 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2371 ASET (array
, idx
, item
);
2372 else if (CHAR_TABLE_P (array
))
2376 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2377 set_char_table_contents (array
, i
, item
);
2378 set_char_table_defalt (array
, item
);
2380 else if (STRINGP (array
))
2382 register unsigned char *p
= SDATA (array
);
2384 CHECK_CHARACTER (item
);
2385 charval
= XFASTINT (item
);
2386 size
= SCHARS (array
);
2387 if (STRING_MULTIBYTE (array
))
2389 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2390 int len
= CHAR_STRING (charval
, str
);
2391 ptrdiff_t size_byte
= SBYTES (array
);
2394 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2395 error ("Attempt to change byte length of a string");
2396 for (idx
= 0; idx
< size_byte
; idx
++)
2397 *p
++ = str
[idx
% len
];
2400 for (idx
= 0; idx
< size
; idx
++)
2403 else if (BOOL_VECTOR_P (array
))
2404 return bool_vector_fill (array
, item
);
2406 wrong_type_argument (Qarrayp
, array
);
2410 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2412 doc
: /* Clear the contents of STRING.
2413 This makes STRING unibyte and may change its length. */)
2414 (Lisp_Object string
)
2417 CHECK_STRING (string
);
2418 len
= SBYTES (string
);
2419 memset (SDATA (string
), 0, len
);
2420 STRING_SET_CHARS (string
, len
);
2421 STRING_SET_UNIBYTE (string
);
2427 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2429 return CALLN (Fnconc
, s1
, s2
);
2432 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2433 doc
: /* Concatenate any number of lists by altering them.
2434 Only the last argument is not altered, and need not be a list.
2435 usage: (nconc &rest LISTS) */)
2436 (ptrdiff_t nargs
, Lisp_Object
*args
)
2439 register Lisp_Object tail
, tem
, val
;
2443 for (argnum
= 0; argnum
< nargs
; argnum
++)
2446 if (NILP (tem
)) continue;
2451 if (argnum
+ 1 == nargs
) break;
2453 CHECK_LIST_CONS (tem
, tem
);
2462 tem
= args
[argnum
+ 1];
2463 Fsetcdr (tail
, tem
);
2465 args
[argnum
+ 1] = tail
;
2471 /* This is the guts of all mapping functions.
2472 Apply FN to each element of SEQ, one by one,
2473 storing the results into elements of VALS, a C vector of Lisp_Objects.
2474 LENI is the length of VALS, which should also be the length of SEQ. */
2477 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2479 Lisp_Object tail
, dummy
;
2482 if (VECTORP (seq
) || COMPILEDP (seq
))
2484 for (i
= 0; i
< leni
; i
++)
2486 dummy
= call1 (fn
, AREF (seq
, i
));
2491 else if (BOOL_VECTOR_P (seq
))
2493 for (i
= 0; i
< leni
; i
++)
2495 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2500 else if (STRINGP (seq
))
2504 for (i
= 0, i_byte
= 0; i
< leni
;)
2507 ptrdiff_t i_before
= i
;
2509 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2510 XSETFASTINT (dummy
, c
);
2511 dummy
= call1 (fn
, dummy
);
2513 vals
[i_before
] = dummy
;
2516 else /* Must be a list, since Flength did not get an error */
2519 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2521 dummy
= call1 (fn
, XCAR (tail
));
2529 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2530 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2531 In between each pair of results, stick in SEPARATOR. Thus, " " as
2532 SEPARATOR results in spaces between the values returned by FUNCTION.
2533 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2534 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2544 len
= Flength (sequence
);
2545 if (CHAR_TABLE_P (sequence
))
2546 wrong_type_argument (Qlistp
, sequence
);
2548 nargs
= leni
+ leni
- 1;
2549 if (nargs
< 0) return empty_unibyte_string
;
2551 SAFE_ALLOCA_LISP (args
, nargs
);
2553 mapcar1 (leni
, args
, function
, sequence
);
2555 for (i
= leni
- 1; i
> 0; i
--)
2556 args
[i
+ i
] = args
[i
];
2558 for (i
= 1; i
< nargs
; i
+= 2)
2559 args
[i
] = separator
;
2561 ret
= Fconcat (nargs
, args
);
2567 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2568 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2569 The result is a list just as long as SEQUENCE.
2570 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2571 (Lisp_Object function
, Lisp_Object sequence
)
2573 register Lisp_Object len
;
2574 register EMACS_INT leni
;
2575 register Lisp_Object
*args
;
2579 len
= Flength (sequence
);
2580 if (CHAR_TABLE_P (sequence
))
2581 wrong_type_argument (Qlistp
, sequence
);
2582 leni
= XFASTINT (len
);
2584 SAFE_ALLOCA_LISP (args
, leni
);
2586 mapcar1 (leni
, args
, function
, sequence
);
2588 ret
= Flist (leni
, args
);
2594 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2595 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2596 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2597 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2598 (Lisp_Object function
, Lisp_Object sequence
)
2600 register EMACS_INT leni
;
2602 leni
= XFASTINT (Flength (sequence
));
2603 if (CHAR_TABLE_P (sequence
))
2604 wrong_type_argument (Qlistp
, sequence
);
2605 mapcar1 (leni
, 0, function
, sequence
);
2610 /* This is how C code calls `yes-or-no-p' and allows the user
2614 do_yes_or_no_p (Lisp_Object prompt
)
2616 return call1 (intern ("yes-or-no-p"), prompt
);
2619 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2620 doc
: /* Ask user a yes-or-no question.
2621 Return t if answer is yes, and nil if the answer is no.
2622 PROMPT is the string to display to ask the question. It should end in
2623 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2625 The user must confirm the answer with RET, and can edit it until it
2628 If dialog boxes are supported, a dialog box will be used
2629 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2630 (Lisp_Object prompt
)
2634 CHECK_STRING (prompt
);
2636 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2637 && use_dialog_box
&& ! NILP (last_input_event
))
2639 Lisp_Object pane
, menu
, obj
;
2640 redisplay_preserve_echo_area (4);
2641 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2642 Fcons (build_string ("No"), Qnil
));
2643 menu
= Fcons (prompt
, pane
);
2644 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2648 AUTO_STRING (yes_or_no
, "(yes or no) ");
2649 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2653 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2654 Qyes_or_no_p_history
, Qnil
,
2656 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2658 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2663 message1 ("Please answer yes or no.");
2664 Fsleep_for (make_number (2), Qnil
);
2668 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2669 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2671 Each of the three load averages is multiplied by 100, then converted
2674 When USE-FLOATS is non-nil, floats will be used instead of integers.
2675 These floats are not multiplied by 100.
2677 If the 5-minute or 15-minute load averages are not available, return a
2678 shortened list, containing only those averages which are available.
2680 An error is thrown if the load average can't be obtained. In some
2681 cases making it work would require Emacs being installed setuid or
2682 setgid so that it can read kernel information, and that usually isn't
2684 (Lisp_Object use_floats
)
2687 int loads
= getloadavg (load_ave
, 3);
2688 Lisp_Object ret
= Qnil
;
2691 error ("load-average not implemented for this operating system");
2695 Lisp_Object load
= (NILP (use_floats
)
2696 ? make_number (100.0 * load_ave
[loads
])
2697 : make_float (load_ave
[loads
]));
2698 ret
= Fcons (load
, ret
);
2704 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2705 doc
: /* Return t if FEATURE is present in this Emacs.
2707 Use this to conditionalize execution of lisp code based on the
2708 presence or absence of Emacs or environment extensions.
2709 Use `provide' to declare that a feature is available. This function
2710 looks at the value of the variable `features'. The optional argument
2711 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2712 (Lisp_Object feature
, Lisp_Object subfeature
)
2714 register Lisp_Object tem
;
2715 CHECK_SYMBOL (feature
);
2716 tem
= Fmemq (feature
, Vfeatures
);
2717 if (!NILP (tem
) && !NILP (subfeature
))
2718 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2719 return (NILP (tem
)) ? Qnil
: Qt
;
2722 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2723 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2724 The optional argument SUBFEATURES should be a list of symbols listing
2725 particular subfeatures supported in this version of FEATURE. */)
2726 (Lisp_Object feature
, Lisp_Object subfeatures
)
2728 register Lisp_Object tem
;
2729 CHECK_SYMBOL (feature
);
2730 CHECK_LIST (subfeatures
);
2731 if (!NILP (Vautoload_queue
))
2732 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2734 tem
= Fmemq (feature
, Vfeatures
);
2736 Vfeatures
= Fcons (feature
, Vfeatures
);
2737 if (!NILP (subfeatures
))
2738 Fput (feature
, Qsubfeatures
, subfeatures
);
2739 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2741 /* Run any load-hooks for this file. */
2742 tem
= Fassq (feature
, Vafter_load_alist
);
2744 Fmapc (Qfuncall
, XCDR (tem
));
2749 /* `require' and its subroutines. */
2751 /* List of features currently being require'd, innermost first. */
2753 static Lisp_Object require_nesting_list
;
2756 require_unwind (Lisp_Object old_value
)
2758 require_nesting_list
= old_value
;
2761 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2762 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2763 If FEATURE is not a member of the list `features', then the feature
2764 is not loaded; so load the file FILENAME.
2765 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2766 and `load' will try to load this name appended with the suffix `.elc' or
2767 `.el', in that order. The name without appended suffix will not be used.
2768 See `get-load-suffixes' for the complete list of suffixes.
2769 If the optional third argument NOERROR is non-nil,
2770 then return nil if the file is not found instead of signaling an error.
2771 Normally the return value is FEATURE.
2772 The normal messages at start and end of loading FILENAME are suppressed. */)
2773 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2776 bool from_file
= load_in_progress
;
2778 CHECK_SYMBOL (feature
);
2780 /* Record the presence of `require' in this file
2781 even if the feature specified is already loaded.
2782 But not more than once in any file,
2783 and not when we aren't loading or reading from a file. */
2785 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2786 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2791 tem
= Fcons (Qrequire
, feature
);
2792 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2793 LOADHIST_ATTACH (tem
);
2795 tem
= Fmemq (feature
, Vfeatures
);
2799 ptrdiff_t count
= SPECPDL_INDEX ();
2802 /* This is to make sure that loadup.el gives a clear picture
2803 of what files are preloaded and when. */
2804 if (! NILP (Vpurify_flag
))
2805 error ("(require %s) while preparing to dump",
2806 SDATA (SYMBOL_NAME (feature
)));
2808 /* A certain amount of recursive `require' is legitimate,
2809 but if we require the same feature recursively 3 times,
2811 tem
= require_nesting_list
;
2812 while (! NILP (tem
))
2814 if (! NILP (Fequal (feature
, XCAR (tem
))))
2819 error ("Recursive `require' for feature `%s'",
2820 SDATA (SYMBOL_NAME (feature
)));
2822 /* Update the list for any nested `require's that occur. */
2823 record_unwind_protect (require_unwind
, require_nesting_list
);
2824 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2826 /* Value saved here is to be restored into Vautoload_queue */
2827 record_unwind_protect (un_autoload
, Vautoload_queue
);
2828 Vautoload_queue
= Qt
;
2830 /* Load the file. */
2831 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2832 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2834 /* If load failed entirely, return nil. */
2836 return unbind_to (count
, Qnil
);
2838 tem
= Fmemq (feature
, Vfeatures
);
2840 error ("Required feature `%s' was not provided",
2841 SDATA (SYMBOL_NAME (feature
)));
2843 /* Once loading finishes, don't undo it. */
2844 Vautoload_queue
= Qt
;
2845 feature
= unbind_to (count
, feature
);
2851 /* Primitives for work of the "widget" library.
2852 In an ideal world, this section would not have been necessary.
2853 However, lisp function calls being as slow as they are, it turns
2854 out that some functions in the widget library (wid-edit.el) are the
2855 bottleneck of Widget operation. Here is their translation to C,
2856 for the sole reason of efficiency. */
2858 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2859 doc
: /* Return non-nil if PLIST has the property PROP.
2860 PLIST is a property list, which is a list of the form
2861 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2862 Unlike `plist-get', this allows you to distinguish between a missing
2863 property and a property with the value nil.
2864 The value is actually the tail of PLIST whose car is PROP. */)
2865 (Lisp_Object plist
, Lisp_Object prop
)
2867 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2869 plist
= XCDR (plist
);
2870 plist
= CDR (plist
);
2876 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2877 doc
: /* In WIDGET, set PROPERTY to VALUE.
2878 The value can later be retrieved with `widget-get'. */)
2879 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2881 CHECK_CONS (widget
);
2882 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2886 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2887 doc
: /* In WIDGET, get the value of PROPERTY.
2888 The value could either be specified when the widget was created, or
2889 later with `widget-put'. */)
2890 (Lisp_Object widget
, Lisp_Object property
)
2898 CHECK_CONS (widget
);
2899 tmp
= Fplist_member (XCDR (widget
), property
);
2905 tmp
= XCAR (widget
);
2908 widget
= Fget (tmp
, Qwidget_type
);
2912 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2913 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2914 ARGS are passed as extra arguments to the function.
2915 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2916 (ptrdiff_t nargs
, Lisp_Object
*args
)
2918 Lisp_Object widget
= args
[0];
2919 Lisp_Object property
= args
[1];
2920 Lisp_Object propval
= Fwidget_get (widget
, property
);
2921 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2922 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2926 #ifdef HAVE_LANGINFO_CODESET
2927 #include <langinfo.h>
2930 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2931 doc
: /* Access locale data ITEM for the current C locale, if available.
2932 ITEM should be one of the following:
2934 `codeset', returning the character set as a string (locale item CODESET);
2936 `days', returning a 7-element vector of day names (locale items DAY_n);
2938 `months', returning a 12-element vector of month names (locale items MON_n);
2940 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2941 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2943 If the system can't provide such information through a call to
2944 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2946 See also Info node `(libc)Locales'.
2948 The data read from the system are decoded using `locale-coding-system'. */)
2952 #ifdef HAVE_LANGINFO_CODESET
2954 if (EQ (item
, Qcodeset
))
2956 str
= nl_langinfo (CODESET
);
2957 return build_string (str
);
2960 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2962 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2963 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2965 synchronize_system_time_locale ();
2966 for (i
= 0; i
< 7; i
++)
2968 str
= nl_langinfo (days
[i
]);
2969 val
= build_unibyte_string (str
);
2970 /* Fixme: Is this coding system necessarily right, even if
2971 it is consistent with CODESET? If not, what to do? */
2972 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2979 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2981 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2982 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2983 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2985 synchronize_system_time_locale ();
2986 for (i
= 0; i
< 12; i
++)
2988 str
= nl_langinfo (months
[i
]);
2989 val
= build_unibyte_string (str
);
2990 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2996 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2997 but is in the locale files. This could be used by ps-print. */
2999 else if (EQ (item
, Qpaper
))
3000 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3001 #endif /* PAPER_WIDTH */
3002 #endif /* HAVE_LANGINFO_CODESET*/
3006 /* base64 encode/decode functions (RFC 2045).
3007 Based on code from GNU recode. */
3009 #define MIME_LINE_LENGTH 76
3011 #define IS_ASCII(Character) \
3013 #define IS_BASE64(Character) \
3014 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3015 #define IS_BASE64_IGNORABLE(Character) \
3016 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3017 || (Character) == '\f' || (Character) == '\r')
3019 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3020 character or return retval if there are no characters left to
3022 #define READ_QUADRUPLET_BYTE(retval) \
3027 if (nchars_return) \
3028 *nchars_return = nchars; \
3033 while (IS_BASE64_IGNORABLE (c))
3035 /* Table of characters coding the 64 values. */
3036 static const char base64_value_to_char
[64] =
3038 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3039 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3040 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3041 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3042 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3043 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3044 '8', '9', '+', '/' /* 60-63 */
3047 /* Table of base64 values for first 128 characters. */
3048 static const short base64_char_to_value
[128] =
3050 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3051 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3052 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3053 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3054 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3055 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3056 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3057 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3058 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3059 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3060 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3061 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3062 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3065 /* The following diagram shows the logical steps by which three octets
3066 get transformed into four base64 characters.
3068 .--------. .--------. .--------.
3069 |aaaaaabb| |bbbbcccc| |ccdddddd|
3070 `--------' `--------' `--------'
3072 .--------+--------+--------+--------.
3073 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3074 `--------+--------+--------+--------'
3076 .--------+--------+--------+--------.
3077 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3078 `--------+--------+--------+--------'
3080 The octets are divided into 6 bit chunks, which are then encoded into
3081 base64 characters. */
3084 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3085 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3088 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3090 doc
: /* Base64-encode the region between BEG and END.
3091 Return the length of the encoded text.
3092 Optional third argument NO-LINE-BREAK means do not break long lines
3093 into shorter lines. */)
3094 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3097 ptrdiff_t allength
, length
;
3098 ptrdiff_t ibeg
, iend
, encoded_length
;
3099 ptrdiff_t old_pos
= PT
;
3102 validate_region (&beg
, &end
);
3104 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3105 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3106 move_gap_both (XFASTINT (beg
), ibeg
);
3108 /* We need to allocate enough room for encoding the text.
3109 We need 33 1/3% more space, plus a newline every 76
3110 characters, and then we round up. */
3111 length
= iend
- ibeg
;
3112 allength
= length
+ length
/3 + 1;
3113 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3115 encoded
= SAFE_ALLOCA (allength
);
3116 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3117 encoded
, length
, NILP (no_line_break
),
3118 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3119 if (encoded_length
> allength
)
3122 if (encoded_length
< 0)
3124 /* The encoding wasn't possible. */
3126 error ("Multibyte character in data for base64 encoding");
3129 /* Now we have encoded the region, so we insert the new contents
3130 and delete the old. (Insert first in order to preserve markers.) */
3131 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3132 insert (encoded
, encoded_length
);
3134 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3136 /* If point was outside of the region, restore it exactly; else just
3137 move to the beginning of the region. */
3138 if (old_pos
>= XFASTINT (end
))
3139 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3140 else if (old_pos
> XFASTINT (beg
))
3141 old_pos
= XFASTINT (beg
);
3144 /* We return the length of the encoded text. */
3145 return make_number (encoded_length
);
3148 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3150 doc
: /* Base64-encode STRING and return the result.
3151 Optional second argument NO-LINE-BREAK means do not break long lines
3152 into shorter lines. */)
3153 (Lisp_Object string
, Lisp_Object no_line_break
)
3155 ptrdiff_t allength
, length
, encoded_length
;
3157 Lisp_Object encoded_string
;
3160 CHECK_STRING (string
);
3162 /* We need to allocate enough room for encoding the text.
3163 We need 33 1/3% more space, plus a newline every 76
3164 characters, and then we round up. */
3165 length
= SBYTES (string
);
3166 allength
= length
+ length
/3 + 1;
3167 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3169 /* We need to allocate enough room for decoding the text. */
3170 encoded
= SAFE_ALLOCA (allength
);
3172 encoded_length
= base64_encode_1 (SSDATA (string
),
3173 encoded
, length
, NILP (no_line_break
),
3174 STRING_MULTIBYTE (string
));
3175 if (encoded_length
> allength
)
3178 if (encoded_length
< 0)
3180 /* The encoding wasn't possible. */
3181 error ("Multibyte character in data for base64 encoding");
3184 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3187 return encoded_string
;
3191 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3192 bool line_break
, bool multibyte
)
3205 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3206 if (CHAR_BYTE8_P (c
))
3207 c
= CHAR_TO_BYTE8 (c
);
3215 /* Wrap line every 76 characters. */
3219 if (counter
< MIME_LINE_LENGTH
/ 4)
3228 /* Process first byte of a triplet. */
3230 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3231 value
= (0x03 & c
) << 4;
3233 /* Process second byte of a triplet. */
3237 *e
++ = base64_value_to_char
[value
];
3245 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3246 if (CHAR_BYTE8_P (c
))
3247 c
= CHAR_TO_BYTE8 (c
);
3255 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3256 value
= (0x0f & c
) << 2;
3258 /* Process third byte of a triplet. */
3262 *e
++ = base64_value_to_char
[value
];
3269 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3270 if (CHAR_BYTE8_P (c
))
3271 c
= CHAR_TO_BYTE8 (c
);
3279 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3280 *e
++ = base64_value_to_char
[0x3f & c
];
3287 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3289 doc
: /* Base64-decode the region between BEG and END.
3290 Return the length of the decoded text.
3291 If the region can't be decoded, signal an error and don't modify the buffer. */)
3292 (Lisp_Object beg
, Lisp_Object end
)
3294 ptrdiff_t ibeg
, iend
, length
, allength
;
3296 ptrdiff_t old_pos
= PT
;
3297 ptrdiff_t decoded_length
;
3298 ptrdiff_t inserted_chars
;
3299 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3302 validate_region (&beg
, &end
);
3304 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3305 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3307 length
= iend
- ibeg
;
3309 /* We need to allocate enough room for decoding the text. If we are
3310 working on a multibyte buffer, each decoded code may occupy at
3312 allength
= multibyte
? length
* 2 : length
;
3313 decoded
= SAFE_ALLOCA (allength
);
3315 move_gap_both (XFASTINT (beg
), ibeg
);
3316 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3318 multibyte
, &inserted_chars
);
3319 if (decoded_length
> allength
)
3322 if (decoded_length
< 0)
3324 /* The decoding wasn't possible. */
3325 error ("Invalid base64 data");
3328 /* Now we have decoded the region, so we insert the new contents
3329 and delete the old. (Insert first in order to preserve markers.) */
3330 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3331 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3334 /* Delete the original text. */
3335 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3336 iend
+ decoded_length
, 1);
3338 /* If point was outside of the region, restore it exactly; else just
3339 move to the beginning of the region. */
3340 if (old_pos
>= XFASTINT (end
))
3341 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3342 else if (old_pos
> XFASTINT (beg
))
3343 old_pos
= XFASTINT (beg
);
3344 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3346 return make_number (inserted_chars
);
3349 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3351 doc
: /* Base64-decode STRING and return the result. */)
3352 (Lisp_Object string
)
3355 ptrdiff_t length
, decoded_length
;
3356 Lisp_Object decoded_string
;
3359 CHECK_STRING (string
);
3361 length
= SBYTES (string
);
3362 /* We need to allocate enough room for decoding the text. */
3363 decoded
= SAFE_ALLOCA (length
);
3365 /* The decoded result should be unibyte. */
3366 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3368 if (decoded_length
> length
)
3370 else if (decoded_length
>= 0)
3371 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3373 decoded_string
= Qnil
;
3376 if (!STRINGP (decoded_string
))
3377 error ("Invalid base64 data");
3379 return decoded_string
;
3382 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3383 MULTIBYTE, the decoded result should be in multibyte
3384 form. If NCHARS_RETURN is not NULL, store the number of produced
3385 characters in *NCHARS_RETURN. */
3388 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3389 bool multibyte
, ptrdiff_t *nchars_return
)
3391 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3394 unsigned long value
;
3395 ptrdiff_t nchars
= 0;
3399 /* Process first byte of a quadruplet. */
3401 READ_QUADRUPLET_BYTE (e
-to
);
3405 value
= base64_char_to_value
[c
] << 18;
3407 /* Process second byte of a quadruplet. */
3409 READ_QUADRUPLET_BYTE (-1);
3413 value
|= base64_char_to_value
[c
] << 12;
3415 c
= (unsigned char) (value
>> 16);
3416 if (multibyte
&& c
>= 128)
3417 e
+= BYTE8_STRING (c
, e
);
3422 /* Process third byte of a quadruplet. */
3424 READ_QUADRUPLET_BYTE (-1);
3428 READ_QUADRUPLET_BYTE (-1);
3437 value
|= base64_char_to_value
[c
] << 6;
3439 c
= (unsigned char) (0xff & value
>> 8);
3440 if (multibyte
&& c
>= 128)
3441 e
+= BYTE8_STRING (c
, e
);
3446 /* Process fourth byte of a quadruplet. */
3448 READ_QUADRUPLET_BYTE (-1);
3455 value
|= base64_char_to_value
[c
];
3457 c
= (unsigned char) (0xff & value
);
3458 if (multibyte
&& c
>= 128)
3459 e
+= BYTE8_STRING (c
, e
);
3468 /***********************************************************************
3470 ***** Hash Tables *****
3472 ***********************************************************************/
3474 /* Implemented by gerd@gnu.org. This hash table implementation was
3475 inspired by CMUCL hash tables. */
3479 1. For small tables, association lists are probably faster than
3480 hash tables because they have lower overhead.
3482 For uses of hash tables where the O(1) behavior of table
3483 operations is not a requirement, it might therefore be a good idea
3484 not to hash. Instead, we could just do a linear search in the
3485 key_and_value vector of the hash table. This could be done
3486 if a `:linear-search t' argument is given to make-hash-table. */
3489 /* The list of all weak hash tables. Don't staticpro this one. */
3491 static struct Lisp_Hash_Table
*weak_hash_tables
;
3494 /***********************************************************************
3496 ***********************************************************************/
3499 CHECK_HASH_TABLE (Lisp_Object x
)
3501 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3505 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3507 h
->key_and_value
= key_and_value
;
3510 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3515 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3517 gc_aset (h
->next
, idx
, val
);
3520 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3525 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3527 gc_aset (h
->hash
, idx
, val
);
3530 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3535 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3537 gc_aset (h
->index
, idx
, val
);
3540 /* If OBJ is a Lisp hash table, return a pointer to its struct
3541 Lisp_Hash_Table. Otherwise, signal an error. */
3543 static struct Lisp_Hash_Table
*
3544 check_hash_table (Lisp_Object obj
)
3546 CHECK_HASH_TABLE (obj
);
3547 return XHASH_TABLE (obj
);
3551 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3552 number. A number is "almost" a prime number if it is not divisible
3553 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3556 next_almost_prime (EMACS_INT n
)
3558 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3559 for (n
|= 1; ; n
+= 2)
3560 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3565 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3566 which USED[I] is non-zero. If found at index I in ARGS, set
3567 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3568 0. This function is used to extract a keyword/argument pair from
3569 a DEFUN parameter list. */
3572 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3576 for (i
= 1; i
< nargs
; i
++)
3577 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3588 /* Return a Lisp vector which has the same contents as VEC but has
3589 at least INCR_MIN more entries, where INCR_MIN is positive.
3590 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3591 than NITEMS_MAX. Entries in the resulting
3592 vector that are not copied from VEC are set to nil. */
3595 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3597 struct Lisp_Vector
*v
;
3598 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3599 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3600 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3601 ? nitems_max
: C_language_max
);
3602 eassert (VECTORP (vec
));
3603 eassert (0 < incr_min
&& -1 <= nitems_max
);
3604 old_size
= ASIZE (vec
);
3605 incr_max
= n_max
- old_size
;
3606 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3607 if (incr_max
< incr
)
3608 memory_full (SIZE_MAX
);
3609 new_size
= old_size
+ incr
;
3610 v
= allocate_vector (new_size
);
3611 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3612 memclear (v
->contents
+ old_size
, incr
* word_size
);
3613 XSETVECTOR (vec
, v
);
3618 /***********************************************************************
3620 ***********************************************************************/
3622 static struct hash_table_test hashtest_eq
;
3623 struct hash_table_test hashtest_eql
, hashtest_equal
;
3625 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3626 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3627 KEY2 are the same. */
3630 cmpfn_eql (struct hash_table_test
*ht
,
3634 return (FLOATP (key1
)
3636 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3640 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3641 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3642 KEY2 are the same. */
3645 cmpfn_equal (struct hash_table_test
*ht
,
3649 return !NILP (Fequal (key1
, key2
));
3653 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3654 HASH2 in hash table H using H->user_cmp_function. Value is true
3655 if KEY1 and KEY2 are the same. */
3658 cmpfn_user_defined (struct hash_table_test
*ht
,
3662 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3666 /* Value is a hash code for KEY for use in hash table H which uses
3667 `eq' to compare keys. The hash code returned is guaranteed to fit
3668 in a Lisp integer. */
3671 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3673 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3677 /* Value is a hash code for KEY for use in hash table H which uses
3678 `eql' to compare keys. The hash code returned is guaranteed to fit
3679 in a Lisp integer. */
3682 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3686 hash
= sxhash (key
, 0);
3688 hash
= XHASH (key
) ^ XTYPE (key
);
3692 /* Value is a hash code for KEY for use in hash table H which uses
3693 `equal' to compare keys. The hash code returned is guaranteed to fit
3694 in a Lisp integer. */
3697 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3699 EMACS_UINT hash
= sxhash (key
, 0);
3703 /* Value is a hash code for KEY for use in hash table H which uses as
3704 user-defined function to compare keys. The hash code returned is
3705 guaranteed to fit in a Lisp integer. */
3708 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3710 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3711 return hashfn_eq (ht
, hash
);
3714 /* Allocate basically initialized hash table. */
3716 static struct Lisp_Hash_Table
*
3717 allocate_hash_table (void)
3719 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3720 count
, PVEC_HASH_TABLE
);
3723 /* An upper bound on the size of a hash table index. It must fit in
3724 ptrdiff_t and be a valid Emacs fixnum. */
3725 #define INDEX_SIZE_BOUND \
3726 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3728 /* Create and initialize a new hash table.
3730 TEST specifies the test the hash table will use to compare keys.
3731 It must be either one of the predefined tests `eq', `eql' or
3732 `equal' or a symbol denoting a user-defined test named TEST with
3733 test and hash functions USER_TEST and USER_HASH.
3735 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3737 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3738 new size when it becomes full is computed by adding REHASH_SIZE to
3739 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3740 table's new size is computed by multiplying its old size with
3743 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3744 be resized when the ratio of (number of entries in the table) /
3745 (table size) is >= REHASH_THRESHOLD.
3747 WEAK specifies the weakness of the table. If non-nil, it must be
3748 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3751 make_hash_table (struct hash_table_test test
,
3752 Lisp_Object size
, Lisp_Object rehash_size
,
3753 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3755 struct Lisp_Hash_Table
*h
;
3757 EMACS_INT index_size
, sz
;
3761 /* Preconditions. */
3762 eassert (SYMBOLP (test
.name
));
3763 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3764 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3765 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3766 eassert (FLOATP (rehash_threshold
)
3767 && 0 < XFLOAT_DATA (rehash_threshold
)
3768 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3770 if (XFASTINT (size
) == 0)
3771 size
= make_number (1);
3773 sz
= XFASTINT (size
);
3774 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3775 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3776 ? next_almost_prime (index_float
)
3777 : INDEX_SIZE_BOUND
+ 1);
3778 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3779 error ("Hash table too large");
3781 /* Allocate a table and initialize it. */
3782 h
= allocate_hash_table ();
3784 /* Initialize hash table slots. */
3787 h
->rehash_threshold
= rehash_threshold
;
3788 h
->rehash_size
= rehash_size
;
3790 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3791 h
->hash
= Fmake_vector (size
, Qnil
);
3792 h
->next
= Fmake_vector (size
, Qnil
);
3793 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3795 /* Set up the free list. */
3796 for (i
= 0; i
< sz
- 1; ++i
)
3797 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3798 h
->next_free
= make_number (0);
3800 XSET_HASH_TABLE (table
, h
);
3801 eassert (HASH_TABLE_P (table
));
3802 eassert (XHASH_TABLE (table
) == h
);
3804 /* Maybe add this hash table to the list of all weak hash tables. */
3806 h
->next_weak
= NULL
;
3809 h
->next_weak
= weak_hash_tables
;
3810 weak_hash_tables
= h
;
3817 /* Return a copy of hash table H1. Keys and values are not copied,
3818 only the table itself is. */
3821 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3824 struct Lisp_Hash_Table
*h2
;
3826 h2
= allocate_hash_table ();
3828 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3829 h2
->hash
= Fcopy_sequence (h1
->hash
);
3830 h2
->next
= Fcopy_sequence (h1
->next
);
3831 h2
->index
= Fcopy_sequence (h1
->index
);
3832 XSET_HASH_TABLE (table
, h2
);
3834 /* Maybe add this hash table to the list of all weak hash tables. */
3835 if (!NILP (h2
->weak
))
3837 h2
->next_weak
= weak_hash_tables
;
3838 weak_hash_tables
= h2
;
3845 /* Resize hash table H if it's too full. If H cannot be resized
3846 because it's already too large, throw an error. */
3849 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3851 if (NILP (h
->next_free
))
3853 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3854 EMACS_INT new_size
, index_size
, nsize
;
3858 if (INTEGERP (h
->rehash_size
))
3859 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3862 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3863 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3865 new_size
= float_new_size
;
3866 if (new_size
<= old_size
)
3867 new_size
= old_size
+ 1;
3870 new_size
= INDEX_SIZE_BOUND
+ 1;
3872 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3873 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3874 ? next_almost_prime (index_float
)
3875 : INDEX_SIZE_BOUND
+ 1);
3876 nsize
= max (index_size
, 2 * new_size
);
3877 if (INDEX_SIZE_BOUND
< nsize
)
3878 error ("Hash table too large to resize");
3880 #ifdef ENABLE_CHECKING
3881 if (HASH_TABLE_P (Vpurify_flag
)
3882 && XHASH_TABLE (Vpurify_flag
) == h
)
3883 message ("Growing hash table to: %"pI
"d", new_size
);
3886 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3887 2 * (new_size
- old_size
), -1));
3888 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3889 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3890 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3892 /* Update the free list. Do it so that new entries are added at
3893 the end of the free list. This makes some operations like
3895 for (i
= old_size
; i
< new_size
- 1; ++i
)
3896 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3898 if (!NILP (h
->next_free
))
3900 Lisp_Object last
, next
;
3902 last
= h
->next_free
;
3903 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3907 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3910 XSETFASTINT (h
->next_free
, old_size
);
3913 for (i
= 0; i
< old_size
; ++i
)
3914 if (!NILP (HASH_HASH (h
, i
)))
3916 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3917 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3918 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3919 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3925 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3926 the hash code of KEY. Value is the index of the entry in H
3927 matching KEY, or -1 if not found. */
3930 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3932 EMACS_UINT hash_code
;
3933 ptrdiff_t start_of_bucket
;
3936 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3937 eassert ((hash_code
& ~INTMASK
) == 0);
3941 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3942 idx
= HASH_INDEX (h
, start_of_bucket
);
3946 ptrdiff_t i
= XFASTINT (idx
);
3947 if (EQ (key
, HASH_KEY (h
, i
))
3949 && hash_code
== XUINT (HASH_HASH (h
, i
))
3950 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3952 idx
= HASH_NEXT (h
, i
);
3955 return NILP (idx
) ? -1 : XFASTINT (idx
);
3959 /* Put an entry into hash table H that associates KEY with VALUE.
3960 HASH is a previously computed hash code of KEY.
3961 Value is the index of the entry in H matching KEY. */
3964 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3967 ptrdiff_t start_of_bucket
, i
;
3969 eassert ((hash
& ~INTMASK
) == 0);
3971 /* Increment count after resizing because resizing may fail. */
3972 maybe_resize_hash_table (h
);
3975 /* Store key/value in the key_and_value vector. */
3976 i
= XFASTINT (h
->next_free
);
3977 h
->next_free
= HASH_NEXT (h
, i
);
3978 set_hash_key_slot (h
, i
, key
);
3979 set_hash_value_slot (h
, i
, value
);
3981 /* Remember its hash code. */
3982 set_hash_hash_slot (h
, i
, make_number (hash
));
3984 /* Add new entry to its collision chain. */
3985 start_of_bucket
= hash
% ASIZE (h
->index
);
3986 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3987 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3992 /* Remove the entry matching KEY from hash table H, if there is one. */
3995 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3997 EMACS_UINT hash_code
;
3998 ptrdiff_t start_of_bucket
;
3999 Lisp_Object idx
, prev
;
4001 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4002 eassert ((hash_code
& ~INTMASK
) == 0);
4003 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4004 idx
= HASH_INDEX (h
, start_of_bucket
);
4009 ptrdiff_t i
= XFASTINT (idx
);
4011 if (EQ (key
, HASH_KEY (h
, i
))
4013 && hash_code
== XUINT (HASH_HASH (h
, i
))
4014 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4016 /* Take entry out of collision chain. */
4018 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4020 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4022 /* Clear slots in key_and_value and add the slots to
4024 set_hash_key_slot (h
, i
, Qnil
);
4025 set_hash_value_slot (h
, i
, Qnil
);
4026 set_hash_hash_slot (h
, i
, Qnil
);
4027 set_hash_next_slot (h
, i
, h
->next_free
);
4028 h
->next_free
= make_number (i
);
4030 eassert (h
->count
>= 0);
4036 idx
= HASH_NEXT (h
, i
);
4042 /* Clear hash table H. */
4045 hash_clear (struct Lisp_Hash_Table
*h
)
4049 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4051 for (i
= 0; i
< size
; ++i
)
4053 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4054 set_hash_key_slot (h
, i
, Qnil
);
4055 set_hash_value_slot (h
, i
, Qnil
);
4056 set_hash_hash_slot (h
, i
, Qnil
);
4059 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4060 ASET (h
->index
, i
, Qnil
);
4062 h
->next_free
= make_number (0);
4069 /************************************************************************
4071 ************************************************************************/
4073 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4074 entries from the table that don't survive the current GC.
4075 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4076 true if anything was marked. */
4079 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4081 ptrdiff_t bucket
, n
;
4084 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4087 for (bucket
= 0; bucket
< n
; ++bucket
)
4089 Lisp_Object idx
, next
, prev
;
4091 /* Follow collision chain, removing entries that
4092 don't survive this garbage collection. */
4094 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4096 ptrdiff_t i
= XFASTINT (idx
);
4097 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4098 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4101 if (EQ (h
->weak
, Qkey
))
4102 remove_p
= !key_known_to_survive_p
;
4103 else if (EQ (h
->weak
, Qvalue
))
4104 remove_p
= !value_known_to_survive_p
;
4105 else if (EQ (h
->weak
, Qkey_or_value
))
4106 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4107 else if (EQ (h
->weak
, Qkey_and_value
))
4108 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4112 next
= HASH_NEXT (h
, i
);
4114 if (remove_entries_p
)
4118 /* Take out of collision chain. */
4120 set_hash_index_slot (h
, bucket
, next
);
4122 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4124 /* Add to free list. */
4125 set_hash_next_slot (h
, i
, h
->next_free
);
4128 /* Clear key, value, and hash. */
4129 set_hash_key_slot (h
, i
, Qnil
);
4130 set_hash_value_slot (h
, i
, Qnil
);
4131 set_hash_hash_slot (h
, i
, Qnil
);
4144 /* Make sure key and value survive. */
4145 if (!key_known_to_survive_p
)
4147 mark_object (HASH_KEY (h
, i
));
4151 if (!value_known_to_survive_p
)
4153 mark_object (HASH_VALUE (h
, i
));
4164 /* Remove elements from weak hash tables that don't survive the
4165 current garbage collection. Remove weak tables that don't survive
4166 from Vweak_hash_tables. Called from gc_sweep. */
4168 NO_INLINE
/* For better stack traces */
4170 sweep_weak_hash_tables (void)
4172 struct Lisp_Hash_Table
*h
, *used
, *next
;
4175 /* Mark all keys and values that are in use. Keep on marking until
4176 there is no more change. This is necessary for cases like
4177 value-weak table A containing an entry X -> Y, where Y is used in a
4178 key-weak table B, Z -> Y. If B comes after A in the list of weak
4179 tables, X -> Y might be removed from A, although when looking at B
4180 one finds that it shouldn't. */
4184 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4186 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4187 marked
|= sweep_weak_table (h
, 0);
4192 /* Remove tables and entries that aren't used. */
4193 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4195 next
= h
->next_weak
;
4197 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4199 /* TABLE is marked as used. Sweep its contents. */
4201 sweep_weak_table (h
, 1);
4203 /* Add table to the list of used weak hash tables. */
4204 h
->next_weak
= used
;
4209 weak_hash_tables
= used
;
4214 /***********************************************************************
4215 Hash Code Computation
4216 ***********************************************************************/
4218 /* Maximum depth up to which to dive into Lisp structures. */
4220 #define SXHASH_MAX_DEPTH 3
4222 /* Maximum length up to which to take list and vector elements into
4225 #define SXHASH_MAX_LEN 7
4227 /* Return a hash for string PTR which has length LEN. The hash value
4228 can be any EMACS_UINT value. */
4231 hash_string (char const *ptr
, ptrdiff_t len
)
4233 char const *p
= ptr
;
4234 char const *end
= p
+ len
;
4236 EMACS_UINT hash
= 0;
4241 hash
= sxhash_combine (hash
, c
);
4247 /* Return a hash for string PTR which has length LEN. The hash
4248 code returned is guaranteed to fit in a Lisp integer. */
4251 sxhash_string (char const *ptr
, ptrdiff_t len
)
4253 EMACS_UINT hash
= hash_string (ptr
, len
);
4254 return SXHASH_REDUCE (hash
);
4257 /* Return a hash for the floating point value VAL. */
4260 sxhash_float (double val
)
4262 EMACS_UINT hash
= 0;
4264 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4265 + (sizeof val
% sizeof hash
!= 0))
4269 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4273 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4274 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4275 hash
= sxhash_combine (hash
, u
.word
[i
]);
4276 return SXHASH_REDUCE (hash
);
4279 /* Return a hash for list LIST. DEPTH is the current depth in the
4280 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4283 sxhash_list (Lisp_Object list
, int depth
)
4285 EMACS_UINT hash
= 0;
4288 if (depth
< SXHASH_MAX_DEPTH
)
4290 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4291 list
= XCDR (list
), ++i
)
4293 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4294 hash
= sxhash_combine (hash
, hash2
);
4299 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4300 hash
= sxhash_combine (hash
, hash2
);
4303 return SXHASH_REDUCE (hash
);
4307 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4308 the Lisp structure. */
4311 sxhash_vector (Lisp_Object vec
, int depth
)
4313 EMACS_UINT hash
= ASIZE (vec
);
4316 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4317 for (i
= 0; i
< n
; ++i
)
4319 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4320 hash
= sxhash_combine (hash
, hash2
);
4323 return SXHASH_REDUCE (hash
);
4326 /* Return a hash for bool-vector VECTOR. */
4329 sxhash_bool_vector (Lisp_Object vec
)
4331 EMACS_INT size
= bool_vector_size (vec
);
4332 EMACS_UINT hash
= size
;
4335 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4336 for (i
= 0; i
< n
; ++i
)
4337 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4339 return SXHASH_REDUCE (hash
);
4343 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4344 structure. Value is an unsigned integer clipped to INTMASK. */
4347 sxhash (Lisp_Object obj
, int depth
)
4351 if (depth
> SXHASH_MAX_DEPTH
)
4354 switch (XTYPE (obj
))
4366 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4369 /* This can be everything from a vector to an overlay. */
4370 case Lisp_Vectorlike
:
4372 /* According to the CL HyperSpec, two arrays are equal only if
4373 they are `eq', except for strings and bit-vectors. In
4374 Emacs, this works differently. We have to compare element
4376 hash
= sxhash_vector (obj
, depth
);
4377 else if (BOOL_VECTOR_P (obj
))
4378 hash
= sxhash_bool_vector (obj
);
4380 /* Others are `equal' if they are `eq', so let's take their
4386 hash
= sxhash_list (obj
, depth
);
4390 hash
= sxhash_float (XFLOAT_DATA (obj
));
4402 /***********************************************************************
4404 ***********************************************************************/
4407 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4408 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4411 EMACS_UINT hash
= sxhash (obj
, 0);
4412 return make_number (hash
);
4416 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4417 doc
: /* Create and return a new hash table.
4419 Arguments are specified as keyword/argument pairs. The following
4420 arguments are defined:
4422 :test TEST -- TEST must be a symbol that specifies how to compare
4423 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4424 `equal'. User-supplied test and hash functions can be specified via
4425 `define-hash-table-test'.
4427 :size SIZE -- A hint as to how many elements will be put in the table.
4430 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4431 fills up. If REHASH-SIZE is an integer, increase the size by that
4432 amount. If it is a float, it must be > 1.0, and the new size is the
4433 old size multiplied by that factor. Default is 1.5.
4435 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4436 Resize the hash table when the ratio (number of entries / table size)
4437 is greater than or equal to THRESHOLD. Default is 0.8.
4439 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4440 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4441 returned is a weak table. Key/value pairs are removed from a weak
4442 hash table when there are no non-weak references pointing to their
4443 key, value, one of key or value, or both key and value, depending on
4444 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4447 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4448 (ptrdiff_t nargs
, Lisp_Object
*args
)
4450 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4451 struct hash_table_test testdesc
;
4455 /* The vector `used' is used to keep track of arguments that
4456 have been consumed. */
4457 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4458 memset (used
, 0, nargs
* sizeof *used
);
4460 /* See if there's a `:test TEST' among the arguments. */
4461 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4462 test
= i
? args
[i
] : Qeql
;
4464 testdesc
= hashtest_eq
;
4465 else if (EQ (test
, Qeql
))
4466 testdesc
= hashtest_eql
;
4467 else if (EQ (test
, Qequal
))
4468 testdesc
= hashtest_equal
;
4471 /* See if it is a user-defined test. */
4474 prop
= Fget (test
, Qhash_table_test
);
4475 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4476 signal_error ("Invalid hash table test", test
);
4477 testdesc
.name
= test
;
4478 testdesc
.user_cmp_function
= XCAR (prop
);
4479 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4480 testdesc
.hashfn
= hashfn_user_defined
;
4481 testdesc
.cmpfn
= cmpfn_user_defined
;
4484 /* See if there's a `:size SIZE' argument. */
4485 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4486 size
= i
? args
[i
] : Qnil
;
4488 size
= make_number (DEFAULT_HASH_SIZE
);
4489 else if (!INTEGERP (size
) || XINT (size
) < 0)
4490 signal_error ("Invalid hash table size", size
);
4492 /* Look for `:rehash-size SIZE'. */
4493 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4494 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4495 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4496 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4497 signal_error ("Invalid hash table rehash size", rehash_size
);
4499 /* Look for `:rehash-threshold THRESHOLD'. */
4500 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4501 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4502 if (! (FLOATP (rehash_threshold
)
4503 && 0 < XFLOAT_DATA (rehash_threshold
)
4504 && XFLOAT_DATA (rehash_threshold
) <= 1))
4505 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4507 /* Look for `:weakness WEAK'. */
4508 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4509 weak
= i
? args
[i
] : Qnil
;
4511 weak
= Qkey_and_value
;
4514 && !EQ (weak
, Qvalue
)
4515 && !EQ (weak
, Qkey_or_value
)
4516 && !EQ (weak
, Qkey_and_value
))
4517 signal_error ("Invalid hash table weakness", weak
);
4519 /* Now, all args should have been used up, or there's a problem. */
4520 for (i
= 0; i
< nargs
; ++i
)
4522 signal_error ("Invalid argument list", args
[i
]);
4525 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4529 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4530 doc
: /* Return a copy of hash table TABLE. */)
4533 return copy_hash_table (check_hash_table (table
));
4537 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4538 doc
: /* Return the number of elements in TABLE. */)
4541 return make_number (check_hash_table (table
)->count
);
4545 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4546 Shash_table_rehash_size
, 1, 1, 0,
4547 doc
: /* Return the current rehash size of TABLE. */)
4550 return check_hash_table (table
)->rehash_size
;
4554 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4555 Shash_table_rehash_threshold
, 1, 1, 0,
4556 doc
: /* Return the current rehash threshold of TABLE. */)
4559 return check_hash_table (table
)->rehash_threshold
;
4563 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4564 doc
: /* Return the size of TABLE.
4565 The size can be used as an argument to `make-hash-table' to create
4566 a hash table than can hold as many elements as TABLE holds
4567 without need for resizing. */)
4570 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4571 return make_number (HASH_TABLE_SIZE (h
));
4575 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4576 doc
: /* Return the test TABLE uses. */)
4579 return check_hash_table (table
)->test
.name
;
4583 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4585 doc
: /* Return the weakness of TABLE. */)
4588 return check_hash_table (table
)->weak
;
4592 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4593 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4596 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4600 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4601 doc
: /* Clear hash table TABLE and return it. */)
4604 hash_clear (check_hash_table (table
));
4605 /* Be compatible with XEmacs. */
4610 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4611 doc
: /* Look up KEY in TABLE and return its associated value.
4612 If KEY is not found, return DFLT which defaults to nil. */)
4613 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4615 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4616 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4617 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4621 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4622 doc
: /* Associate KEY with VALUE in hash table TABLE.
4623 If KEY is already present in table, replace its current value with
4624 VALUE. In any case, return VALUE. */)
4625 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4627 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4631 i
= hash_lookup (h
, key
, &hash
);
4633 set_hash_value_slot (h
, i
, value
);
4635 hash_put (h
, key
, value
, hash
);
4641 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4642 doc
: /* Remove KEY from TABLE. */)
4643 (Lisp_Object key
, Lisp_Object table
)
4645 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4646 hash_remove_from_table (h
, key
);
4651 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4652 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4653 FUNCTION is called with two arguments, KEY and VALUE.
4654 `maphash' always returns nil. */)
4655 (Lisp_Object function
, Lisp_Object table
)
4657 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4659 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4660 if (!NILP (HASH_HASH (h
, i
)))
4661 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4667 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4668 Sdefine_hash_table_test
, 3, 3, 0,
4669 doc
: /* Define a new hash table test with name NAME, a symbol.
4671 In hash tables created with NAME specified as test, use TEST to
4672 compare keys, and HASH for computing hash codes of keys.
4674 TEST must be a function taking two arguments and returning non-nil if
4675 both arguments are the same. HASH must be a function taking one
4676 argument and returning an object that is the hash code of the argument.
4677 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4678 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4679 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4681 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4686 /************************************************************************
4687 MD5, SHA-1, and SHA-2
4688 ************************************************************************/
4695 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4698 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4699 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4703 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4704 register EMACS_INT b
, e
;
4705 register struct buffer
*bp
;
4708 void *(*hash_func
) (const char *, size_t, void *);
4711 CHECK_SYMBOL (algorithm
);
4713 if (STRINGP (object
))
4715 if (NILP (coding_system
))
4717 /* Decide the coding-system to encode the data with. */
4719 if (STRING_MULTIBYTE (object
))
4720 /* use default, we can't guess correct value */
4721 coding_system
= preferred_coding_system ();
4723 coding_system
= Qraw_text
;
4726 if (NILP (Fcoding_system_p (coding_system
)))
4728 /* Invalid coding system. */
4730 if (!NILP (noerror
))
4731 coding_system
= Qraw_text
;
4733 xsignal1 (Qcoding_system_error
, coding_system
);
4736 if (STRING_MULTIBYTE (object
))
4737 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4739 size
= SCHARS (object
);
4740 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4742 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4743 end_byte
= (end_char
== size
4745 : string_char_to_byte (object
, end_char
));
4749 struct buffer
*prev
= current_buffer
;
4751 record_unwind_current_buffer ();
4753 CHECK_BUFFER (object
);
4755 bp
= XBUFFER (object
);
4756 set_buffer_internal (bp
);
4762 CHECK_NUMBER_COERCE_MARKER (start
);
4770 CHECK_NUMBER_COERCE_MARKER (end
);
4775 temp
= b
, b
= e
, e
= temp
;
4777 if (!(BEGV
<= b
&& e
<= ZV
))
4778 args_out_of_range (start
, end
);
4780 if (NILP (coding_system
))
4782 /* Decide the coding-system to encode the data with.
4783 See fileio.c:Fwrite-region */
4785 if (!NILP (Vcoding_system_for_write
))
4786 coding_system
= Vcoding_system_for_write
;
4789 bool force_raw_text
= 0;
4791 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4792 if (NILP (coding_system
)
4793 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4795 coding_system
= Qnil
;
4796 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4800 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4802 /* Check file-coding-system-alist. */
4803 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4804 Qwrite_region
, start
, end
,
4805 Fbuffer_file_name (object
));
4806 if (CONSP (val
) && !NILP (XCDR (val
)))
4807 coding_system
= XCDR (val
);
4810 if (NILP (coding_system
)
4811 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4813 /* If we still have not decided a coding system, use the
4814 default value of buffer-file-coding-system. */
4815 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4819 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4820 /* Confirm that VAL can surely encode the current region. */
4821 coding_system
= call4 (Vselect_safe_coding_system_function
,
4822 make_number (b
), make_number (e
),
4823 coding_system
, Qnil
);
4826 coding_system
= Qraw_text
;
4829 if (NILP (Fcoding_system_p (coding_system
)))
4831 /* Invalid coding system. */
4833 if (!NILP (noerror
))
4834 coding_system
= Qraw_text
;
4836 xsignal1 (Qcoding_system_error
, coding_system
);
4840 object
= make_buffer_string (b
, e
, 0);
4841 set_buffer_internal (prev
);
4842 /* Discard the unwind protect for recovering the current
4846 if (STRING_MULTIBYTE (object
))
4847 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4849 end_byte
= SBYTES (object
);
4852 if (EQ (algorithm
, Qmd5
))
4854 digest_size
= MD5_DIGEST_SIZE
;
4855 hash_func
= md5_buffer
;
4857 else if (EQ (algorithm
, Qsha1
))
4859 digest_size
= SHA1_DIGEST_SIZE
;
4860 hash_func
= sha1_buffer
;
4862 else if (EQ (algorithm
, Qsha224
))
4864 digest_size
= SHA224_DIGEST_SIZE
;
4865 hash_func
= sha224_buffer
;
4867 else if (EQ (algorithm
, Qsha256
))
4869 digest_size
= SHA256_DIGEST_SIZE
;
4870 hash_func
= sha256_buffer
;
4872 else if (EQ (algorithm
, Qsha384
))
4874 digest_size
= SHA384_DIGEST_SIZE
;
4875 hash_func
= sha384_buffer
;
4877 else if (EQ (algorithm
, Qsha512
))
4879 digest_size
= SHA512_DIGEST_SIZE
;
4880 hash_func
= sha512_buffer
;
4883 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4885 /* allocate 2 x digest_size so that it can be re-used to hold the
4887 digest
= make_uninit_string (digest_size
* 2);
4889 hash_func (SSDATA (object
) + start_byte
,
4890 end_byte
- start_byte
,
4895 unsigned char *p
= SDATA (digest
);
4896 for (i
= digest_size
- 1; i
>= 0; i
--)
4898 static char const hexdigit
[16] = "0123456789abcdef";
4900 p
[2 * i
] = hexdigit
[p_i
>> 4];
4901 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4906 return make_unibyte_string (SSDATA (digest
), digest_size
);
4909 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4910 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4912 A message digest is a cryptographic checksum of a document, and the
4913 algorithm to calculate it is defined in RFC 1321.
4915 The two optional arguments START and END are character positions
4916 specifying for which part of OBJECT the message digest should be
4917 computed. If nil or omitted, the digest is computed for the whole
4920 The MD5 message digest is computed from the result of encoding the
4921 text in a coding system, not directly from the internal Emacs form of
4922 the text. The optional fourth argument CODING-SYSTEM specifies which
4923 coding system to encode the text with. It should be the same coding
4924 system that you used or will use when actually writing the text into a
4927 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4928 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4929 system would be chosen by default for writing this text into a file.
4931 If OBJECT is a string, the most preferred coding system (see the
4932 command `prefer-coding-system') is used.
4934 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4935 guesswork fails. Normally, an error is signaled in such case. */)
4936 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4938 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4941 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4942 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4943 ALGORITHM is a symbol specifying the hash to use:
4944 md5, sha1, sha224, sha256, sha384 or sha512.
4946 The two optional arguments START and END are positions specifying for
4947 which part of OBJECT to compute the hash. If nil or omitted, uses the
4950 If BINARY is non-nil, returns a string in binary form. */)
4951 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4953 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4959 DEFSYM (Qmd5
, "md5");
4960 DEFSYM (Qsha1
, "sha1");
4961 DEFSYM (Qsha224
, "sha224");
4962 DEFSYM (Qsha256
, "sha256");
4963 DEFSYM (Qsha384
, "sha384");
4964 DEFSYM (Qsha512
, "sha512");
4966 /* Hash table stuff. */
4967 DEFSYM (Qhash_table_p
, "hash-table-p");
4969 DEFSYM (Qeql
, "eql");
4970 DEFSYM (Qequal
, "equal");
4971 DEFSYM (QCtest
, ":test");
4972 DEFSYM (QCsize
, ":size");
4973 DEFSYM (QCrehash_size
, ":rehash-size");
4974 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4975 DEFSYM (QCweakness
, ":weakness");
4976 DEFSYM (Qkey
, "key");
4977 DEFSYM (Qvalue
, "value");
4978 DEFSYM (Qhash_table_test
, "hash-table-test");
4979 DEFSYM (Qkey_or_value
, "key-or-value");
4980 DEFSYM (Qkey_and_value
, "key-and-value");
4983 defsubr (&Smake_hash_table
);
4984 defsubr (&Scopy_hash_table
);
4985 defsubr (&Shash_table_count
);
4986 defsubr (&Shash_table_rehash_size
);
4987 defsubr (&Shash_table_rehash_threshold
);
4988 defsubr (&Shash_table_size
);
4989 defsubr (&Shash_table_test
);
4990 defsubr (&Shash_table_weakness
);
4991 defsubr (&Shash_table_p
);
4992 defsubr (&Sclrhash
);
4993 defsubr (&Sgethash
);
4994 defsubr (&Sputhash
);
4995 defsubr (&Sremhash
);
4996 defsubr (&Smaphash
);
4997 defsubr (&Sdefine_hash_table_test
);
4999 DEFSYM (Qstring_lessp
, "string-lessp");
5000 DEFSYM (Qprovide
, "provide");
5001 DEFSYM (Qrequire
, "require");
5002 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5003 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5004 DEFSYM (Qwidget_type
, "widget-type");
5006 staticpro (&string_char_byte_cache_string
);
5007 string_char_byte_cache_string
= Qnil
;
5009 require_nesting_list
= Qnil
;
5010 staticpro (&require_nesting_list
);
5012 Fset (Qyes_or_no_p_history
, Qnil
);
5014 DEFVAR_LISP ("features", Vfeatures
,
5015 doc
: /* A list of symbols which are the features of the executing Emacs.
5016 Used by `featurep' and `require', and altered by `provide'. */);
5017 Vfeatures
= list1 (Qemacs
);
5018 DEFSYM (Qsubfeatures
, "subfeatures");
5019 DEFSYM (Qfuncall
, "funcall");
5021 #ifdef HAVE_LANGINFO_CODESET
5022 DEFSYM (Qcodeset
, "codeset");
5023 DEFSYM (Qdays
, "days");
5024 DEFSYM (Qmonths
, "months");
5025 DEFSYM (Qpaper
, "paper");
5026 #endif /* HAVE_LANGINFO_CODESET */
5028 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5029 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5030 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5031 invoked by mouse clicks and mouse menu items.
5033 On some platforms, file selection dialogs are also enabled if this is
5037 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5038 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5039 This applies to commands from menus and tool bar buttons even when
5040 they are initiated from the keyboard. If `use-dialog-box' is nil,
5041 that disables the use of a file dialog, regardless of the value of
5043 use_file_dialog
= 1;
5045 defsubr (&Sidentity
);
5048 defsubr (&Ssafe_length
);
5049 defsubr (&Sstring_bytes
);
5050 defsubr (&Sstring_equal
);
5051 defsubr (&Scompare_strings
);
5052 defsubr (&Sstring_lessp
);
5053 defsubr (&Sstring_collate_lessp
);
5054 defsubr (&Sstring_collate_equalp
);
5057 defsubr (&Svconcat
);
5058 defsubr (&Scopy_sequence
);
5059 defsubr (&Sstring_make_multibyte
);
5060 defsubr (&Sstring_make_unibyte
);
5061 defsubr (&Sstring_as_multibyte
);
5062 defsubr (&Sstring_as_unibyte
);
5063 defsubr (&Sstring_to_multibyte
);
5064 defsubr (&Sstring_to_unibyte
);
5065 defsubr (&Scopy_alist
);
5066 defsubr (&Ssubstring
);
5067 defsubr (&Ssubstring_no_properties
);
5080 defsubr (&Snreverse
);
5081 defsubr (&Sreverse
);
5083 defsubr (&Splist_get
);
5085 defsubr (&Splist_put
);
5087 defsubr (&Slax_plist_get
);
5088 defsubr (&Slax_plist_put
);
5091 defsubr (&Sequal_including_properties
);
5092 defsubr (&Sfillarray
);
5093 defsubr (&Sclear_string
);
5097 defsubr (&Smapconcat
);
5098 defsubr (&Syes_or_no_p
);
5099 defsubr (&Sload_average
);
5100 defsubr (&Sfeaturep
);
5101 defsubr (&Srequire
);
5102 defsubr (&Sprovide
);
5103 defsubr (&Splist_member
);
5104 defsubr (&Swidget_put
);
5105 defsubr (&Swidget_get
);
5106 defsubr (&Swidget_apply
);
5107 defsubr (&Sbase64_encode_region
);
5108 defsubr (&Sbase64_decode_region
);
5109 defsubr (&Sbase64_encode_string
);
5110 defsubr (&Sbase64_decode_string
);
5112 defsubr (&Ssecure_hash
);
5113 defsubr (&Slocale_info
);
5115 hashtest_eq
.name
= Qeq
;
5116 hashtest_eq
.user_hash_function
= Qnil
;
5117 hashtest_eq
.user_cmp_function
= Qnil
;
5118 hashtest_eq
.cmpfn
= 0;
5119 hashtest_eq
.hashfn
= hashfn_eq
;
5121 hashtest_eql
.name
= Qeql
;
5122 hashtest_eql
.user_hash_function
= Qnil
;
5123 hashtest_eql
.user_cmp_function
= Qnil
;
5124 hashtest_eql
.cmpfn
= cmpfn_eql
;
5125 hashtest_eql
.hashfn
= hashfn_eql
;
5127 hashtest_equal
.name
= Qequal
;
5128 hashtest_equal
.user_hash_function
= Qnil
;
5129 hashtest_equal
.user_cmp_function
= Qnil
;
5130 hashtest_equal
.cmpfn
= cmpfn_equal
;
5131 hashtest_equal
.hashfn
= hashfn_equal
;