1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2016 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 (at
11 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"
36 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
37 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
39 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
40 Lisp_Object
[], Lisp_Object
[]);
42 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
44 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
45 doc
: /* Return the argument unchanged. */
52 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
53 doc
: /* Return a pseudo-random number.
54 All integers representable in Lisp, i.e. between `most-negative-fixnum'
55 and `most-positive-fixnum', inclusive, are equally likely.
57 With positive integer LIMIT, return random number in interval [0,LIMIT).
58 With argument t, set the random number seed from the system's entropy
59 pool if available, otherwise from less-random volatile data such as the time.
60 With a string argument, set the seed based on the string's contents.
61 Other values of LIMIT are ignored.
63 See Info node `(elisp)Random Numbers' for more details. */)
70 else if (STRINGP (limit
))
71 seed_random (SSDATA (limit
), SBYTES (limit
));
74 if (INTEGERP (limit
) && 0 < XINT (limit
))
77 /* Return the remainder, except reject the rare case where
78 get_random returns a number so close to INTMASK that the
79 remainder isn't random. */
80 EMACS_INT remainder
= val
% XINT (limit
);
81 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
82 return make_number (remainder
);
85 return make_number (val
);
88 /* Heuristic on how many iterations of a tight loop can be safely done
89 before it's time to do a QUIT. This must be a power of 2. */
90 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
92 /* Random data-structure functions. */
95 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
97 CHECK_TYPE (NILP (x
), Qlistp
, y
);
100 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
101 doc
: /* Return the length of vector, list or string SEQUENCE.
102 A byte-code function object is also allowed.
103 If the string contains multibyte characters, this is not necessarily
104 the number of bytes in the string; it is the number of characters.
105 To get the number of bytes, use `string-bytes'. */)
106 (register Lisp_Object sequence
)
108 register Lisp_Object val
;
110 if (STRINGP (sequence
))
111 XSETFASTINT (val
, SCHARS (sequence
));
112 else if (VECTORP (sequence
))
113 XSETFASTINT (val
, ASIZE (sequence
));
114 else if (CHAR_TABLE_P (sequence
))
115 XSETFASTINT (val
, MAX_CHAR
);
116 else if (BOOL_VECTOR_P (sequence
))
117 XSETFASTINT (val
, bool_vector_size (sequence
));
118 else if (COMPILEDP (sequence
))
119 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
120 else if (CONSP (sequence
))
127 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
129 if (MOST_POSITIVE_FIXNUM
< i
)
130 error ("List too long");
133 sequence
= XCDR (sequence
);
135 while (CONSP (sequence
));
137 CHECK_LIST_END (sequence
, sequence
);
139 val
= make_number (i
);
141 else if (NILP (sequence
))
142 XSETFASTINT (val
, 0);
144 wrong_type_argument (Qsequencep
, sequence
);
149 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
150 doc
: /* Return the length of a list, but avoid error or infinite loop.
151 This function never gets an error. If LIST is not really a list,
152 it returns 0. If LIST is circular, it returns a finite value
153 which is at least the number of distinct elements. */)
156 Lisp_Object tail
, halftail
;
161 return make_number (0);
163 /* halftail is used to detect circular lists. */
164 for (tail
= halftail
= list
; ; )
169 if (EQ (tail
, halftail
))
172 if ((lolen
& 1) == 0)
174 halftail
= XCDR (halftail
);
175 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
179 hilen
+= UINTMAX_MAX
+ 1.0;
184 /* If the length does not fit into a fixnum, return a float.
185 On all known practical machines this returns an upper bound on
187 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
190 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
191 doc
: /* Return the number of bytes in STRING.
192 If STRING is multibyte, this may be greater than the length of STRING. */)
195 CHECK_STRING (string
);
196 return make_number (SBYTES (string
));
199 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
200 doc
: /* Return t if two strings have identical contents.
201 Case is significant, but text properties are ignored.
202 Symbols are also allowed; their print names are used instead. */)
203 (register Lisp_Object s1
, Lisp_Object s2
)
206 s1
= SYMBOL_NAME (s1
);
208 s2
= SYMBOL_NAME (s2
);
212 if (SCHARS (s1
) != SCHARS (s2
)
213 || SBYTES (s1
) != SBYTES (s2
)
214 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
219 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
220 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
221 The arguments START1, END1, START2, and END2, if non-nil, are
222 positions specifying which parts of STR1 or STR2 to compare. In
223 string STR1, compare the part between START1 (inclusive) and END1
224 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
225 the string; if END1 is nil, it defaults to the length of the string.
226 Likewise, in string STR2, compare the part between START2 and END2.
227 Like in `substring', negative values are counted from the end.
229 The strings are compared by the numeric values of their characters.
230 For instance, STR1 is "less than" STR2 if its first differing
231 character has a smaller numeric value. If IGNORE-CASE is non-nil,
232 characters are converted to lower-case before comparing them. Unibyte
233 strings are converted to multibyte for comparison.
235 The value is t if the strings (or specified portions) match.
236 If string STR1 is less, the value is a negative number N;
237 - 1 - N is the number of characters that match at the beginning.
238 If string STR1 is greater, the value is a positive number N;
239 N - 1 is the number of characters that match at the beginning. */)
240 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
241 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
243 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
248 /* For backward compatibility, silently bring too-large positive end
249 values into range. */
250 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
251 end1
= make_number (SCHARS (str1
));
252 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
253 end2
= make_number (SCHARS (str2
));
255 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
256 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
261 i1_byte
= string_char_to_byte (str1
, i1
);
262 i2_byte
= string_char_to_byte (str2
, i2
);
264 while (i1
< to1
&& i2
< to2
)
266 /* When we find a mismatch, we must compare the
267 characters, not just the bytes. */
270 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
271 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
276 if (! NILP (ignore_case
))
278 c1
= XINT (Fupcase (make_number (c1
)));
279 c2
= XINT (Fupcase (make_number (c2
)));
285 /* Note that I1 has already been incremented
286 past the character that we are comparing;
287 hence we don't add or subtract 1 here. */
289 return make_number (- i1
+ from1
);
291 return make_number (i1
- from1
);
295 return make_number (i1
- from1
+ 1);
297 return make_number (- i1
+ from1
- 1);
302 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
303 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
305 Symbols are also allowed; their print names are used instead. */)
306 (register Lisp_Object string1
, Lisp_Object string2
)
308 register ptrdiff_t end
;
309 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
311 if (SYMBOLP (string1
))
312 string1
= SYMBOL_NAME (string1
);
313 if (SYMBOLP (string2
))
314 string2
= SYMBOL_NAME (string2
);
315 CHECK_STRING (string1
);
316 CHECK_STRING (string2
);
318 i1
= i1_byte
= i2
= i2_byte
= 0;
320 end
= SCHARS (string1
);
321 if (end
> SCHARS (string2
))
322 end
= SCHARS (string2
);
326 /* When we find a mismatch, we must compare the
327 characters, not just the bytes. */
330 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
331 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
334 return c1
< c2
? Qt
: Qnil
;
336 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
339 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
340 doc
: /* Return t if first arg string is less than second in collation order.
341 Symbols are also allowed; their print names are used instead.
343 This function obeys the conventions for collation order in your
344 locale settings. For example, punctuation and whitespace characters
345 might be considered less significant for sorting:
347 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
348 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
350 The optional argument LOCALE, a string, overrides the setting of your
351 current locale identifier for collation. The value is system
352 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
353 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
355 If IGNORE-CASE is non-nil, characters are converted to lower-case
356 before comparing them.
358 To emulate Unicode-compliant collation on MS-Windows systems,
359 bind `w32-collate-ignore-punctuation' to a non-nil value, since
360 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
362 If your system does not support a locale environment, this function
363 behaves like `string-lessp'. */)
364 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
366 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
367 /* Check parameters. */
369 s1
= SYMBOL_NAME (s1
);
371 s2
= SYMBOL_NAME (s2
);
375 CHECK_STRING (locale
);
377 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
379 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
380 return Fstring_lessp (s1
, s2
);
381 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
384 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
385 doc
: /* Return t if two strings have identical contents.
386 Symbols are also allowed; their print names are used instead.
388 This function obeys the conventions for collation order in your locale
389 settings. For example, characters with different coding points but
390 the same meaning might be considered as equal, like different grave
391 accent Unicode characters:
393 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
396 The optional argument LOCALE, a string, overrides the setting of your
397 current locale identifier for collation. The value is system
398 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
399 while it would be \"enu_USA.1252\" on MS Windows systems.
401 If IGNORE-CASE is non-nil, characters are converted to lower-case
402 before comparing them.
404 To emulate Unicode-compliant collation on MS-Windows systems,
405 bind `w32-collate-ignore-punctuation' to a non-nil value, since
406 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
408 If your system does not support a locale environment, this function
409 behaves like `string-equal'.
411 Do NOT use this function to compare file names for equality, only
412 for sorting them. */)
413 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
415 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
416 /* Check parameters. */
418 s1
= SYMBOL_NAME (s1
);
420 s2
= SYMBOL_NAME (s2
);
424 CHECK_STRING (locale
);
426 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
428 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
429 return Fstring_equal (s1
, s2
);
430 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
433 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
434 enum Lisp_Type target_type
, bool last_special
);
438 concat2 (Lisp_Object s1
, Lisp_Object s2
)
440 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
445 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
447 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
450 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
451 doc
: /* Concatenate all the arguments and make the result a list.
452 The result is a list whose elements are the elements of all the arguments.
453 Each argument may be a list, vector or string.
454 The last argument is not copied, just used as the tail of the new list.
455 usage: (append &rest SEQUENCES) */)
456 (ptrdiff_t nargs
, Lisp_Object
*args
)
458 return concat (nargs
, args
, Lisp_Cons
, 1);
461 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
462 doc
: /* Concatenate all the arguments and make the result a string.
463 The result is a string whose elements are the elements of all the arguments.
464 Each argument may be a string or a list or vector of characters (integers).
465 usage: (concat &rest SEQUENCES) */)
466 (ptrdiff_t nargs
, Lisp_Object
*args
)
468 return concat (nargs
, args
, Lisp_String
, 0);
471 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
472 doc
: /* Concatenate all the arguments and make the result a vector.
473 The result is a vector whose elements are the elements of all the arguments.
474 Each argument may be a list, vector or string.
475 usage: (vconcat &rest SEQUENCES) */)
476 (ptrdiff_t nargs
, Lisp_Object
*args
)
478 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
482 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
483 doc
: /* Return a copy of a list, vector, string or char-table.
484 The elements of a list or vector are not copied; they are shared
485 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
492 return copy_char_table (arg
);
495 if (BOOL_VECTOR_P (arg
))
497 EMACS_INT nbits
= bool_vector_size (arg
);
498 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
499 Lisp_Object val
= make_uninit_bool_vector (nbits
);
500 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
504 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
505 wrong_type_argument (Qsequencep
, arg
);
507 return concat (1, &arg
, XTYPE (arg
), 0);
510 /* This structure holds information of an argument of `concat' that is
511 a string and has text properties to be copied. */
514 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
515 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
516 ptrdiff_t to
; /* refer to VAL (the target string) */
520 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
521 enum Lisp_Type target_type
, bool last_special
)
527 ptrdiff_t toindex_byte
= 0;
528 EMACS_INT result_len
;
529 EMACS_INT result_len_byte
;
531 Lisp_Object last_tail
;
534 /* When we make a multibyte string, we can't copy text properties
535 while concatenating each string because the length of resulting
536 string can't be decided until we finish the whole concatenation.
537 So, we record strings that have text properties to be copied
538 here, and copy the text properties after the concatenation. */
539 struct textprop_rec
*textprops
= NULL
;
540 /* Number of elements in textprops. */
541 ptrdiff_t num_textprops
= 0;
546 /* In append, the last arg isn't treated like the others */
547 if (last_special
&& nargs
> 0)
550 last_tail
= args
[nargs
];
555 /* Check each argument. */
556 for (argnum
= 0; argnum
< nargs
; argnum
++)
559 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
560 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
561 wrong_type_argument (Qsequencep
, this);
564 /* Compute total length in chars of arguments in RESULT_LEN.
565 If desired output is a string, also compute length in bytes
566 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
567 whether the result should be a multibyte string. */
571 for (argnum
= 0; argnum
< nargs
; argnum
++)
575 len
= XFASTINT (Flength (this));
576 if (target_type
== Lisp_String
)
578 /* We must count the number of bytes needed in the string
579 as well as the number of characters. */
583 ptrdiff_t this_len_byte
;
585 if (VECTORP (this) || COMPILEDP (this))
586 for (i
= 0; i
< len
; i
++)
589 CHECK_CHARACTER (ch
);
591 this_len_byte
= CHAR_BYTES (c
);
592 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
594 result_len_byte
+= this_len_byte
;
595 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
598 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
599 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
600 else if (CONSP (this))
601 for (; CONSP (this); this = XCDR (this))
604 CHECK_CHARACTER (ch
);
606 this_len_byte
= CHAR_BYTES (c
);
607 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
609 result_len_byte
+= this_len_byte
;
610 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
613 else if (STRINGP (this))
615 if (STRING_MULTIBYTE (this))
618 this_len_byte
= SBYTES (this);
621 this_len_byte
= count_size_as_multibyte (SDATA (this),
623 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
625 result_len_byte
+= this_len_byte
;
630 if (MOST_POSITIVE_FIXNUM
< result_len
)
631 memory_full (SIZE_MAX
);
634 if (! some_multibyte
)
635 result_len_byte
= result_len
;
637 /* Create the output object. */
638 if (target_type
== Lisp_Cons
)
639 val
= Fmake_list (make_number (result_len
), Qnil
);
640 else if (target_type
== Lisp_Vectorlike
)
641 val
= Fmake_vector (make_number (result_len
), Qnil
);
642 else if (some_multibyte
)
643 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
645 val
= make_uninit_string (result_len
);
647 /* In `append', if all but last arg are nil, return last arg. */
648 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
651 /* Copy the contents of the args into the result. */
653 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
655 toindex
= 0, toindex_byte
= 0;
659 SAFE_NALLOCA (textprops
, 1, nargs
);
661 for (argnum
= 0; argnum
< nargs
; argnum
++)
664 ptrdiff_t thisleni
= 0;
665 register ptrdiff_t thisindex
= 0;
666 register ptrdiff_t thisindex_byte
= 0;
670 thislen
= Flength (this), thisleni
= XINT (thislen
);
672 /* Between strings of the same kind, copy fast. */
673 if (STRINGP (this) && STRINGP (val
)
674 && STRING_MULTIBYTE (this) == some_multibyte
)
676 ptrdiff_t thislen_byte
= SBYTES (this);
678 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
679 if (string_intervals (this))
681 textprops
[num_textprops
].argnum
= argnum
;
682 textprops
[num_textprops
].from
= 0;
683 textprops
[num_textprops
++].to
= toindex
;
685 toindex_byte
+= thislen_byte
;
688 /* Copy a single-byte string to a multibyte string. */
689 else if (STRINGP (this) && STRINGP (val
))
691 if (string_intervals (this))
693 textprops
[num_textprops
].argnum
= argnum
;
694 textprops
[num_textprops
].from
= 0;
695 textprops
[num_textprops
++].to
= toindex
;
697 toindex_byte
+= copy_text (SDATA (this),
698 SDATA (val
) + toindex_byte
,
699 SCHARS (this), 0, 1);
703 /* Copy element by element. */
706 register Lisp_Object elt
;
708 /* Fetch next element of `this' arg into `elt', or break if
709 `this' is exhausted. */
710 if (NILP (this)) break;
712 elt
= XCAR (this), this = XCDR (this);
713 else if (thisindex
>= thisleni
)
715 else if (STRINGP (this))
718 if (STRING_MULTIBYTE (this))
719 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
724 c
= SREF (this, thisindex
); thisindex
++;
725 if (some_multibyte
&& !ASCII_CHAR_P (c
))
726 c
= BYTE8_TO_CHAR (c
);
728 XSETFASTINT (elt
, c
);
730 else if (BOOL_VECTOR_P (this))
732 elt
= bool_vector_ref (this, thisindex
);
737 elt
= AREF (this, thisindex
);
741 /* Store this element into the result. */
748 else if (VECTORP (val
))
750 ASET (val
, toindex
, elt
);
756 CHECK_CHARACTER (elt
);
759 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
761 SSET (val
, toindex_byte
++, c
);
767 XSETCDR (prev
, last_tail
);
769 if (num_textprops
> 0)
772 ptrdiff_t last_to_end
= -1;
774 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
776 this = args
[textprops
[argnum
].argnum
];
777 props
= text_property_list (this,
779 make_number (SCHARS (this)),
781 /* If successive arguments have properties, be sure that the
782 value of `composition' property be the copy. */
783 if (last_to_end
== textprops
[argnum
].to
)
784 make_composition_value_copy (props
);
785 add_text_properties_from_list (val
, props
,
786 make_number (textprops
[argnum
].to
));
787 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
795 static Lisp_Object string_char_byte_cache_string
;
796 static ptrdiff_t string_char_byte_cache_charpos
;
797 static ptrdiff_t string_char_byte_cache_bytepos
;
800 clear_string_char_byte_cache (void)
802 string_char_byte_cache_string
= Qnil
;
805 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
808 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
811 ptrdiff_t best_below
, best_below_byte
;
812 ptrdiff_t best_above
, best_above_byte
;
814 best_below
= best_below_byte
= 0;
815 best_above
= SCHARS (string
);
816 best_above_byte
= SBYTES (string
);
817 if (best_above
== best_above_byte
)
820 if (EQ (string
, string_char_byte_cache_string
))
822 if (string_char_byte_cache_charpos
< char_index
)
824 best_below
= string_char_byte_cache_charpos
;
825 best_below_byte
= string_char_byte_cache_bytepos
;
829 best_above
= string_char_byte_cache_charpos
;
830 best_above_byte
= string_char_byte_cache_bytepos
;
834 if (char_index
- best_below
< best_above
- char_index
)
836 unsigned char *p
= SDATA (string
) + best_below_byte
;
838 while (best_below
< char_index
)
840 p
+= BYTES_BY_CHAR_HEAD (*p
);
843 i_byte
= p
- SDATA (string
);
847 unsigned char *p
= SDATA (string
) + best_above_byte
;
849 while (best_above
> char_index
)
852 while (!CHAR_HEAD_P (*p
)) p
--;
855 i_byte
= p
- SDATA (string
);
858 string_char_byte_cache_bytepos
= i_byte
;
859 string_char_byte_cache_charpos
= char_index
;
860 string_char_byte_cache_string
= string
;
865 /* Return the character index corresponding to BYTE_INDEX in STRING. */
868 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
871 ptrdiff_t best_below
, best_below_byte
;
872 ptrdiff_t best_above
, best_above_byte
;
874 best_below
= best_below_byte
= 0;
875 best_above
= SCHARS (string
);
876 best_above_byte
= SBYTES (string
);
877 if (best_above
== best_above_byte
)
880 if (EQ (string
, string_char_byte_cache_string
))
882 if (string_char_byte_cache_bytepos
< byte_index
)
884 best_below
= string_char_byte_cache_charpos
;
885 best_below_byte
= string_char_byte_cache_bytepos
;
889 best_above
= string_char_byte_cache_charpos
;
890 best_above_byte
= string_char_byte_cache_bytepos
;
894 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
896 unsigned char *p
= SDATA (string
) + best_below_byte
;
897 unsigned char *pend
= SDATA (string
) + byte_index
;
901 p
+= BYTES_BY_CHAR_HEAD (*p
);
905 i_byte
= p
- SDATA (string
);
909 unsigned char *p
= SDATA (string
) + best_above_byte
;
910 unsigned char *pbeg
= SDATA (string
) + byte_index
;
915 while (!CHAR_HEAD_P (*p
)) p
--;
919 i_byte
= p
- SDATA (string
);
922 string_char_byte_cache_bytepos
= i_byte
;
923 string_char_byte_cache_charpos
= i
;
924 string_char_byte_cache_string
= string
;
929 /* Convert STRING to a multibyte string. */
932 string_make_multibyte (Lisp_Object string
)
939 if (STRING_MULTIBYTE (string
))
942 nbytes
= count_size_as_multibyte (SDATA (string
),
944 /* If all the chars are ASCII, they won't need any more bytes
945 once converted. In that case, we can return STRING itself. */
946 if (nbytes
== SBYTES (string
))
949 buf
= SAFE_ALLOCA (nbytes
);
950 copy_text (SDATA (string
), buf
, SBYTES (string
),
953 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
960 /* Convert STRING (if unibyte) to a multibyte string without changing
961 the number of characters. Characters 0200 trough 0237 are
962 converted to eight-bit characters. */
965 string_to_multibyte (Lisp_Object string
)
972 if (STRING_MULTIBYTE (string
))
975 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
976 /* If all the chars are ASCII, they won't need any more bytes once
978 if (nbytes
== SBYTES (string
))
979 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
981 buf
= SAFE_ALLOCA (nbytes
);
982 memcpy (buf
, SDATA (string
), SBYTES (string
));
983 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
985 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
992 /* Convert STRING to a single-byte string. */
995 string_make_unibyte (Lisp_Object string
)
1002 if (! STRING_MULTIBYTE (string
))
1005 nchars
= SCHARS (string
);
1007 buf
= SAFE_ALLOCA (nchars
);
1008 copy_text (SDATA (string
), buf
, SBYTES (string
),
1011 ret
= make_unibyte_string ((char *) buf
, nchars
);
1017 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1019 doc
: /* Return the multibyte equivalent of STRING.
1020 If STRING is unibyte and contains non-ASCII characters, the function
1021 `unibyte-char-to-multibyte' is used to convert each unibyte character
1022 to a multibyte character. In this case, the returned string is a
1023 newly created string with no text properties. If STRING is multibyte
1024 or entirely ASCII, it is returned unchanged. In particular, when
1025 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1026 \(When the characters are all ASCII, Emacs primitives will treat the
1027 string the same way whether it is unibyte or multibyte.) */)
1028 (Lisp_Object string
)
1030 CHECK_STRING (string
);
1032 return string_make_multibyte (string
);
1035 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1037 doc
: /* Return the unibyte equivalent of STRING.
1038 Multibyte character codes are converted to unibyte according to
1039 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1040 If the lookup in the translation table fails, this function takes just
1041 the low 8 bits of each character. */)
1042 (Lisp_Object string
)
1044 CHECK_STRING (string
);
1046 return string_make_unibyte (string
);
1049 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1051 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1052 If STRING is unibyte, the result is STRING itself.
1053 Otherwise it is a newly created string, with no text properties.
1054 If STRING is multibyte and contains a character of charset
1055 `eight-bit', it is converted to the corresponding single byte. */)
1056 (Lisp_Object string
)
1058 CHECK_STRING (string
);
1060 if (STRING_MULTIBYTE (string
))
1062 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1063 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1065 string
= make_unibyte_string ((char *) str
, bytes
);
1071 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1073 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1074 If STRING is multibyte, the result is STRING itself.
1075 Otherwise it is a newly created string, with no text properties.
1077 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1078 part of a correct utf-8 sequence), it is converted to the corresponding
1079 multibyte character of charset `eight-bit'.
1080 See also `string-to-multibyte'.
1082 Beware, this often doesn't really do what you think it does.
1083 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1084 If you're not sure, whether to use `string-as-multibyte' or
1085 `string-to-multibyte', use `string-to-multibyte'. */)
1086 (Lisp_Object string
)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1093 ptrdiff_t nchars
, nbytes
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1100 if (nbytes
!= SBYTES (string
))
1101 str_as_multibyte (SDATA (new_string
), nbytes
,
1102 SBYTES (string
), NULL
);
1103 string
= new_string
;
1104 set_string_intervals (string
, NULL
);
1109 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1111 doc
: /* Return a multibyte string with the same individual chars as STRING.
1112 If STRING is multibyte, the result is STRING itself.
1113 Otherwise it is a newly created string, with no text properties.
1115 If STRING is unibyte and contains an 8-bit byte, it is converted to
1116 the corresponding multibyte character of charset `eight-bit'.
1118 This differs from `string-as-multibyte' by converting each byte of a correct
1119 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1120 correct sequence. */)
1121 (Lisp_Object string
)
1123 CHECK_STRING (string
);
1125 return string_to_multibyte (string
);
1128 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1130 doc
: /* Return a unibyte string with the same individual chars as STRING.
1131 If STRING is unibyte, the result is STRING itself.
1132 Otherwise it is a newly created string, with no text properties,
1133 where each `eight-bit' character is converted to the corresponding byte.
1134 If STRING contains a non-ASCII, non-`eight-bit' character,
1135 an error is signaled. */)
1136 (Lisp_Object string
)
1138 CHECK_STRING (string
);
1140 if (STRING_MULTIBYTE (string
))
1142 ptrdiff_t chars
= SCHARS (string
);
1143 unsigned char *str
= xmalloc (chars
);
1144 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1146 if (converted
< chars
)
1147 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1148 string
= make_unibyte_string ((char *) str
, chars
);
1155 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1156 doc
: /* Return a copy of ALIST.
1157 This is an alist which represents the same mapping from objects to objects,
1158 but does not share the alist structure with ALIST.
1159 The objects mapped (cars and cdrs of elements of the alist)
1160 are shared, however.
1161 Elements of ALIST that are not conses are also shared. */)
1164 register Lisp_Object tem
;
1169 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1170 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1172 register Lisp_Object car
;
1176 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1181 /* Check that ARRAY can have a valid subarray [FROM..TO),
1182 given that its size is SIZE.
1183 If FROM is nil, use 0; if TO is nil, use SIZE.
1184 Count negative values backwards from the end.
1185 Set *IFROM and *ITO to the two indexes used. */
1188 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1189 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1193 if (INTEGERP (from
))
1199 else if (NILP (from
))
1202 wrong_type_argument (Qintegerp
, from
);
1213 wrong_type_argument (Qintegerp
, to
);
1215 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1216 args_out_of_range_3 (array
, from
, to
);
1222 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1223 doc
: /* Return a new string whose contents are a substring of STRING.
1224 The returned string consists of the characters between index FROM
1225 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1226 zero-indexed: 0 means the first character of STRING. Negative values
1227 are counted from the end of STRING. If TO is nil, the substring runs
1228 to the end of STRING.
1230 The STRING argument may also be a vector. In that case, the return
1231 value is a new vector that contains the elements between index FROM
1232 \(inclusive) and index TO (exclusive) of that vector argument.
1234 With one argument, just copy STRING (with properties, if any). */)
1235 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1238 ptrdiff_t size
, ifrom
, ito
;
1240 size
= CHECK_VECTOR_OR_STRING (string
);
1241 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1243 if (STRINGP (string
))
1246 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1248 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1249 res
= make_specified_string (SSDATA (string
) + from_byte
,
1250 ito
- ifrom
, to_byte
- from_byte
,
1251 STRING_MULTIBYTE (string
));
1252 copy_text_properties (make_number (ifrom
), make_number (ito
),
1253 string
, make_number (0), res
, Qnil
);
1256 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1262 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1263 doc
: /* Return a substring of STRING, without text properties.
1264 It starts at index FROM and ends before TO.
1265 TO may be nil or omitted; then the substring runs to the end of STRING.
1266 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1267 If FROM or TO is negative, it counts from the end.
1269 With one argument, just copy STRING without its properties. */)
1270 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1272 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1274 CHECK_STRING (string
);
1276 size
= SCHARS (string
);
1277 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1279 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1281 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1282 return make_specified_string (SSDATA (string
) + from_byte
,
1283 to_char
- from_char
, to_byte
- from_byte
,
1284 STRING_MULTIBYTE (string
));
1287 /* Extract a substring of STRING, giving start and end positions
1288 both in characters and in bytes. */
1291 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1292 ptrdiff_t to
, ptrdiff_t to_byte
)
1295 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1297 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1298 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1300 if (STRINGP (string
))
1302 res
= make_specified_string (SSDATA (string
) + from_byte
,
1303 to
- from
, to_byte
- from_byte
,
1304 STRING_MULTIBYTE (string
));
1305 copy_text_properties (make_number (from
), make_number (to
),
1306 string
, make_number (0), res
, Qnil
);
1309 res
= Fvector (to
- from
, aref_addr (string
, from
));
1314 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1315 doc
: /* Take cdr N times on LIST, return the result. */)
1316 (Lisp_Object n
, Lisp_Object list
)
1321 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1324 CHECK_LIST_CONS (list
, list
);
1330 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1331 doc
: /* Return the Nth element of LIST.
1332 N counts from zero. If LIST is not that long, nil is returned. */)
1333 (Lisp_Object n
, Lisp_Object list
)
1335 return Fcar (Fnthcdr (n
, list
));
1338 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1339 doc
: /* Return element of SEQUENCE at index N. */)
1340 (register Lisp_Object sequence
, Lisp_Object n
)
1343 if (CONSP (sequence
) || NILP (sequence
))
1344 return Fcar (Fnthcdr (n
, sequence
));
1346 /* Faref signals a "not array" error, so check here. */
1347 CHECK_ARRAY (sequence
, Qsequencep
);
1348 return Faref (sequence
, n
);
1351 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1352 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1353 The value is actually the tail of LIST whose car is ELT. */)
1354 (register Lisp_Object elt
, Lisp_Object list
)
1356 register Lisp_Object tail
;
1357 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1359 register Lisp_Object tem
;
1360 CHECK_LIST_CONS (tail
, list
);
1362 if (! NILP (Fequal (elt
, tem
)))
1369 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1370 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1371 The value is actually the tail of LIST whose car is ELT. */)
1372 (register Lisp_Object elt
, Lisp_Object list
)
1376 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1380 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1384 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1395 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1396 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1397 The value is actually the tail of LIST whose car is ELT. */)
1398 (register Lisp_Object elt
, Lisp_Object list
)
1400 register Lisp_Object tail
;
1403 return Fmemq (elt
, list
);
1405 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1407 register Lisp_Object tem
;
1408 CHECK_LIST_CONS (tail
, list
);
1410 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1417 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1418 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1419 The value is actually the first element of LIST whose car is KEY.
1420 Elements of LIST that are not conses are ignored. */)
1421 (Lisp_Object key
, Lisp_Object list
)
1426 || (CONSP (XCAR (list
))
1427 && EQ (XCAR (XCAR (list
)), key
)))
1432 || (CONSP (XCAR (list
))
1433 && EQ (XCAR (XCAR (list
)), key
)))
1438 || (CONSP (XCAR (list
))
1439 && EQ (XCAR (XCAR (list
)), key
)))
1449 /* Like Fassq but never report an error and do not allow quits.
1450 Use only on lists known never to be circular. */
1453 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1456 && (!CONSP (XCAR (list
))
1457 || !EQ (XCAR (XCAR (list
)), key
)))
1460 return CAR_SAFE (list
);
1463 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1464 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1465 The value is actually the first element of LIST whose car equals KEY. */)
1466 (Lisp_Object key
, Lisp_Object list
)
1473 || (CONSP (XCAR (list
))
1474 && (car
= XCAR (XCAR (list
)),
1475 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1480 || (CONSP (XCAR (list
))
1481 && (car
= XCAR (XCAR (list
)),
1482 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1487 || (CONSP (XCAR (list
))
1488 && (car
= XCAR (XCAR (list
)),
1489 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1499 /* Like Fassoc but never report an error and do not allow quits.
1500 Use only on lists known never to be circular. */
1503 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1506 && (!CONSP (XCAR (list
))
1507 || (!EQ (XCAR (XCAR (list
)), key
)
1508 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1511 return CONSP (list
) ? XCAR (list
) : Qnil
;
1514 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1515 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1516 The value is actually the first element of LIST whose cdr is KEY. */)
1517 (register Lisp_Object key
, Lisp_Object list
)
1522 || (CONSP (XCAR (list
))
1523 && EQ (XCDR (XCAR (list
)), key
)))
1528 || (CONSP (XCAR (list
))
1529 && EQ (XCDR (XCAR (list
)), key
)))
1534 || (CONSP (XCAR (list
))
1535 && EQ (XCDR (XCAR (list
)), key
)))
1545 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1546 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1547 The value is actually the first element of LIST whose cdr equals KEY. */)
1548 (Lisp_Object key
, Lisp_Object list
)
1555 || (CONSP (XCAR (list
))
1556 && (cdr
= XCDR (XCAR (list
)),
1557 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1562 || (CONSP (XCAR (list
))
1563 && (cdr
= XCDR (XCAR (list
)),
1564 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1569 || (CONSP (XCAR (list
))
1570 && (cdr
= XCDR (XCAR (list
)),
1571 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1581 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1582 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1583 More precisely, this function skips any members `eq' to ELT at the
1584 front of LIST, then removes members `eq' to ELT from the remaining
1585 sublist by modifying its list structure, then returns the resulting
1588 Write `(setq foo (delq element foo))' to be sure of correctly changing
1589 the value of a list `foo'. See also `remq', which does not modify the
1591 (register Lisp_Object elt
, Lisp_Object list
)
1593 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1596 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1598 Lisp_Object tem
= XCAR (tail
);
1604 Fsetcdr (prev
, XCDR (tail
));
1612 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1613 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1614 SEQ must be a sequence (i.e. a list, a vector, or a string).
1615 The return value is a sequence of the same type.
1617 If SEQ is a list, this behaves like `delq', except that it compares
1618 with `equal' instead of `eq'. In particular, it may remove elements
1619 by altering the list structure.
1621 If SEQ is not a list, deletion is never performed destructively;
1622 instead this function creates and returns a new vector or string.
1624 Write `(setq foo (delete element foo))' to be sure of correctly
1625 changing the value of a sequence `foo'. */)
1626 (Lisp_Object elt
, Lisp_Object seq
)
1632 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1633 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1636 if (n
!= ASIZE (seq
))
1638 struct Lisp_Vector
*p
= allocate_vector (n
);
1640 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1641 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1642 p
->contents
[n
++] = AREF (seq
, i
);
1644 XSETVECTOR (seq
, p
);
1647 else if (STRINGP (seq
))
1649 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1652 for (i
= nchars
= nbytes
= ibyte
= 0;
1654 ++i
, ibyte
+= cbytes
)
1656 if (STRING_MULTIBYTE (seq
))
1658 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1659 cbytes
= CHAR_BYTES (c
);
1667 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1674 if (nchars
!= SCHARS (seq
))
1678 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1679 if (!STRING_MULTIBYTE (seq
))
1680 STRING_SET_UNIBYTE (tem
);
1682 for (i
= nchars
= nbytes
= ibyte
= 0;
1684 ++i
, ibyte
+= cbytes
)
1686 if (STRING_MULTIBYTE (seq
))
1688 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1689 cbytes
= CHAR_BYTES (c
);
1697 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1699 unsigned char *from
= SDATA (seq
) + ibyte
;
1700 unsigned char *to
= SDATA (tem
) + nbytes
;
1706 for (n
= cbytes
; n
--; )
1716 Lisp_Object tail
, prev
;
1718 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1720 CHECK_LIST_CONS (tail
, seq
);
1722 if (!NILP (Fequal (elt
, XCAR (tail
))))
1727 Fsetcdr (prev
, XCDR (tail
));
1738 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1739 doc
: /* Reverse order of items in a list, vector or string SEQ.
1740 If SEQ is a list, it should be nil-terminated.
1741 This function may destructively modify SEQ to produce the value. */)
1746 else if (STRINGP (seq
))
1747 return Freverse (seq
);
1748 else if (CONSP (seq
))
1750 Lisp_Object prev
, tail
, next
;
1752 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1755 CHECK_LIST_CONS (tail
, tail
);
1757 Fsetcdr (tail
, prev
);
1762 else if (VECTORP (seq
))
1764 ptrdiff_t i
, size
= ASIZE (seq
);
1766 for (i
= 0; i
< size
/ 2; i
++)
1768 Lisp_Object tem
= AREF (seq
, i
);
1769 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1770 ASET (seq
, size
- i
- 1, tem
);
1773 else if (BOOL_VECTOR_P (seq
))
1775 ptrdiff_t i
, size
= bool_vector_size (seq
);
1777 for (i
= 0; i
< size
/ 2; i
++)
1779 bool tem
= bool_vector_bitref (seq
, i
);
1780 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1781 bool_vector_set (seq
, size
- i
- 1, tem
);
1785 wrong_type_argument (Qarrayp
, seq
);
1789 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1790 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1791 See also the function `nreverse', which is used more often. */)
1798 else if (CONSP (seq
))
1800 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1803 new = Fcons (XCAR (seq
), new);
1805 CHECK_LIST_END (seq
, seq
);
1807 else if (VECTORP (seq
))
1809 ptrdiff_t i
, size
= ASIZE (seq
);
1811 new = make_uninit_vector (size
);
1812 for (i
= 0; i
< size
; i
++)
1813 ASET (new, i
, AREF (seq
, size
- i
- 1));
1815 else if (BOOL_VECTOR_P (seq
))
1818 EMACS_INT nbits
= bool_vector_size (seq
);
1820 new = make_uninit_bool_vector (nbits
);
1821 for (i
= 0; i
< nbits
; i
++)
1822 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1824 else if (STRINGP (seq
))
1826 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1832 new = make_uninit_string (size
);
1833 for (i
= 0; i
< size
; i
++)
1834 SSET (new, i
, SREF (seq
, size
- i
- 1));
1838 unsigned char *p
, *q
;
1840 new = make_uninit_multibyte_string (size
, bytes
);
1841 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1842 while (q
> SDATA (new))
1846 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1848 CHAR_STRING (ch
, q
);
1853 wrong_type_argument (Qsequencep
, seq
);
1857 /* Sort LIST using PREDICATE, preserving original order of elements
1858 considered as equal. */
1861 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1863 Lisp_Object front
, back
;
1864 Lisp_Object len
, tem
;
1868 len
= Flength (list
);
1869 length
= XINT (len
);
1873 XSETINT (len
, (length
/ 2) - 1);
1874 tem
= Fnthcdr (len
, list
);
1876 Fsetcdr (tem
, Qnil
);
1878 front
= Fsort (front
, predicate
);
1879 back
= Fsort (back
, predicate
);
1880 return merge (front
, back
, predicate
);
1883 /* Using PRED to compare, return whether A and B are in order.
1884 Compare stably when A appeared before B in the input. */
1886 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1888 return NILP (call2 (pred
, b
, a
));
1891 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1892 into DEST. Argument arrays must be nonempty and must not overlap,
1893 except that B might be the last part of DEST. */
1895 merge_vectors (Lisp_Object pred
,
1896 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1897 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1898 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1900 eassume (0 < alen
&& 0 < blen
);
1901 Lisp_Object
const *alim
= a
+ alen
;
1902 Lisp_Object
const *blim
= b
+ blen
;
1906 if (inorder (pred
, a
[0], b
[0]))
1912 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1921 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1928 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1929 temporary storage. LEN must be at least 2. */
1931 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1932 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1933 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1936 ptrdiff_t halflen
= len
>> 1;
1937 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1938 if (1 < len
- halflen
)
1939 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1940 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1943 /* Using PRED to compare, sort from LEN-length SRC into DST.
1944 Len must be positive. */
1946 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1947 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1948 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1951 ptrdiff_t halflen
= len
>> 1;
1957 sort_vector_inplace (pred
, halflen
, src
, dest
);
1958 if (1 < len
- halflen
)
1959 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1960 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1964 /* Sort VECTOR in place using PREDICATE, preserving original order of
1965 elements considered as equal. */
1968 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1970 ptrdiff_t len
= ASIZE (vector
);
1973 ptrdiff_t halflen
= len
>> 1;
1976 SAFE_ALLOCA_LISP (tmp
, halflen
);
1977 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1978 tmp
[i
] = make_number (0);
1979 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1983 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1984 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1985 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1986 modified by side effects. PREDICATE is called with two elements of
1987 SEQ, and should return non-nil if the first element should sort before
1989 (Lisp_Object seq
, Lisp_Object predicate
)
1992 seq
= sort_list (seq
, predicate
);
1993 else if (VECTORP (seq
))
1994 sort_vector (seq
, predicate
);
1995 else if (!NILP (seq
))
1996 wrong_type_argument (Qsequencep
, seq
);
2001 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2003 Lisp_Object l1
= org_l1
;
2004 Lisp_Object l2
= org_l2
;
2005 Lisp_Object tail
= Qnil
;
2006 Lisp_Object value
= Qnil
;
2026 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2041 Fsetcdr (tail
, tem
);
2047 /* This does not check for quits. That is safe since it must terminate. */
2049 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2050 doc
: /* Extract a value from a property list.
2051 PLIST is a property list, which is a list of the form
2052 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2053 corresponding to the given PROP, or nil if PROP is not one of the
2054 properties on the list. This function never signals an error. */)
2055 (Lisp_Object plist
, Lisp_Object prop
)
2057 Lisp_Object tail
, halftail
;
2059 /* halftail is used to detect circular lists. */
2060 tail
= halftail
= plist
;
2061 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2063 if (EQ (prop
, XCAR (tail
)))
2064 return XCAR (XCDR (tail
));
2066 tail
= XCDR (XCDR (tail
));
2067 halftail
= XCDR (halftail
);
2068 if (EQ (tail
, halftail
))
2075 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2076 doc
: /* Return the value of SYMBOL's PROPNAME property.
2077 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2078 (Lisp_Object symbol
, Lisp_Object propname
)
2080 CHECK_SYMBOL (symbol
);
2081 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2084 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2085 doc
: /* Change value in PLIST of PROP to VAL.
2086 PLIST is a property list, which is a list of the form
2087 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2088 If PROP is already a property on the list, its value is set to VAL,
2089 otherwise the new PROP VAL pair is added. The new plist is returned;
2090 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2091 The PLIST is modified by side effects. */)
2092 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2094 register Lisp_Object tail
, prev
;
2095 Lisp_Object newcell
;
2097 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2098 tail
= XCDR (XCDR (tail
)))
2100 if (EQ (prop
, XCAR (tail
)))
2102 Fsetcar (XCDR (tail
), val
);
2109 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2113 Fsetcdr (XCDR (prev
), newcell
);
2117 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2118 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2119 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2120 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2122 CHECK_SYMBOL (symbol
);
2124 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2128 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2129 doc
: /* Extract a value from a property list, comparing with `equal'.
2130 PLIST is a property list, which is a list of the form
2131 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2132 corresponding to the given PROP, or nil if PROP is not
2133 one of the properties on the list. */)
2134 (Lisp_Object plist
, Lisp_Object prop
)
2139 CONSP (tail
) && CONSP (XCDR (tail
));
2140 tail
= XCDR (XCDR (tail
)))
2142 if (! NILP (Fequal (prop
, XCAR (tail
))))
2143 return XCAR (XCDR (tail
));
2148 CHECK_LIST_END (tail
, prop
);
2153 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2154 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2155 PLIST is a property list, which is a list of the form
2156 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2157 If PROP is already a property on the list, its value is set to VAL,
2158 otherwise the new PROP VAL pair is added. The new plist is returned;
2159 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2160 The PLIST is modified by side effects. */)
2161 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2163 register Lisp_Object tail
, prev
;
2164 Lisp_Object newcell
;
2166 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2167 tail
= XCDR (XCDR (tail
)))
2169 if (! NILP (Fequal (prop
, XCAR (tail
))))
2171 Fsetcar (XCDR (tail
), val
);
2178 newcell
= list2 (prop
, val
);
2182 Fsetcdr (XCDR (prev
), newcell
);
2186 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2187 doc
: /* Return t if the two args are the same Lisp object.
2188 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2189 (Lisp_Object obj1
, Lisp_Object obj2
)
2192 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2194 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2197 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2198 doc
: /* Return t if two Lisp objects have similar structure and contents.
2199 They must have the same data type.
2200 Conses are compared by comparing the cars and the cdrs.
2201 Vectors and strings are compared element by element.
2202 Numbers are compared by value, but integers cannot equal floats.
2203 (Use `=' if you want integers and floats to be able to be equal.)
2204 Symbols must match exactly. */)
2205 (register Lisp_Object o1
, Lisp_Object o2
)
2207 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2210 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2211 doc
: /* Return t if two Lisp objects have similar structure and contents.
2212 This is like `equal' except that it compares the text properties
2213 of strings. (`equal' ignores text properties.) */)
2214 (register Lisp_Object o1
, Lisp_Object o2
)
2216 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2219 /* DEPTH is current depth of recursion. Signal an error if it
2221 PROPS means compare string text properties too. */
2224 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2230 error ("Stack overflow in equal");
2232 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2235 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2237 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2239 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2241 { /* `o1' was seen already. */
2242 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2243 if (!NILP (Fmemq (o2
, o2s
)))
2246 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2249 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2259 if (XTYPE (o1
) != XTYPE (o2
))
2268 d1
= extract_float (o1
);
2269 d2
= extract_float (o2
);
2270 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2271 though they are not =. */
2272 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2276 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2280 /* FIXME: This inf-loops in a circular list! */
2284 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2288 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2289 depth
+ 1, props
, ht
)
2290 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2291 depth
+ 1, props
, ht
))
2293 o1
= XOVERLAY (o1
)->plist
;
2294 o2
= XOVERLAY (o2
)->plist
;
2299 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2300 && (XMARKER (o1
)->buffer
== 0
2301 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2305 case Lisp_Vectorlike
:
2308 ptrdiff_t size
= ASIZE (o1
);
2309 /* Pseudovectors have the type encoded in the size field, so this test
2310 actually checks that the objects have the same type as well as the
2312 if (ASIZE (o2
) != size
)
2314 /* Boolvectors are compared much like strings. */
2315 if (BOOL_VECTOR_P (o1
))
2317 EMACS_INT size
= bool_vector_size (o1
);
2318 if (size
!= bool_vector_size (o2
))
2320 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2321 bool_vector_bytes (size
)))
2325 if (WINDOW_CONFIGURATIONP (o1
))
2326 return compare_window_configurations (o1
, o2
, 0);
2328 /* Aside from them, only true vectors, char-tables, compiled
2329 functions, and fonts (font-spec, font-entity, font-object)
2330 are sensible to compare, so eliminate the others now. */
2331 if (size
& PSEUDOVECTOR_FLAG
)
2333 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2336 size
&= PSEUDOVECTOR_SIZE_MASK
;
2338 for (i
= 0; i
< size
; i
++)
2343 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2351 if (SCHARS (o1
) != SCHARS (o2
))
2353 if (SBYTES (o1
) != SBYTES (o2
))
2355 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2357 if (props
&& !compare_string_intervals (o1
, o2
))
2369 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2370 doc
: /* Store each element of ARRAY with ITEM.
2371 ARRAY is a vector, string, char-table, or bool-vector. */)
2372 (Lisp_Object array
, Lisp_Object item
)
2374 register ptrdiff_t size
, idx
;
2376 if (VECTORP (array
))
2377 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2378 ASET (array
, idx
, item
);
2379 else if (CHAR_TABLE_P (array
))
2383 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2384 set_char_table_contents (array
, i
, item
);
2385 set_char_table_defalt (array
, item
);
2387 else if (STRINGP (array
))
2389 register unsigned char *p
= SDATA (array
);
2391 CHECK_CHARACTER (item
);
2392 charval
= XFASTINT (item
);
2393 size
= SCHARS (array
);
2394 if (STRING_MULTIBYTE (array
))
2396 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2397 int len
= CHAR_STRING (charval
, str
);
2398 ptrdiff_t size_byte
= SBYTES (array
);
2401 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2402 error ("Attempt to change byte length of a string");
2403 for (idx
= 0; idx
< size_byte
; idx
++)
2404 *p
++ = str
[idx
% len
];
2407 for (idx
= 0; idx
< size
; idx
++)
2410 else if (BOOL_VECTOR_P (array
))
2411 return bool_vector_fill (array
, item
);
2413 wrong_type_argument (Qarrayp
, array
);
2417 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2419 doc
: /* Clear the contents of STRING.
2420 This makes STRING unibyte and may change its length. */)
2421 (Lisp_Object string
)
2424 CHECK_STRING (string
);
2425 len
= SBYTES (string
);
2426 memset (SDATA (string
), 0, len
);
2427 STRING_SET_CHARS (string
, len
);
2428 STRING_SET_UNIBYTE (string
);
2434 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2436 return CALLN (Fnconc
, s1
, s2
);
2439 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2440 doc
: /* Concatenate any number of lists by altering them.
2441 Only the last argument is not altered, and need not be a list.
2442 usage: (nconc &rest LISTS) */)
2443 (ptrdiff_t nargs
, Lisp_Object
*args
)
2446 register Lisp_Object tail
, tem
, val
;
2450 for (argnum
= 0; argnum
< nargs
; argnum
++)
2453 if (NILP (tem
)) continue;
2458 if (argnum
+ 1 == nargs
) break;
2460 CHECK_LIST_CONS (tem
, tem
);
2469 tem
= args
[argnum
+ 1];
2470 Fsetcdr (tail
, tem
);
2472 args
[argnum
+ 1] = tail
;
2478 /* This is the guts of all mapping functions.
2479 Apply FN to each element of SEQ, one by one,
2480 storing the results into elements of VALS, a C vector of Lisp_Objects.
2481 LENI is the length of VALS, which should also be the length of SEQ. */
2484 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2486 Lisp_Object tail
, dummy
;
2489 if (VECTORP (seq
) || COMPILEDP (seq
))
2491 for (i
= 0; i
< leni
; i
++)
2493 dummy
= call1 (fn
, AREF (seq
, i
));
2498 else if (BOOL_VECTOR_P (seq
))
2500 for (i
= 0; i
< leni
; i
++)
2502 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2507 else if (STRINGP (seq
))
2511 for (i
= 0, i_byte
= 0; i
< leni
;)
2514 ptrdiff_t i_before
= i
;
2516 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2517 XSETFASTINT (dummy
, c
);
2518 dummy
= call1 (fn
, dummy
);
2520 vals
[i_before
] = dummy
;
2523 else /* Must be a list, since Flength did not get an error */
2526 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2528 dummy
= call1 (fn
, XCAR (tail
));
2536 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2537 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2538 In between each pair of results, stick in SEPARATOR. Thus, " " as
2539 SEPARATOR results in spaces between the values returned by FUNCTION.
2540 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2541 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2551 len
= Flength (sequence
);
2552 if (CHAR_TABLE_P (sequence
))
2553 wrong_type_argument (Qlistp
, sequence
);
2555 nargs
= leni
+ leni
- 1;
2556 if (nargs
< 0) return empty_unibyte_string
;
2558 SAFE_ALLOCA_LISP (args
, nargs
);
2560 mapcar1 (leni
, args
, function
, sequence
);
2562 for (i
= leni
- 1; i
> 0; i
--)
2563 args
[i
+ i
] = args
[i
];
2565 for (i
= 1; i
< nargs
; i
+= 2)
2566 args
[i
] = separator
;
2568 ret
= Fconcat (nargs
, args
);
2574 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2575 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2576 The result is a list just as long as SEQUENCE.
2577 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2578 (Lisp_Object function
, Lisp_Object sequence
)
2580 register Lisp_Object len
;
2581 register EMACS_INT leni
;
2582 register Lisp_Object
*args
;
2586 len
= Flength (sequence
);
2587 if (CHAR_TABLE_P (sequence
))
2588 wrong_type_argument (Qlistp
, sequence
);
2589 leni
= XFASTINT (len
);
2591 SAFE_ALLOCA_LISP (args
, leni
);
2593 mapcar1 (leni
, args
, function
, sequence
);
2595 ret
= Flist (leni
, args
);
2601 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2602 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2603 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2604 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2605 (Lisp_Object function
, Lisp_Object sequence
)
2607 register EMACS_INT leni
;
2609 leni
= XFASTINT (Flength (sequence
));
2610 if (CHAR_TABLE_P (sequence
))
2611 wrong_type_argument (Qlistp
, sequence
);
2612 mapcar1 (leni
, 0, function
, sequence
);
2617 /* This is how C code calls `yes-or-no-p' and allows the user
2621 do_yes_or_no_p (Lisp_Object prompt
)
2623 return call1 (intern ("yes-or-no-p"), prompt
);
2626 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2627 doc
: /* Ask user a yes-or-no question.
2628 Return t if answer is yes, and nil if the answer is no.
2629 PROMPT is the string to display to ask the question. It should end in
2630 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2632 The user must confirm the answer with RET, and can edit it until it
2635 If dialog boxes are supported, a dialog box will be used
2636 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2637 (Lisp_Object prompt
)
2641 CHECK_STRING (prompt
);
2643 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2644 && use_dialog_box
&& ! NILP (last_input_event
))
2646 Lisp_Object pane
, menu
, obj
;
2647 redisplay_preserve_echo_area (4);
2648 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2649 Fcons (build_string ("No"), Qnil
));
2650 menu
= Fcons (prompt
, pane
);
2651 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2655 AUTO_STRING (yes_or_no
, "(yes or no) ");
2656 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2660 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2661 Qyes_or_no_p_history
, Qnil
,
2663 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2665 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2670 message1 ("Please answer yes or no.");
2671 Fsleep_for (make_number (2), Qnil
);
2675 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2676 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2678 Each of the three load averages is multiplied by 100, then converted
2681 When USE-FLOATS is non-nil, floats will be used instead of integers.
2682 These floats are not multiplied by 100.
2684 If the 5-minute or 15-minute load averages are not available, return a
2685 shortened list, containing only those averages which are available.
2687 An error is thrown if the load average can't be obtained. In some
2688 cases making it work would require Emacs being installed setuid or
2689 setgid so that it can read kernel information, and that usually isn't
2691 (Lisp_Object use_floats
)
2694 int loads
= getloadavg (load_ave
, 3);
2695 Lisp_Object ret
= Qnil
;
2698 error ("load-average not implemented for this operating system");
2702 Lisp_Object load
= (NILP (use_floats
)
2703 ? make_number (100.0 * load_ave
[loads
])
2704 : make_float (load_ave
[loads
]));
2705 ret
= Fcons (load
, ret
);
2711 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2712 doc
: /* Return t if FEATURE is present in this Emacs.
2714 Use this to conditionalize execution of lisp code based on the
2715 presence or absence of Emacs or environment extensions.
2716 Use `provide' to declare that a feature is available. This function
2717 looks at the value of the variable `features'. The optional argument
2718 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2719 (Lisp_Object feature
, Lisp_Object subfeature
)
2721 register Lisp_Object tem
;
2722 CHECK_SYMBOL (feature
);
2723 tem
= Fmemq (feature
, Vfeatures
);
2724 if (!NILP (tem
) && !NILP (subfeature
))
2725 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2726 return (NILP (tem
)) ? Qnil
: Qt
;
2729 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2730 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2731 The optional argument SUBFEATURES should be a list of symbols listing
2732 particular subfeatures supported in this version of FEATURE. */)
2733 (Lisp_Object feature
, Lisp_Object subfeatures
)
2735 register Lisp_Object tem
;
2736 CHECK_SYMBOL (feature
);
2737 CHECK_LIST (subfeatures
);
2738 if (!NILP (Vautoload_queue
))
2739 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2741 tem
= Fmemq (feature
, Vfeatures
);
2743 Vfeatures
= Fcons (feature
, Vfeatures
);
2744 if (!NILP (subfeatures
))
2745 Fput (feature
, Qsubfeatures
, subfeatures
);
2746 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2748 /* Run any load-hooks for this file. */
2749 tem
= Fassq (feature
, Vafter_load_alist
);
2751 Fmapc (Qfuncall
, XCDR (tem
));
2756 /* `require' and its subroutines. */
2758 /* List of features currently being require'd, innermost first. */
2760 static Lisp_Object require_nesting_list
;
2763 require_unwind (Lisp_Object old_value
)
2765 require_nesting_list
= old_value
;
2768 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2769 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2770 If FEATURE is not a member of the list `features', then the feature
2771 is not loaded; so load the file FILENAME.
2772 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2773 and `load' will try to load this name appended with the suffix `.elc',
2774 `.el', or the system-dependent suffix for dynamic module files, in that
2775 order. The name without appended suffix will not be used.
2776 See `get-load-suffixes' for the complete list of suffixes.
2777 If the optional third argument NOERROR is non-nil,
2778 then return nil if the file is not found instead of signaling an error.
2779 Normally the return value is FEATURE.
2780 The normal messages at start and end of loading FILENAME are suppressed. */)
2781 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2784 bool from_file
= load_in_progress
;
2786 CHECK_SYMBOL (feature
);
2788 /* Record the presence of `require' in this file
2789 even if the feature specified is already loaded.
2790 But not more than once in any file,
2791 and not when we aren't loading or reading from a file. */
2793 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2794 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2799 tem
= Fcons (Qrequire
, feature
);
2800 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2801 LOADHIST_ATTACH (tem
);
2803 tem
= Fmemq (feature
, Vfeatures
);
2807 ptrdiff_t count
= SPECPDL_INDEX ();
2810 /* This is to make sure that loadup.el gives a clear picture
2811 of what files are preloaded and when. */
2812 if (! NILP (Vpurify_flag
))
2813 error ("(require %s) while preparing to dump",
2814 SDATA (SYMBOL_NAME (feature
)));
2816 /* A certain amount of recursive `require' is legitimate,
2817 but if we require the same feature recursively 3 times,
2819 tem
= require_nesting_list
;
2820 while (! NILP (tem
))
2822 if (! NILP (Fequal (feature
, XCAR (tem
))))
2827 error ("Recursive `require' for feature `%s'",
2828 SDATA (SYMBOL_NAME (feature
)));
2830 /* Update the list for any nested `require's that occur. */
2831 record_unwind_protect (require_unwind
, require_nesting_list
);
2832 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2834 /* Value saved here is to be restored into Vautoload_queue */
2835 record_unwind_protect (un_autoload
, Vautoload_queue
);
2836 Vautoload_queue
= Qt
;
2838 /* Load the file. */
2839 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2840 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2842 /* If load failed entirely, return nil. */
2844 return unbind_to (count
, Qnil
);
2846 tem
= Fmemq (feature
, Vfeatures
);
2848 error ("Required feature `%s' was not provided",
2849 SDATA (SYMBOL_NAME (feature
)));
2851 /* Once loading finishes, don't undo it. */
2852 Vautoload_queue
= Qt
;
2853 feature
= unbind_to (count
, feature
);
2859 /* Primitives for work of the "widget" library.
2860 In an ideal world, this section would not have been necessary.
2861 However, lisp function calls being as slow as they are, it turns
2862 out that some functions in the widget library (wid-edit.el) are the
2863 bottleneck of Widget operation. Here is their translation to C,
2864 for the sole reason of efficiency. */
2866 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2867 doc
: /* Return non-nil if PLIST has the property PROP.
2868 PLIST is a property list, which is a list of the form
2869 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2870 Unlike `plist-get', this allows you to distinguish between a missing
2871 property and a property with the value nil.
2872 The value is actually the tail of PLIST whose car is PROP. */)
2873 (Lisp_Object plist
, Lisp_Object prop
)
2875 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2877 plist
= XCDR (plist
);
2878 plist
= CDR (plist
);
2884 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2885 doc
: /* In WIDGET, set PROPERTY to VALUE.
2886 The value can later be retrieved with `widget-get'. */)
2887 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2889 CHECK_CONS (widget
);
2890 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2894 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2895 doc
: /* In WIDGET, get the value of PROPERTY.
2896 The value could either be specified when the widget was created, or
2897 later with `widget-put'. */)
2898 (Lisp_Object widget
, Lisp_Object property
)
2906 CHECK_CONS (widget
);
2907 tmp
= Fplist_member (XCDR (widget
), property
);
2913 tmp
= XCAR (widget
);
2916 widget
= Fget (tmp
, Qwidget_type
);
2920 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2921 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2922 ARGS are passed as extra arguments to the function.
2923 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2924 (ptrdiff_t nargs
, Lisp_Object
*args
)
2926 Lisp_Object widget
= args
[0];
2927 Lisp_Object property
= args
[1];
2928 Lisp_Object propval
= Fwidget_get (widget
, property
);
2929 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2930 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2934 #ifdef HAVE_LANGINFO_CODESET
2935 #include <langinfo.h>
2938 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2939 doc
: /* Access locale data ITEM for the current C locale, if available.
2940 ITEM should be one of the following:
2942 `codeset', returning the character set as a string (locale item CODESET);
2944 `days', returning a 7-element vector of day names (locale items DAY_n);
2946 `months', returning a 12-element vector of month names (locale items MON_n);
2948 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2949 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2951 If the system can't provide such information through a call to
2952 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2954 See also Info node `(libc)Locales'.
2956 The data read from the system are decoded using `locale-coding-system'. */)
2960 #ifdef HAVE_LANGINFO_CODESET
2962 if (EQ (item
, Qcodeset
))
2964 str
= nl_langinfo (CODESET
);
2965 return build_string (str
);
2968 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2970 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2971 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2973 synchronize_system_time_locale ();
2974 for (i
= 0; i
< 7; i
++)
2976 str
= nl_langinfo (days
[i
]);
2977 val
= build_unibyte_string (str
);
2978 /* Fixme: Is this coding system necessarily right, even if
2979 it is consistent with CODESET? If not, what to do? */
2980 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2987 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2989 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2990 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2991 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2993 synchronize_system_time_locale ();
2994 for (i
= 0; i
< 12; i
++)
2996 str
= nl_langinfo (months
[i
]);
2997 val
= build_unibyte_string (str
);
2998 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3004 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3005 but is in the locale files. This could be used by ps-print. */
3007 else if (EQ (item
, Qpaper
))
3008 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3009 #endif /* PAPER_WIDTH */
3010 #endif /* HAVE_LANGINFO_CODESET*/
3014 /* base64 encode/decode functions (RFC 2045).
3015 Based on code from GNU recode. */
3017 #define MIME_LINE_LENGTH 76
3019 #define IS_ASCII(Character) \
3021 #define IS_BASE64(Character) \
3022 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3023 #define IS_BASE64_IGNORABLE(Character) \
3024 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3025 || (Character) == '\f' || (Character) == '\r')
3027 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3028 character or return retval if there are no characters left to
3030 #define READ_QUADRUPLET_BYTE(retval) \
3035 if (nchars_return) \
3036 *nchars_return = nchars; \
3041 while (IS_BASE64_IGNORABLE (c))
3043 /* Table of characters coding the 64 values. */
3044 static const char base64_value_to_char
[64] =
3046 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3047 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3048 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3049 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3050 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3051 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3052 '8', '9', '+', '/' /* 60-63 */
3055 /* Table of base64 values for first 128 characters. */
3056 static const short base64_char_to_value
[128] =
3058 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3059 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3060 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3061 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3062 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3063 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3064 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3065 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3066 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3067 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3068 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3069 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3070 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3073 /* The following diagram shows the logical steps by which three octets
3074 get transformed into four base64 characters.
3076 .--------. .--------. .--------.
3077 |aaaaaabb| |bbbbcccc| |ccdddddd|
3078 `--------' `--------' `--------'
3080 .--------+--------+--------+--------.
3081 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3082 `--------+--------+--------+--------'
3084 .--------+--------+--------+--------.
3085 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3086 `--------+--------+--------+--------'
3088 The octets are divided into 6 bit chunks, which are then encoded into
3089 base64 characters. */
3092 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3093 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3096 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3098 doc
: /* Base64-encode the region between BEG and END.
3099 Return the length of the encoded text.
3100 Optional third argument NO-LINE-BREAK means do not break long lines
3101 into shorter lines. */)
3102 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3105 ptrdiff_t allength
, length
;
3106 ptrdiff_t ibeg
, iend
, encoded_length
;
3107 ptrdiff_t old_pos
= PT
;
3110 validate_region (&beg
, &end
);
3112 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3113 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3114 move_gap_both (XFASTINT (beg
), ibeg
);
3116 /* We need to allocate enough room for encoding the text.
3117 We need 33 1/3% more space, plus a newline every 76
3118 characters, and then we round up. */
3119 length
= iend
- ibeg
;
3120 allength
= length
+ length
/3 + 1;
3121 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3123 encoded
= SAFE_ALLOCA (allength
);
3124 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3125 encoded
, length
, NILP (no_line_break
),
3126 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3127 if (encoded_length
> allength
)
3130 if (encoded_length
< 0)
3132 /* The encoding wasn't possible. */
3134 error ("Multibyte character in data for base64 encoding");
3137 /* Now we have encoded the region, so we insert the new contents
3138 and delete the old. (Insert first in order to preserve markers.) */
3139 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3140 insert (encoded
, encoded_length
);
3142 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3144 /* If point was outside of the region, restore it exactly; else just
3145 move to the beginning of the region. */
3146 if (old_pos
>= XFASTINT (end
))
3147 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3148 else if (old_pos
> XFASTINT (beg
))
3149 old_pos
= XFASTINT (beg
);
3152 /* We return the length of the encoded text. */
3153 return make_number (encoded_length
);
3156 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3158 doc
: /* Base64-encode STRING and return the result.
3159 Optional second argument NO-LINE-BREAK means do not break long lines
3160 into shorter lines. */)
3161 (Lisp_Object string
, Lisp_Object no_line_break
)
3163 ptrdiff_t allength
, length
, encoded_length
;
3165 Lisp_Object encoded_string
;
3168 CHECK_STRING (string
);
3170 /* We need to allocate enough room for encoding the text.
3171 We need 33 1/3% more space, plus a newline every 76
3172 characters, and then we round up. */
3173 length
= SBYTES (string
);
3174 allength
= length
+ length
/3 + 1;
3175 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3177 /* We need to allocate enough room for decoding the text. */
3178 encoded
= SAFE_ALLOCA (allength
);
3180 encoded_length
= base64_encode_1 (SSDATA (string
),
3181 encoded
, length
, NILP (no_line_break
),
3182 STRING_MULTIBYTE (string
));
3183 if (encoded_length
> allength
)
3186 if (encoded_length
< 0)
3188 /* The encoding wasn't possible. */
3189 error ("Multibyte character in data for base64 encoding");
3192 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3195 return encoded_string
;
3199 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3200 bool line_break
, bool multibyte
)
3213 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3214 if (CHAR_BYTE8_P (c
))
3215 c
= CHAR_TO_BYTE8 (c
);
3223 /* Wrap line every 76 characters. */
3227 if (counter
< MIME_LINE_LENGTH
/ 4)
3236 /* Process first byte of a triplet. */
3238 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3239 value
= (0x03 & c
) << 4;
3241 /* Process second byte of a triplet. */
3245 *e
++ = base64_value_to_char
[value
];
3253 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3254 if (CHAR_BYTE8_P (c
))
3255 c
= CHAR_TO_BYTE8 (c
);
3263 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3264 value
= (0x0f & c
) << 2;
3266 /* Process third byte of a triplet. */
3270 *e
++ = base64_value_to_char
[value
];
3277 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3278 if (CHAR_BYTE8_P (c
))
3279 c
= CHAR_TO_BYTE8 (c
);
3287 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3288 *e
++ = base64_value_to_char
[0x3f & c
];
3295 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3297 doc
: /* Base64-decode the region between BEG and END.
3298 Return the length of the decoded text.
3299 If the region can't be decoded, signal an error and don't modify the buffer. */)
3300 (Lisp_Object beg
, Lisp_Object end
)
3302 ptrdiff_t ibeg
, iend
, length
, allength
;
3304 ptrdiff_t old_pos
= PT
;
3305 ptrdiff_t decoded_length
;
3306 ptrdiff_t inserted_chars
;
3307 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3310 validate_region (&beg
, &end
);
3312 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3313 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3315 length
= iend
- ibeg
;
3317 /* We need to allocate enough room for decoding the text. If we are
3318 working on a multibyte buffer, each decoded code may occupy at
3320 allength
= multibyte
? length
* 2 : length
;
3321 decoded
= SAFE_ALLOCA (allength
);
3323 move_gap_both (XFASTINT (beg
), ibeg
);
3324 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3326 multibyte
, &inserted_chars
);
3327 if (decoded_length
> allength
)
3330 if (decoded_length
< 0)
3332 /* The decoding wasn't possible. */
3333 error ("Invalid base64 data");
3336 /* Now we have decoded the region, so we insert the new contents
3337 and delete the old. (Insert first in order to preserve markers.) */
3338 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3339 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3342 /* Delete the original text. */
3343 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3344 iend
+ decoded_length
, 1);
3346 /* If point was outside of the region, restore it exactly; else just
3347 move to the beginning of the region. */
3348 if (old_pos
>= XFASTINT (end
))
3349 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3350 else if (old_pos
> XFASTINT (beg
))
3351 old_pos
= XFASTINT (beg
);
3352 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3354 return make_number (inserted_chars
);
3357 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3359 doc
: /* Base64-decode STRING and return the result. */)
3360 (Lisp_Object string
)
3363 ptrdiff_t length
, decoded_length
;
3364 Lisp_Object decoded_string
;
3367 CHECK_STRING (string
);
3369 length
= SBYTES (string
);
3370 /* We need to allocate enough room for decoding the text. */
3371 decoded
= SAFE_ALLOCA (length
);
3373 /* The decoded result should be unibyte. */
3374 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3376 if (decoded_length
> length
)
3378 else if (decoded_length
>= 0)
3379 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3381 decoded_string
= Qnil
;
3384 if (!STRINGP (decoded_string
))
3385 error ("Invalid base64 data");
3387 return decoded_string
;
3390 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3391 MULTIBYTE, the decoded result should be in multibyte
3392 form. If NCHARS_RETURN is not NULL, store the number of produced
3393 characters in *NCHARS_RETURN. */
3396 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3397 bool multibyte
, ptrdiff_t *nchars_return
)
3399 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3402 unsigned long value
;
3403 ptrdiff_t nchars
= 0;
3407 /* Process first byte of a quadruplet. */
3409 READ_QUADRUPLET_BYTE (e
-to
);
3413 value
= base64_char_to_value
[c
] << 18;
3415 /* Process second byte of a quadruplet. */
3417 READ_QUADRUPLET_BYTE (-1);
3421 value
|= base64_char_to_value
[c
] << 12;
3423 c
= (unsigned char) (value
>> 16);
3424 if (multibyte
&& c
>= 128)
3425 e
+= BYTE8_STRING (c
, e
);
3430 /* Process third byte of a quadruplet. */
3432 READ_QUADRUPLET_BYTE (-1);
3436 READ_QUADRUPLET_BYTE (-1);
3445 value
|= base64_char_to_value
[c
] << 6;
3447 c
= (unsigned char) (0xff & value
>> 8);
3448 if (multibyte
&& c
>= 128)
3449 e
+= BYTE8_STRING (c
, e
);
3454 /* Process fourth byte of a quadruplet. */
3456 READ_QUADRUPLET_BYTE (-1);
3463 value
|= base64_char_to_value
[c
];
3465 c
= (unsigned char) (0xff & value
);
3466 if (multibyte
&& c
>= 128)
3467 e
+= BYTE8_STRING (c
, e
);
3476 /***********************************************************************
3478 ***** Hash Tables *****
3480 ***********************************************************************/
3482 /* Implemented by gerd@gnu.org. This hash table implementation was
3483 inspired by CMUCL hash tables. */
3487 1. For small tables, association lists are probably faster than
3488 hash tables because they have lower overhead.
3490 For uses of hash tables where the O(1) behavior of table
3491 operations is not a requirement, it might therefore be a good idea
3492 not to hash. Instead, we could just do a linear search in the
3493 key_and_value vector of the hash table. This could be done
3494 if a `:linear-search t' argument is given to make-hash-table. */
3497 /* The list of all weak hash tables. Don't staticpro this one. */
3499 static struct Lisp_Hash_Table
*weak_hash_tables
;
3502 /***********************************************************************
3504 ***********************************************************************/
3507 CHECK_HASH_TABLE (Lisp_Object x
)
3509 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3513 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3515 h
->key_and_value
= key_and_value
;
3518 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3523 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3525 gc_aset (h
->next
, idx
, val
);
3528 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3533 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3535 gc_aset (h
->hash
, idx
, val
);
3538 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3543 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3545 gc_aset (h
->index
, idx
, val
);
3548 /* If OBJ is a Lisp hash table, return a pointer to its struct
3549 Lisp_Hash_Table. Otherwise, signal an error. */
3551 static struct Lisp_Hash_Table
*
3552 check_hash_table (Lisp_Object obj
)
3554 CHECK_HASH_TABLE (obj
);
3555 return XHASH_TABLE (obj
);
3559 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3560 number. A number is "almost" a prime number if it is not divisible
3561 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3564 next_almost_prime (EMACS_INT n
)
3566 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3567 for (n
|= 1; ; n
+= 2)
3568 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3573 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3574 which USED[I] is non-zero. If found at index I in ARGS, set
3575 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3576 0. This function is used to extract a keyword/argument pair from
3577 a DEFUN parameter list. */
3580 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3584 for (i
= 1; i
< nargs
; i
++)
3585 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3596 /* Return a Lisp vector which has the same contents as VEC but has
3597 at least INCR_MIN more entries, where INCR_MIN is positive.
3598 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3599 than NITEMS_MAX. Entries in the resulting
3600 vector that are not copied from VEC are set to nil. */
3603 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3605 struct Lisp_Vector
*v
;
3606 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3607 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3608 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3609 ? nitems_max
: C_language_max
);
3610 eassert (VECTORP (vec
));
3611 eassert (0 < incr_min
&& -1 <= nitems_max
);
3612 old_size
= ASIZE (vec
);
3613 incr_max
= n_max
- old_size
;
3614 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3615 if (incr_max
< incr
)
3616 memory_full (SIZE_MAX
);
3617 new_size
= old_size
+ incr
;
3618 v
= allocate_vector (new_size
);
3619 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3620 memclear (v
->contents
+ old_size
, incr
* word_size
);
3621 XSETVECTOR (vec
, v
);
3626 /***********************************************************************
3628 ***********************************************************************/
3630 struct hash_table_test hashtest_eq
, hashtest_eql
, hashtest_equal
;
3632 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3633 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3634 KEY2 are the same. */
3637 cmpfn_eql (struct hash_table_test
*ht
,
3641 return (FLOATP (key1
)
3643 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3647 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3648 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3649 KEY2 are the same. */
3652 cmpfn_equal (struct hash_table_test
*ht
,
3656 return !NILP (Fequal (key1
, key2
));
3660 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3661 HASH2 in hash table H using H->user_cmp_function. Value is true
3662 if KEY1 and KEY2 are the same. */
3665 cmpfn_user_defined (struct hash_table_test
*ht
,
3669 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3673 /* Value is a hash code for KEY for use in hash table H which uses
3674 `eq' to compare keys. The hash code returned is guaranteed to fit
3675 in a Lisp integer. */
3678 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3680 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3684 /* Value is a hash code for KEY for use in hash table H which uses
3685 `eql' to compare keys. The hash code returned is guaranteed to fit
3686 in a Lisp integer. */
3689 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3693 hash
= sxhash (key
, 0);
3695 hash
= XHASH (key
) ^ XTYPE (key
);
3699 /* Value is a hash code for KEY for use in hash table H which uses
3700 `equal' to compare keys. The hash code returned is guaranteed to fit
3701 in a Lisp integer. */
3704 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3706 EMACS_UINT hash
= sxhash (key
, 0);
3710 /* Value is a hash code for KEY for use in hash table H which uses as
3711 user-defined function to compare keys. The hash code returned is
3712 guaranteed to fit in a Lisp integer. */
3715 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3717 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3718 return hashfn_eq (ht
, hash
);
3721 /* Allocate basically initialized hash table. */
3723 static struct Lisp_Hash_Table
*
3724 allocate_hash_table (void)
3726 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3727 count
, PVEC_HASH_TABLE
);
3730 /* An upper bound on the size of a hash table index. It must fit in
3731 ptrdiff_t and be a valid Emacs fixnum. */
3732 #define INDEX_SIZE_BOUND \
3733 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3735 /* Create and initialize a new hash table.
3737 TEST specifies the test the hash table will use to compare keys.
3738 It must be either one of the predefined tests `eq', `eql' or
3739 `equal' or a symbol denoting a user-defined test named TEST with
3740 test and hash functions USER_TEST and USER_HASH.
3742 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3744 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3745 new size when it becomes full is computed by adding REHASH_SIZE to
3746 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3747 table's new size is computed by multiplying its old size with
3750 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3751 be resized when the ratio of (number of entries in the table) /
3752 (table size) is >= REHASH_THRESHOLD.
3754 WEAK specifies the weakness of the table. If non-nil, it must be
3755 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3758 make_hash_table (struct hash_table_test test
,
3759 Lisp_Object size
, Lisp_Object rehash_size
,
3760 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3762 struct Lisp_Hash_Table
*h
;
3764 EMACS_INT index_size
, sz
;
3768 /* Preconditions. */
3769 eassert (SYMBOLP (test
.name
));
3770 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3771 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3772 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3773 eassert (FLOATP (rehash_threshold
)
3774 && 0 < XFLOAT_DATA (rehash_threshold
)
3775 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3777 if (XFASTINT (size
) == 0)
3778 size
= make_number (1);
3780 sz
= XFASTINT (size
);
3781 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3782 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3783 ? next_almost_prime (index_float
)
3784 : INDEX_SIZE_BOUND
+ 1);
3785 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3786 error ("Hash table too large");
3788 /* Allocate a table and initialize it. */
3789 h
= allocate_hash_table ();
3791 /* Initialize hash table slots. */
3794 h
->rehash_threshold
= rehash_threshold
;
3795 h
->rehash_size
= rehash_size
;
3797 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3798 h
->hash
= Fmake_vector (size
, Qnil
);
3799 h
->next
= Fmake_vector (size
, Qnil
);
3800 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3802 /* Set up the free list. */
3803 for (i
= 0; i
< sz
- 1; ++i
)
3804 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3805 h
->next_free
= make_number (0);
3807 XSET_HASH_TABLE (table
, h
);
3808 eassert (HASH_TABLE_P (table
));
3809 eassert (XHASH_TABLE (table
) == h
);
3811 /* Maybe add this hash table to the list of all weak hash tables. */
3813 h
->next_weak
= NULL
;
3816 h
->next_weak
= weak_hash_tables
;
3817 weak_hash_tables
= h
;
3824 /* Return a copy of hash table H1. Keys and values are not copied,
3825 only the table itself is. */
3828 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3831 struct Lisp_Hash_Table
*h2
;
3833 h2
= allocate_hash_table ();
3835 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3836 h2
->hash
= Fcopy_sequence (h1
->hash
);
3837 h2
->next
= Fcopy_sequence (h1
->next
);
3838 h2
->index
= Fcopy_sequence (h1
->index
);
3839 XSET_HASH_TABLE (table
, h2
);
3841 /* Maybe add this hash table to the list of all weak hash tables. */
3842 if (!NILP (h2
->weak
))
3844 h2
->next_weak
= weak_hash_tables
;
3845 weak_hash_tables
= h2
;
3852 /* Resize hash table H if it's too full. If H cannot be resized
3853 because it's already too large, throw an error. */
3856 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3858 if (NILP (h
->next_free
))
3860 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3861 EMACS_INT new_size
, index_size
, nsize
;
3865 if (INTEGERP (h
->rehash_size
))
3866 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3869 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3870 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3872 new_size
= float_new_size
;
3873 if (new_size
<= old_size
)
3874 new_size
= old_size
+ 1;
3877 new_size
= INDEX_SIZE_BOUND
+ 1;
3879 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3880 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3881 ? next_almost_prime (index_float
)
3882 : INDEX_SIZE_BOUND
+ 1);
3883 nsize
= max (index_size
, 2 * new_size
);
3884 if (INDEX_SIZE_BOUND
< nsize
)
3885 error ("Hash table too large to resize");
3887 #ifdef ENABLE_CHECKING
3888 if (HASH_TABLE_P (Vpurify_flag
)
3889 && XHASH_TABLE (Vpurify_flag
) == h
)
3890 message ("Growing hash table to: %"pI
"d", new_size
);
3893 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3894 2 * (new_size
- old_size
), -1));
3895 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3896 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3897 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3899 /* Update the free list. Do it so that new entries are added at
3900 the end of the free list. This makes some operations like
3902 for (i
= old_size
; i
< new_size
- 1; ++i
)
3903 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3905 if (!NILP (h
->next_free
))
3907 Lisp_Object last
, next
;
3909 last
= h
->next_free
;
3910 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3914 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3917 XSETFASTINT (h
->next_free
, old_size
);
3920 for (i
= 0; i
< old_size
; ++i
)
3921 if (!NILP (HASH_HASH (h
, i
)))
3923 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3924 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3925 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3926 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3932 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3933 the hash code of KEY. Value is the index of the entry in H
3934 matching KEY, or -1 if not found. */
3937 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3939 EMACS_UINT hash_code
;
3940 ptrdiff_t start_of_bucket
;
3943 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3944 eassert ((hash_code
& ~INTMASK
) == 0);
3948 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3949 idx
= HASH_INDEX (h
, start_of_bucket
);
3953 ptrdiff_t i
= XFASTINT (idx
);
3954 if (EQ (key
, HASH_KEY (h
, i
))
3956 && hash_code
== XUINT (HASH_HASH (h
, i
))
3957 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3959 idx
= HASH_NEXT (h
, i
);
3962 return NILP (idx
) ? -1 : XFASTINT (idx
);
3966 /* Put an entry into hash table H that associates KEY with VALUE.
3967 HASH is a previously computed hash code of KEY.
3968 Value is the index of the entry in H matching KEY. */
3971 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3974 ptrdiff_t start_of_bucket
, i
;
3976 eassert ((hash
& ~INTMASK
) == 0);
3978 /* Increment count after resizing because resizing may fail. */
3979 maybe_resize_hash_table (h
);
3982 /* Store key/value in the key_and_value vector. */
3983 i
= XFASTINT (h
->next_free
);
3984 h
->next_free
= HASH_NEXT (h
, i
);
3985 set_hash_key_slot (h
, i
, key
);
3986 set_hash_value_slot (h
, i
, value
);
3988 /* Remember its hash code. */
3989 set_hash_hash_slot (h
, i
, make_number (hash
));
3991 /* Add new entry to its collision chain. */
3992 start_of_bucket
= hash
% ASIZE (h
->index
);
3993 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3994 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3999 /* Remove the entry matching KEY from hash table H, if there is one. */
4002 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4004 EMACS_UINT hash_code
;
4005 ptrdiff_t start_of_bucket
;
4006 Lisp_Object idx
, prev
;
4008 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4009 eassert ((hash_code
& ~INTMASK
) == 0);
4010 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4011 idx
= HASH_INDEX (h
, start_of_bucket
);
4016 ptrdiff_t i
= XFASTINT (idx
);
4018 if (EQ (key
, HASH_KEY (h
, i
))
4020 && hash_code
== XUINT (HASH_HASH (h
, i
))
4021 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4023 /* Take entry out of collision chain. */
4025 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4027 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4029 /* Clear slots in key_and_value and add the slots to
4031 set_hash_key_slot (h
, i
, Qnil
);
4032 set_hash_value_slot (h
, i
, Qnil
);
4033 set_hash_hash_slot (h
, i
, Qnil
);
4034 set_hash_next_slot (h
, i
, h
->next_free
);
4035 h
->next_free
= make_number (i
);
4037 eassert (h
->count
>= 0);
4043 idx
= HASH_NEXT (h
, i
);
4049 /* Clear hash table H. */
4052 hash_clear (struct Lisp_Hash_Table
*h
)
4056 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4058 for (i
= 0; i
< size
; ++i
)
4060 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4061 set_hash_key_slot (h
, i
, Qnil
);
4062 set_hash_value_slot (h
, i
, Qnil
);
4063 set_hash_hash_slot (h
, i
, Qnil
);
4066 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4067 ASET (h
->index
, i
, Qnil
);
4069 h
->next_free
= make_number (0);
4076 /************************************************************************
4078 ************************************************************************/
4080 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4081 entries from the table that don't survive the current GC.
4082 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4083 true if anything was marked. */
4086 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4088 ptrdiff_t n
= gc_asize (h
->index
);
4089 bool marked
= false;
4091 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4093 Lisp_Object idx
, next
, prev
;
4095 /* Follow collision chain, removing entries that
4096 don't survive this garbage collection. */
4098 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4100 ptrdiff_t i
= XFASTINT (idx
);
4101 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4102 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4105 if (EQ (h
->weak
, Qkey
))
4106 remove_p
= !key_known_to_survive_p
;
4107 else if (EQ (h
->weak
, Qvalue
))
4108 remove_p
= !value_known_to_survive_p
;
4109 else if (EQ (h
->weak
, Qkey_or_value
))
4110 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4111 else if (EQ (h
->weak
, Qkey_and_value
))
4112 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4116 next
= HASH_NEXT (h
, i
);
4118 if (remove_entries_p
)
4122 /* Take out of collision chain. */
4124 set_hash_index_slot (h
, bucket
, next
);
4126 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4128 /* Add to free list. */
4129 set_hash_next_slot (h
, i
, h
->next_free
);
4132 /* Clear key, value, and hash. */
4133 set_hash_key_slot (h
, i
, Qnil
);
4134 set_hash_value_slot (h
, i
, Qnil
);
4135 set_hash_hash_slot (h
, i
, Qnil
);
4148 /* Make sure key and value survive. */
4149 if (!key_known_to_survive_p
)
4151 mark_object (HASH_KEY (h
, i
));
4155 if (!value_known_to_survive_p
)
4157 mark_object (HASH_VALUE (h
, i
));
4168 /* Remove elements from weak hash tables that don't survive the
4169 current garbage collection. Remove weak tables that don't survive
4170 from Vweak_hash_tables. Called from gc_sweep. */
4172 NO_INLINE
/* For better stack traces */
4174 sweep_weak_hash_tables (void)
4176 struct Lisp_Hash_Table
*h
, *used
, *next
;
4179 /* Mark all keys and values that are in use. Keep on marking until
4180 there is no more change. This is necessary for cases like
4181 value-weak table A containing an entry X -> Y, where Y is used in a
4182 key-weak table B, Z -> Y. If B comes after A in the list of weak
4183 tables, X -> Y might be removed from A, although when looking at B
4184 one finds that it shouldn't. */
4188 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4190 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4191 marked
|= sweep_weak_table (h
, 0);
4196 /* Remove tables and entries that aren't used. */
4197 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4199 next
= h
->next_weak
;
4201 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4203 /* TABLE is marked as used. Sweep its contents. */
4205 sweep_weak_table (h
, 1);
4207 /* Add table to the list of used weak hash tables. */
4208 h
->next_weak
= used
;
4213 weak_hash_tables
= used
;
4218 /***********************************************************************
4219 Hash Code Computation
4220 ***********************************************************************/
4222 /* Maximum depth up to which to dive into Lisp structures. */
4224 #define SXHASH_MAX_DEPTH 3
4226 /* Maximum length up to which to take list and vector elements into
4229 #define SXHASH_MAX_LEN 7
4231 /* Return a hash for string PTR which has length LEN. The hash value
4232 can be any EMACS_UINT value. */
4235 hash_string (char const *ptr
, ptrdiff_t len
)
4237 char const *p
= ptr
;
4238 char const *end
= p
+ len
;
4240 EMACS_UINT hash
= 0;
4245 hash
= sxhash_combine (hash
, c
);
4251 /* Return a hash for string PTR which has length LEN. The hash
4252 code returned is guaranteed to fit in a Lisp integer. */
4255 sxhash_string (char const *ptr
, ptrdiff_t len
)
4257 EMACS_UINT hash
= hash_string (ptr
, len
);
4258 return SXHASH_REDUCE (hash
);
4261 /* Return a hash for the floating point value VAL. */
4264 sxhash_float (double val
)
4266 EMACS_UINT hash
= 0;
4268 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4269 + (sizeof val
% sizeof hash
!= 0))
4273 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4277 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4278 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4279 hash
= sxhash_combine (hash
, u
.word
[i
]);
4280 return SXHASH_REDUCE (hash
);
4283 /* Return a hash for list LIST. DEPTH is the current depth in the
4284 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4287 sxhash_list (Lisp_Object list
, int depth
)
4289 EMACS_UINT hash
= 0;
4292 if (depth
< SXHASH_MAX_DEPTH
)
4294 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4295 list
= XCDR (list
), ++i
)
4297 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4298 hash
= sxhash_combine (hash
, hash2
);
4303 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4304 hash
= sxhash_combine (hash
, hash2
);
4307 return SXHASH_REDUCE (hash
);
4311 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4312 the Lisp structure. */
4315 sxhash_vector (Lisp_Object vec
, int depth
)
4317 EMACS_UINT hash
= ASIZE (vec
);
4320 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4321 for (i
= 0; i
< n
; ++i
)
4323 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4324 hash
= sxhash_combine (hash
, hash2
);
4327 return SXHASH_REDUCE (hash
);
4330 /* Return a hash for bool-vector VECTOR. */
4333 sxhash_bool_vector (Lisp_Object vec
)
4335 EMACS_INT size
= bool_vector_size (vec
);
4336 EMACS_UINT hash
= size
;
4339 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4340 for (i
= 0; i
< n
; ++i
)
4341 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4343 return SXHASH_REDUCE (hash
);
4347 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4348 structure. Value is an unsigned integer clipped to INTMASK. */
4351 sxhash (Lisp_Object obj
, int depth
)
4355 if (depth
> SXHASH_MAX_DEPTH
)
4358 switch (XTYPE (obj
))
4370 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4373 /* This can be everything from a vector to an overlay. */
4374 case Lisp_Vectorlike
:
4376 /* According to the CL HyperSpec, two arrays are equal only if
4377 they are `eq', except for strings and bit-vectors. In
4378 Emacs, this works differently. We have to compare element
4380 hash
= sxhash_vector (obj
, depth
);
4381 else if (BOOL_VECTOR_P (obj
))
4382 hash
= sxhash_bool_vector (obj
);
4384 /* Others are `equal' if they are `eq', so let's take their
4390 hash
= sxhash_list (obj
, depth
);
4394 hash
= sxhash_float (XFLOAT_DATA (obj
));
4406 /***********************************************************************
4408 ***********************************************************************/
4411 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4412 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4415 EMACS_UINT hash
= sxhash (obj
, 0);
4416 return make_number (hash
);
4420 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4421 doc
: /* Create and return a new hash table.
4423 Arguments are specified as keyword/argument pairs. The following
4424 arguments are defined:
4426 :test TEST -- TEST must be a symbol that specifies how to compare
4427 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4428 `equal'. User-supplied test and hash functions can be specified via
4429 `define-hash-table-test'.
4431 :size SIZE -- A hint as to how many elements will be put in the table.
4434 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4435 fills up. If REHASH-SIZE is an integer, increase the size by that
4436 amount. If it is a float, it must be > 1.0, and the new size is the
4437 old size multiplied by that factor. Default is 1.5.
4439 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4440 Resize the hash table when the ratio (number of entries / table size)
4441 is greater than or equal to THRESHOLD. Default is 0.8.
4443 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4444 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4445 returned is a weak table. Key/value pairs are removed from a weak
4446 hash table when there are no non-weak references pointing to their
4447 key, value, one of key or value, or both key and value, depending on
4448 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4451 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4452 (ptrdiff_t nargs
, Lisp_Object
*args
)
4454 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4455 struct hash_table_test testdesc
;
4459 /* The vector `used' is used to keep track of arguments that
4460 have been consumed. */
4461 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4462 memset (used
, 0, nargs
* sizeof *used
);
4464 /* See if there's a `:test TEST' among the arguments. */
4465 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4466 test
= i
? args
[i
] : Qeql
;
4468 testdesc
= hashtest_eq
;
4469 else if (EQ (test
, Qeql
))
4470 testdesc
= hashtest_eql
;
4471 else if (EQ (test
, Qequal
))
4472 testdesc
= hashtest_equal
;
4475 /* See if it is a user-defined test. */
4478 prop
= Fget (test
, Qhash_table_test
);
4479 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4480 signal_error ("Invalid hash table test", test
);
4481 testdesc
.name
= test
;
4482 testdesc
.user_cmp_function
= XCAR (prop
);
4483 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4484 testdesc
.hashfn
= hashfn_user_defined
;
4485 testdesc
.cmpfn
= cmpfn_user_defined
;
4488 /* See if there's a `:size SIZE' argument. */
4489 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4490 size
= i
? args
[i
] : Qnil
;
4492 size
= make_number (DEFAULT_HASH_SIZE
);
4493 else if (!INTEGERP (size
) || XINT (size
) < 0)
4494 signal_error ("Invalid hash table size", size
);
4496 /* Look for `:rehash-size SIZE'. */
4497 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4498 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4499 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4500 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4501 signal_error ("Invalid hash table rehash size", rehash_size
);
4503 /* Look for `:rehash-threshold THRESHOLD'. */
4504 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4505 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4506 if (! (FLOATP (rehash_threshold
)
4507 && 0 < XFLOAT_DATA (rehash_threshold
)
4508 && XFLOAT_DATA (rehash_threshold
) <= 1))
4509 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4511 /* Look for `:weakness WEAK'. */
4512 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4513 weak
= i
? args
[i
] : Qnil
;
4515 weak
= Qkey_and_value
;
4518 && !EQ (weak
, Qvalue
)
4519 && !EQ (weak
, Qkey_or_value
)
4520 && !EQ (weak
, Qkey_and_value
))
4521 signal_error ("Invalid hash table weakness", weak
);
4523 /* Now, all args should have been used up, or there's a problem. */
4524 for (i
= 0; i
< nargs
; ++i
)
4526 signal_error ("Invalid argument list", args
[i
]);
4529 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4533 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4534 doc
: /* Return a copy of hash table TABLE. */)
4537 return copy_hash_table (check_hash_table (table
));
4541 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4542 doc
: /* Return the number of elements in TABLE. */)
4545 return make_number (check_hash_table (table
)->count
);
4549 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4550 Shash_table_rehash_size
, 1, 1, 0,
4551 doc
: /* Return the current rehash size of TABLE. */)
4554 return check_hash_table (table
)->rehash_size
;
4558 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4559 Shash_table_rehash_threshold
, 1, 1, 0,
4560 doc
: /* Return the current rehash threshold of TABLE. */)
4563 return check_hash_table (table
)->rehash_threshold
;
4567 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4568 doc
: /* Return the size of TABLE.
4569 The size can be used as an argument to `make-hash-table' to create
4570 a hash table than can hold as many elements as TABLE holds
4571 without need for resizing. */)
4574 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4575 return make_number (HASH_TABLE_SIZE (h
));
4579 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4580 doc
: /* Return the test TABLE uses. */)
4583 return check_hash_table (table
)->test
.name
;
4587 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4589 doc
: /* Return the weakness of TABLE. */)
4592 return check_hash_table (table
)->weak
;
4596 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4597 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4600 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4604 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4605 doc
: /* Clear hash table TABLE and return it. */)
4608 hash_clear (check_hash_table (table
));
4609 /* Be compatible with XEmacs. */
4614 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4615 doc
: /* Look up KEY in TABLE and return its associated value.
4616 If KEY is not found, return DFLT which defaults to nil. */)
4617 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4619 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4620 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4621 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4625 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4626 doc
: /* Associate KEY with VALUE in hash table TABLE.
4627 If KEY is already present in table, replace its current value with
4628 VALUE. In any case, return VALUE. */)
4629 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4631 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4635 i
= hash_lookup (h
, key
, &hash
);
4637 set_hash_value_slot (h
, i
, value
);
4639 hash_put (h
, key
, value
, hash
);
4645 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4646 doc
: /* Remove KEY from TABLE. */)
4647 (Lisp_Object key
, Lisp_Object table
)
4649 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4650 hash_remove_from_table (h
, key
);
4655 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4656 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4657 FUNCTION is called with two arguments, KEY and VALUE.
4658 `maphash' always returns nil. */)
4659 (Lisp_Object function
, Lisp_Object table
)
4661 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4663 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4664 if (!NILP (HASH_HASH (h
, i
)))
4665 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4671 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4672 Sdefine_hash_table_test
, 3, 3, 0,
4673 doc
: /* Define a new hash table test with name NAME, a symbol.
4675 In hash tables created with NAME specified as test, use TEST to
4676 compare keys, and HASH for computing hash codes of keys.
4678 TEST must be a function taking two arguments and returning non-nil if
4679 both arguments are the same. HASH must be a function taking one
4680 argument and returning an object that is the hash code of the argument.
4681 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4682 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4683 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4685 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4690 /************************************************************************
4691 MD5, SHA-1, and SHA-2
4692 ************************************************************************/
4699 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4702 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4703 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4707 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4708 register EMACS_INT b
, e
;
4709 register struct buffer
*bp
;
4712 void *(*hash_func
) (const char *, size_t, void *);
4715 CHECK_SYMBOL (algorithm
);
4717 if (STRINGP (object
))
4719 if (NILP (coding_system
))
4721 /* Decide the coding-system to encode the data with. */
4723 if (STRING_MULTIBYTE (object
))
4724 /* use default, we can't guess correct value */
4725 coding_system
= preferred_coding_system ();
4727 coding_system
= Qraw_text
;
4730 if (NILP (Fcoding_system_p (coding_system
)))
4732 /* Invalid coding system. */
4734 if (!NILP (noerror
))
4735 coding_system
= Qraw_text
;
4737 xsignal1 (Qcoding_system_error
, coding_system
);
4740 if (STRING_MULTIBYTE (object
))
4741 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4743 size
= SCHARS (object
);
4744 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4746 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4747 end_byte
= (end_char
== size
4749 : string_char_to_byte (object
, end_char
));
4753 struct buffer
*prev
= current_buffer
;
4755 record_unwind_current_buffer ();
4757 CHECK_BUFFER (object
);
4759 bp
= XBUFFER (object
);
4760 set_buffer_internal (bp
);
4766 CHECK_NUMBER_COERCE_MARKER (start
);
4774 CHECK_NUMBER_COERCE_MARKER (end
);
4779 temp
= b
, b
= e
, e
= temp
;
4781 if (!(BEGV
<= b
&& e
<= ZV
))
4782 args_out_of_range (start
, end
);
4784 if (NILP (coding_system
))
4786 /* Decide the coding-system to encode the data with.
4787 See fileio.c:Fwrite-region */
4789 if (!NILP (Vcoding_system_for_write
))
4790 coding_system
= Vcoding_system_for_write
;
4793 bool force_raw_text
= 0;
4795 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4796 if (NILP (coding_system
)
4797 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4799 coding_system
= Qnil
;
4800 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4804 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4806 /* Check file-coding-system-alist. */
4807 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4808 Qwrite_region
, start
, end
,
4809 Fbuffer_file_name (object
));
4810 if (CONSP (val
) && !NILP (XCDR (val
)))
4811 coding_system
= XCDR (val
);
4814 if (NILP (coding_system
)
4815 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4817 /* If we still have not decided a coding system, use the
4818 default value of buffer-file-coding-system. */
4819 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4823 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4824 /* Confirm that VAL can surely encode the current region. */
4825 coding_system
= call4 (Vselect_safe_coding_system_function
,
4826 make_number (b
), make_number (e
),
4827 coding_system
, Qnil
);
4830 coding_system
= Qraw_text
;
4833 if (NILP (Fcoding_system_p (coding_system
)))
4835 /* Invalid coding system. */
4837 if (!NILP (noerror
))
4838 coding_system
= Qraw_text
;
4840 xsignal1 (Qcoding_system_error
, coding_system
);
4844 object
= make_buffer_string (b
, e
, 0);
4845 set_buffer_internal (prev
);
4846 /* Discard the unwind protect for recovering the current
4850 if (STRING_MULTIBYTE (object
))
4851 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4853 end_byte
= SBYTES (object
);
4856 if (EQ (algorithm
, Qmd5
))
4858 digest_size
= MD5_DIGEST_SIZE
;
4859 hash_func
= md5_buffer
;
4861 else if (EQ (algorithm
, Qsha1
))
4863 digest_size
= SHA1_DIGEST_SIZE
;
4864 hash_func
= sha1_buffer
;
4866 else if (EQ (algorithm
, Qsha224
))
4868 digest_size
= SHA224_DIGEST_SIZE
;
4869 hash_func
= sha224_buffer
;
4871 else if (EQ (algorithm
, Qsha256
))
4873 digest_size
= SHA256_DIGEST_SIZE
;
4874 hash_func
= sha256_buffer
;
4876 else if (EQ (algorithm
, Qsha384
))
4878 digest_size
= SHA384_DIGEST_SIZE
;
4879 hash_func
= sha384_buffer
;
4881 else if (EQ (algorithm
, Qsha512
))
4883 digest_size
= SHA512_DIGEST_SIZE
;
4884 hash_func
= sha512_buffer
;
4887 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4889 /* allocate 2 x digest_size so that it can be re-used to hold the
4891 digest
= make_uninit_string (digest_size
* 2);
4893 hash_func (SSDATA (object
) + start_byte
,
4894 end_byte
- start_byte
,
4899 unsigned char *p
= SDATA (digest
);
4900 for (i
= digest_size
- 1; i
>= 0; i
--)
4902 static char const hexdigit
[16] = "0123456789abcdef";
4904 p
[2 * i
] = hexdigit
[p_i
>> 4];
4905 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4910 return make_unibyte_string (SSDATA (digest
), digest_size
);
4913 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4914 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4916 A message digest is a cryptographic checksum of a document, and the
4917 algorithm to calculate it is defined in RFC 1321.
4919 The two optional arguments START and END are character positions
4920 specifying for which part of OBJECT the message digest should be
4921 computed. If nil or omitted, the digest is computed for the whole
4924 The MD5 message digest is computed from the result of encoding the
4925 text in a coding system, not directly from the internal Emacs form of
4926 the text. The optional fourth argument CODING-SYSTEM specifies which
4927 coding system to encode the text with. It should be the same coding
4928 system that you used or will use when actually writing the text into a
4931 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4932 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4933 system would be chosen by default for writing this text into a file.
4935 If OBJECT is a string, the most preferred coding system (see the
4936 command `prefer-coding-system') is used.
4938 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4939 guesswork fails. Normally, an error is signaled in such case. */)
4940 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4942 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4945 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4946 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4947 ALGORITHM is a symbol specifying the hash to use:
4948 md5, sha1, sha224, sha256, sha384 or sha512.
4950 The two optional arguments START and END are positions specifying for
4951 which part of OBJECT to compute the hash. If nil or omitted, uses the
4954 If BINARY is non-nil, returns a string in binary form. */)
4955 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4957 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4963 DEFSYM (Qmd5
, "md5");
4964 DEFSYM (Qsha1
, "sha1");
4965 DEFSYM (Qsha224
, "sha224");
4966 DEFSYM (Qsha256
, "sha256");
4967 DEFSYM (Qsha384
, "sha384");
4968 DEFSYM (Qsha512
, "sha512");
4970 /* Hash table stuff. */
4971 DEFSYM (Qhash_table_p
, "hash-table-p");
4973 DEFSYM (Qeql
, "eql");
4974 DEFSYM (Qequal
, "equal");
4975 DEFSYM (QCtest
, ":test");
4976 DEFSYM (QCsize
, ":size");
4977 DEFSYM (QCrehash_size
, ":rehash-size");
4978 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4979 DEFSYM (QCweakness
, ":weakness");
4980 DEFSYM (Qkey
, "key");
4981 DEFSYM (Qvalue
, "value");
4982 DEFSYM (Qhash_table_test
, "hash-table-test");
4983 DEFSYM (Qkey_or_value
, "key-or-value");
4984 DEFSYM (Qkey_and_value
, "key-and-value");
4987 defsubr (&Smake_hash_table
);
4988 defsubr (&Scopy_hash_table
);
4989 defsubr (&Shash_table_count
);
4990 defsubr (&Shash_table_rehash_size
);
4991 defsubr (&Shash_table_rehash_threshold
);
4992 defsubr (&Shash_table_size
);
4993 defsubr (&Shash_table_test
);
4994 defsubr (&Shash_table_weakness
);
4995 defsubr (&Shash_table_p
);
4996 defsubr (&Sclrhash
);
4997 defsubr (&Sgethash
);
4998 defsubr (&Sputhash
);
4999 defsubr (&Sremhash
);
5000 defsubr (&Smaphash
);
5001 defsubr (&Sdefine_hash_table_test
);
5003 DEFSYM (Qstring_lessp
, "string-lessp");
5004 DEFSYM (Qprovide
, "provide");
5005 DEFSYM (Qrequire
, "require");
5006 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5007 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5008 DEFSYM (Qwidget_type
, "widget-type");
5010 staticpro (&string_char_byte_cache_string
);
5011 string_char_byte_cache_string
= Qnil
;
5013 require_nesting_list
= Qnil
;
5014 staticpro (&require_nesting_list
);
5016 Fset (Qyes_or_no_p_history
, Qnil
);
5018 DEFVAR_LISP ("features", Vfeatures
,
5019 doc
: /* A list of symbols which are the features of the executing Emacs.
5020 Used by `featurep' and `require', and altered by `provide'. */);
5021 Vfeatures
= list1 (Qemacs
);
5022 DEFSYM (Qsubfeatures
, "subfeatures");
5023 DEFSYM (Qfuncall
, "funcall");
5025 #ifdef HAVE_LANGINFO_CODESET
5026 DEFSYM (Qcodeset
, "codeset");
5027 DEFSYM (Qdays
, "days");
5028 DEFSYM (Qmonths
, "months");
5029 DEFSYM (Qpaper
, "paper");
5030 #endif /* HAVE_LANGINFO_CODESET */
5032 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5033 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5034 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5035 invoked by mouse clicks and mouse menu items.
5037 On some platforms, file selection dialogs are also enabled if this is
5041 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5042 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5043 This applies to commands from menus and tool bar buttons even when
5044 they are initiated from the keyboard. If `use-dialog-box' is nil,
5045 that disables the use of a file dialog, regardless of the value of
5047 use_file_dialog
= 1;
5049 defsubr (&Sidentity
);
5052 defsubr (&Ssafe_length
);
5053 defsubr (&Sstring_bytes
);
5054 defsubr (&Sstring_equal
);
5055 defsubr (&Scompare_strings
);
5056 defsubr (&Sstring_lessp
);
5057 defsubr (&Sstring_collate_lessp
);
5058 defsubr (&Sstring_collate_equalp
);
5061 defsubr (&Svconcat
);
5062 defsubr (&Scopy_sequence
);
5063 defsubr (&Sstring_make_multibyte
);
5064 defsubr (&Sstring_make_unibyte
);
5065 defsubr (&Sstring_as_multibyte
);
5066 defsubr (&Sstring_as_unibyte
);
5067 defsubr (&Sstring_to_multibyte
);
5068 defsubr (&Sstring_to_unibyte
);
5069 defsubr (&Scopy_alist
);
5070 defsubr (&Ssubstring
);
5071 defsubr (&Ssubstring_no_properties
);
5084 defsubr (&Snreverse
);
5085 defsubr (&Sreverse
);
5087 defsubr (&Splist_get
);
5089 defsubr (&Splist_put
);
5091 defsubr (&Slax_plist_get
);
5092 defsubr (&Slax_plist_put
);
5095 defsubr (&Sequal_including_properties
);
5096 defsubr (&Sfillarray
);
5097 defsubr (&Sclear_string
);
5101 defsubr (&Smapconcat
);
5102 defsubr (&Syes_or_no_p
);
5103 defsubr (&Sload_average
);
5104 defsubr (&Sfeaturep
);
5105 defsubr (&Srequire
);
5106 defsubr (&Sprovide
);
5107 defsubr (&Splist_member
);
5108 defsubr (&Swidget_put
);
5109 defsubr (&Swidget_get
);
5110 defsubr (&Swidget_apply
);
5111 defsubr (&Sbase64_encode_region
);
5112 defsubr (&Sbase64_decode_region
);
5113 defsubr (&Sbase64_encode_string
);
5114 defsubr (&Sbase64_decode_string
);
5116 defsubr (&Ssecure_hash
);
5117 defsubr (&Slocale_info
);
5119 hashtest_eq
.name
= Qeq
;
5120 hashtest_eq
.user_hash_function
= Qnil
;
5121 hashtest_eq
.user_cmp_function
= Qnil
;
5122 hashtest_eq
.cmpfn
= 0;
5123 hashtest_eq
.hashfn
= hashfn_eq
;
5125 hashtest_eql
.name
= Qeql
;
5126 hashtest_eql
.user_hash_function
= Qnil
;
5127 hashtest_eql
.user_cmp_function
= Qnil
;
5128 hashtest_eql
.cmpfn
= cmpfn_eql
;
5129 hashtest_eql
.hashfn
= hashfn_eql
;
5131 hashtest_equal
.name
= Qequal
;
5132 hashtest_equal
.user_hash_function
= Qnil
;
5133 hashtest_equal
.user_cmp_function
= Qnil
;
5134 hashtest_equal
.cmpfn
= cmpfn_equal
;
5135 hashtest_equal
.hashfn
= hashfn_equal
;