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"
35 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
36 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
37 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
39 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
40 doc
: /* Return the argument unchanged. */
47 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
48 doc
: /* Return a pseudo-random number.
49 All integers representable in Lisp, i.e. between `most-negative-fixnum'
50 and `most-positive-fixnum', inclusive, are equally likely.
52 With positive integer LIMIT, return random number in interval [0,LIMIT).
53 With argument t, set the random number seed from the system's entropy
54 pool if available, otherwise from less-random volatile data such as the time.
55 With a string argument, set the seed based on the string's contents.
56 Other values of LIMIT are ignored.
58 See Info node `(elisp)Random Numbers' for more details. */)
65 else if (STRINGP (limit
))
66 seed_random (SSDATA (limit
), SBYTES (limit
));
69 if (INTEGERP (limit
) && 0 < XINT (limit
))
72 /* Return the remainder, except reject the rare case where
73 get_random returns a number so close to INTMASK that the
74 remainder isn't random. */
75 EMACS_INT remainder
= val
% XINT (limit
);
76 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
77 return make_number (remainder
);
80 return make_number (val
);
83 /* Heuristic on how many iterations of a tight loop can be safely done
84 before it's time to do a QUIT. This must be a power of 2. */
85 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
87 /* Random data-structure functions. */
90 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
92 CHECK_TYPE (NILP (x
), Qlistp
, y
);
95 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
96 doc
: /* Return the length of vector, list or string SEQUENCE.
97 A byte-code function object is also allowed.
98 If the string contains multibyte characters, this is not necessarily
99 the number of bytes in the string; it is the number of characters.
100 To get the number of bytes, use `string-bytes'. */)
101 (register Lisp_Object sequence
)
103 register Lisp_Object val
;
105 if (STRINGP (sequence
))
106 XSETFASTINT (val
, SCHARS (sequence
));
107 else if (VECTORP (sequence
))
108 XSETFASTINT (val
, ASIZE (sequence
));
109 else if (CHAR_TABLE_P (sequence
))
110 XSETFASTINT (val
, MAX_CHAR
);
111 else if (BOOL_VECTOR_P (sequence
))
112 XSETFASTINT (val
, bool_vector_size (sequence
));
113 else if (COMPILEDP (sequence
))
114 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
115 else if (CONSP (sequence
))
122 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
124 if (MOST_POSITIVE_FIXNUM
< i
)
125 error ("List too long");
128 sequence
= XCDR (sequence
);
130 while (CONSP (sequence
));
132 CHECK_LIST_END (sequence
, sequence
);
134 val
= make_number (i
);
136 else if (NILP (sequence
))
137 XSETFASTINT (val
, 0);
139 wrong_type_argument (Qsequencep
, sequence
);
144 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
145 doc
: /* Return the length of a list, but avoid error or infinite loop.
146 This function never gets an error. If LIST is not really a list,
147 it returns 0. If LIST is circular, it returns a finite value
148 which is at least the number of distinct elements. */)
151 Lisp_Object tail
, halftail
;
156 return make_number (0);
158 /* halftail is used to detect circular lists. */
159 for (tail
= halftail
= list
; ; )
164 if (EQ (tail
, halftail
))
167 if ((lolen
& 1) == 0)
169 halftail
= XCDR (halftail
);
170 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
174 hilen
+= UINTMAX_MAX
+ 1.0;
179 /* If the length does not fit into a fixnum, return a float.
180 On all known practical machines this returns an upper bound on
182 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
185 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
186 doc
: /* Return the number of bytes in STRING.
187 If STRING is multibyte, this may be greater than the length of STRING. */)
190 CHECK_STRING (string
);
191 return make_number (SBYTES (string
));
194 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
195 doc
: /* Return t if two strings have identical contents.
196 Case is significant, but text properties are ignored.
197 Symbols are also allowed; their print names are used instead. */)
198 (register Lisp_Object s1
, Lisp_Object s2
)
201 s1
= SYMBOL_NAME (s1
);
203 s2
= SYMBOL_NAME (s2
);
207 if (SCHARS (s1
) != SCHARS (s2
)
208 || SBYTES (s1
) != SBYTES (s2
)
209 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
214 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
215 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
216 The arguments START1, END1, START2, and END2, if non-nil, are
217 positions specifying which parts of STR1 or STR2 to compare. In
218 string STR1, compare the part between START1 (inclusive) and END1
219 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
220 the string; if END1 is nil, it defaults to the length of the string.
221 Likewise, in string STR2, compare the part between START2 and END2.
222 Like in `substring', negative values are counted from the end.
224 The strings are compared by the numeric values of their characters.
225 For instance, STR1 is "less than" STR2 if its first differing
226 character has a smaller numeric value. If IGNORE-CASE is non-nil,
227 characters are converted to upper-case before comparing them. Unibyte
228 strings are converted to multibyte for comparison.
230 The value is t if the strings (or specified portions) match.
231 If string STR1 is less, the value is a negative number N;
232 - 1 - N is the number of characters that match at the beginning.
233 If string STR1 is greater, the value is a positive number N;
234 N - 1 is the number of characters that match at the beginning. */)
235 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
236 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
238 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
243 /* For backward compatibility, silently bring too-large positive end
244 values into range. */
245 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
246 end1
= make_number (SCHARS (str1
));
247 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
248 end2
= make_number (SCHARS (str2
));
250 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
251 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
256 i1_byte
= string_char_to_byte (str1
, i1
);
257 i2_byte
= string_char_to_byte (str2
, i2
);
259 while (i1
< to1
&& i2
< to2
)
261 /* When we find a mismatch, we must compare the
262 characters, not just the bytes. */
265 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
266 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
271 if (! NILP (ignore_case
))
273 c1
= XINT (Fupcase (make_number (c1
)));
274 c2
= XINT (Fupcase (make_number (c2
)));
280 /* Note that I1 has already been incremented
281 past the character that we are comparing;
282 hence we don't add or subtract 1 here. */
284 return make_number (- i1
+ from1
);
286 return make_number (i1
- from1
);
290 return make_number (i1
- from1
+ 1);
292 return make_number (- i1
+ from1
- 1);
297 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
298 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
300 Symbols are also allowed; their print names are used instead. */)
301 (register Lisp_Object string1
, Lisp_Object string2
)
303 register ptrdiff_t end
;
304 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
306 if (SYMBOLP (string1
))
307 string1
= SYMBOL_NAME (string1
);
308 if (SYMBOLP (string2
))
309 string2
= SYMBOL_NAME (string2
);
310 CHECK_STRING (string1
);
311 CHECK_STRING (string2
);
313 i1
= i1_byte
= i2
= i2_byte
= 0;
315 end
= SCHARS (string1
);
316 if (end
> SCHARS (string2
))
317 end
= SCHARS (string2
);
321 /* When we find a mismatch, we must compare the
322 characters, not just the bytes. */
325 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
326 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
329 return c1
< c2
? Qt
: Qnil
;
331 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
334 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
335 doc
: /* Return t if first arg string is less than second in collation order.
336 Symbols are also allowed; their print names are used instead.
338 This function obeys the conventions for collation order in your
339 locale settings. For example, punctuation and whitespace characters
340 might be considered less significant for sorting:
342 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
343 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
345 The optional argument LOCALE, a string, overrides the setting of your
346 current locale identifier for collation. The value is system
347 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
348 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
350 If IGNORE-CASE is non-nil, characters are converted to lower-case
351 before comparing them.
353 To emulate Unicode-compliant collation on MS-Windows systems,
354 bind `w32-collate-ignore-punctuation' to a non-nil value, since
355 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
357 If your system does not support a locale environment, this function
358 behaves like `string-lessp'. */)
359 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
361 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
362 /* Check parameters. */
364 s1
= SYMBOL_NAME (s1
);
366 s2
= SYMBOL_NAME (s2
);
370 CHECK_STRING (locale
);
372 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
374 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
375 return Fstring_lessp (s1
, s2
);
376 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
379 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
380 doc
: /* Return t if two strings have identical contents.
381 Symbols are also allowed; their print names are used instead.
383 This function obeys the conventions for collation order in your locale
384 settings. For example, characters with different coding points but
385 the same meaning might be considered as equal, like different grave
386 accent Unicode characters:
388 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
391 The optional argument LOCALE, a string, overrides the setting of your
392 current locale identifier for collation. The value is system
393 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
394 while it would be \"enu_USA.1252\" on MS Windows systems.
396 If IGNORE-CASE is non-nil, characters are converted to lower-case
397 before comparing them.
399 To emulate Unicode-compliant collation on MS-Windows systems,
400 bind `w32-collate-ignore-punctuation' to a non-nil value, since
401 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
403 If your system does not support a locale environment, this function
404 behaves like `string-equal'.
406 Do NOT use this function to compare file names for equality. */)
407 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
409 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
410 /* Check parameters. */
412 s1
= SYMBOL_NAME (s1
);
414 s2
= SYMBOL_NAME (s2
);
418 CHECK_STRING (locale
);
420 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
422 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
423 return Fstring_equal (s1
, s2
);
424 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
427 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
428 enum Lisp_Type target_type
, bool last_special
);
432 concat2 (Lisp_Object s1
, Lisp_Object s2
)
434 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
439 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
441 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
444 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
445 doc
: /* Concatenate all the arguments and make the result a list.
446 The result is a list whose elements are the elements of all the arguments.
447 Each argument may be a list, vector or string.
448 The last argument is not copied, just used as the tail of the new list.
449 usage: (append &rest SEQUENCES) */)
450 (ptrdiff_t nargs
, Lisp_Object
*args
)
452 return concat (nargs
, args
, Lisp_Cons
, 1);
455 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
456 doc
: /* Concatenate all the arguments and make the result a string.
457 The result is a string whose elements are the elements of all the arguments.
458 Each argument may be a string or a list or vector of characters (integers).
459 usage: (concat &rest SEQUENCES) */)
460 (ptrdiff_t nargs
, Lisp_Object
*args
)
462 return concat (nargs
, args
, Lisp_String
, 0);
465 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
466 doc
: /* Concatenate all the arguments and make the result a vector.
467 The result is a vector whose elements are the elements of all the arguments.
468 Each argument may be a list, vector or string.
469 usage: (vconcat &rest SEQUENCES) */)
470 (ptrdiff_t nargs
, Lisp_Object
*args
)
472 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
476 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
477 doc
: /* Return a copy of a list, vector, string or char-table.
478 The elements of a list or vector are not copied; they are shared
479 with the original. */)
482 if (NILP (arg
)) return arg
;
484 if (CHAR_TABLE_P (arg
))
486 return copy_char_table (arg
);
489 if (BOOL_VECTOR_P (arg
))
491 EMACS_INT nbits
= bool_vector_size (arg
);
492 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
493 Lisp_Object val
= make_uninit_bool_vector (nbits
);
494 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
498 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
499 wrong_type_argument (Qsequencep
, arg
);
501 return concat (1, &arg
, XTYPE (arg
), 0);
504 /* This structure holds information of an argument of `concat' that is
505 a string and has text properties to be copied. */
508 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
509 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
510 ptrdiff_t to
; /* refer to VAL (the target string) */
514 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
515 enum Lisp_Type target_type
, bool last_special
)
521 ptrdiff_t toindex_byte
= 0;
522 EMACS_INT result_len
;
523 EMACS_INT result_len_byte
;
525 Lisp_Object last_tail
;
528 /* When we make a multibyte string, we can't copy text properties
529 while concatenating each string because the length of resulting
530 string can't be decided until we finish the whole concatenation.
531 So, we record strings that have text properties to be copied
532 here, and copy the text properties after the concatenation. */
533 struct textprop_rec
*textprops
= NULL
;
534 /* Number of elements in textprops. */
535 ptrdiff_t num_textprops
= 0;
540 /* In append, the last arg isn't treated like the others */
541 if (last_special
&& nargs
> 0)
544 last_tail
= args
[nargs
];
549 /* Check each argument. */
550 for (argnum
= 0; argnum
< nargs
; argnum
++)
553 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
554 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
555 wrong_type_argument (Qsequencep
, this);
558 /* Compute total length in chars of arguments in RESULT_LEN.
559 If desired output is a string, also compute length in bytes
560 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
561 whether the result should be a multibyte string. */
565 for (argnum
= 0; argnum
< nargs
; argnum
++)
569 len
= XFASTINT (Flength (this));
570 if (target_type
== Lisp_String
)
572 /* We must count the number of bytes needed in the string
573 as well as the number of characters. */
577 ptrdiff_t this_len_byte
;
579 if (VECTORP (this) || COMPILEDP (this))
580 for (i
= 0; i
< len
; i
++)
583 CHECK_CHARACTER (ch
);
585 this_len_byte
= CHAR_BYTES (c
);
586 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
588 result_len_byte
+= this_len_byte
;
589 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
592 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
593 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
594 else if (CONSP (this))
595 for (; CONSP (this); this = XCDR (this))
598 CHECK_CHARACTER (ch
);
600 this_len_byte
= CHAR_BYTES (c
);
601 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
603 result_len_byte
+= this_len_byte
;
604 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
607 else if (STRINGP (this))
609 if (STRING_MULTIBYTE (this))
612 this_len_byte
= SBYTES (this);
615 this_len_byte
= count_size_as_multibyte (SDATA (this),
617 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
619 result_len_byte
+= this_len_byte
;
624 if (MOST_POSITIVE_FIXNUM
< result_len
)
625 memory_full (SIZE_MAX
);
628 if (! some_multibyte
)
629 result_len_byte
= result_len
;
631 /* Create the output object. */
632 if (target_type
== Lisp_Cons
)
633 val
= Fmake_list (make_number (result_len
), Qnil
);
634 else if (target_type
== Lisp_Vectorlike
)
635 val
= Fmake_vector (make_number (result_len
), Qnil
);
636 else if (some_multibyte
)
637 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
639 val
= make_uninit_string (result_len
);
641 /* In `append', if all but last arg are nil, return last arg. */
642 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
645 /* Copy the contents of the args into the result. */
647 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
649 toindex
= 0, toindex_byte
= 0;
653 SAFE_NALLOCA (textprops
, 1, nargs
);
655 for (argnum
= 0; argnum
< nargs
; argnum
++)
658 ptrdiff_t thisleni
= 0;
659 register ptrdiff_t thisindex
= 0;
660 register ptrdiff_t thisindex_byte
= 0;
664 thislen
= Flength (this), thisleni
= XINT (thislen
);
666 /* Between strings of the same kind, copy fast. */
667 if (STRINGP (this) && STRINGP (val
)
668 && STRING_MULTIBYTE (this) == some_multibyte
)
670 ptrdiff_t thislen_byte
= SBYTES (this);
672 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
673 if (string_intervals (this))
675 textprops
[num_textprops
].argnum
= argnum
;
676 textprops
[num_textprops
].from
= 0;
677 textprops
[num_textprops
++].to
= toindex
;
679 toindex_byte
+= thislen_byte
;
682 /* Copy a single-byte string to a multibyte string. */
683 else if (STRINGP (this) && STRINGP (val
))
685 if (string_intervals (this))
687 textprops
[num_textprops
].argnum
= argnum
;
688 textprops
[num_textprops
].from
= 0;
689 textprops
[num_textprops
++].to
= toindex
;
691 toindex_byte
+= copy_text (SDATA (this),
692 SDATA (val
) + toindex_byte
,
693 SCHARS (this), 0, 1);
697 /* Copy element by element. */
700 register Lisp_Object elt
;
702 /* Fetch next element of `this' arg into `elt', or break if
703 `this' is exhausted. */
704 if (NILP (this)) break;
706 elt
= XCAR (this), this = XCDR (this);
707 else if (thisindex
>= thisleni
)
709 else if (STRINGP (this))
712 if (STRING_MULTIBYTE (this))
713 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
718 c
= SREF (this, thisindex
); thisindex
++;
719 if (some_multibyte
&& !ASCII_CHAR_P (c
))
720 c
= BYTE8_TO_CHAR (c
);
722 XSETFASTINT (elt
, c
);
724 else if (BOOL_VECTOR_P (this))
726 elt
= bool_vector_ref (this, thisindex
);
731 elt
= AREF (this, thisindex
);
735 /* Store this element into the result. */
742 else if (VECTORP (val
))
744 ASET (val
, toindex
, elt
);
750 CHECK_CHARACTER (elt
);
753 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
755 SSET (val
, toindex_byte
++, c
);
761 XSETCDR (prev
, last_tail
);
763 if (num_textprops
> 0)
766 ptrdiff_t last_to_end
= -1;
768 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
770 this = args
[textprops
[argnum
].argnum
];
771 props
= text_property_list (this,
773 make_number (SCHARS (this)),
775 /* If successive arguments have properties, be sure that the
776 value of `composition' property be the copy. */
777 if (last_to_end
== textprops
[argnum
].to
)
778 make_composition_value_copy (props
);
779 add_text_properties_from_list (val
, props
,
780 make_number (textprops
[argnum
].to
));
781 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
789 static Lisp_Object string_char_byte_cache_string
;
790 static ptrdiff_t string_char_byte_cache_charpos
;
791 static ptrdiff_t string_char_byte_cache_bytepos
;
794 clear_string_char_byte_cache (void)
796 string_char_byte_cache_string
= Qnil
;
799 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
802 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
805 ptrdiff_t best_below
, best_below_byte
;
806 ptrdiff_t best_above
, best_above_byte
;
808 best_below
= best_below_byte
= 0;
809 best_above
= SCHARS (string
);
810 best_above_byte
= SBYTES (string
);
811 if (best_above
== best_above_byte
)
814 if (EQ (string
, string_char_byte_cache_string
))
816 if (string_char_byte_cache_charpos
< char_index
)
818 best_below
= string_char_byte_cache_charpos
;
819 best_below_byte
= string_char_byte_cache_bytepos
;
823 best_above
= string_char_byte_cache_charpos
;
824 best_above_byte
= string_char_byte_cache_bytepos
;
828 if (char_index
- best_below
< best_above
- char_index
)
830 unsigned char *p
= SDATA (string
) + best_below_byte
;
832 while (best_below
< char_index
)
834 p
+= BYTES_BY_CHAR_HEAD (*p
);
837 i_byte
= p
- SDATA (string
);
841 unsigned char *p
= SDATA (string
) + best_above_byte
;
843 while (best_above
> char_index
)
846 while (!CHAR_HEAD_P (*p
)) p
--;
849 i_byte
= p
- SDATA (string
);
852 string_char_byte_cache_bytepos
= i_byte
;
853 string_char_byte_cache_charpos
= char_index
;
854 string_char_byte_cache_string
= string
;
859 /* Return the character index corresponding to BYTE_INDEX in STRING. */
862 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
865 ptrdiff_t best_below
, best_below_byte
;
866 ptrdiff_t best_above
, best_above_byte
;
868 best_below
= best_below_byte
= 0;
869 best_above
= SCHARS (string
);
870 best_above_byte
= SBYTES (string
);
871 if (best_above
== best_above_byte
)
874 if (EQ (string
, string_char_byte_cache_string
))
876 if (string_char_byte_cache_bytepos
< byte_index
)
878 best_below
= string_char_byte_cache_charpos
;
879 best_below_byte
= string_char_byte_cache_bytepos
;
883 best_above
= string_char_byte_cache_charpos
;
884 best_above_byte
= string_char_byte_cache_bytepos
;
888 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
890 unsigned char *p
= SDATA (string
) + best_below_byte
;
891 unsigned char *pend
= SDATA (string
) + byte_index
;
895 p
+= BYTES_BY_CHAR_HEAD (*p
);
899 i_byte
= p
- SDATA (string
);
903 unsigned char *p
= SDATA (string
) + best_above_byte
;
904 unsigned char *pbeg
= SDATA (string
) + byte_index
;
909 while (!CHAR_HEAD_P (*p
)) p
--;
913 i_byte
= p
- SDATA (string
);
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Convert STRING to a multibyte string. */
926 string_make_multibyte (Lisp_Object string
)
933 if (STRING_MULTIBYTE (string
))
936 nbytes
= count_size_as_multibyte (SDATA (string
),
938 /* If all the chars are ASCII, they won't need any more bytes
939 once converted. In that case, we can return STRING itself. */
940 if (nbytes
== SBYTES (string
))
943 buf
= SAFE_ALLOCA (nbytes
);
944 copy_text (SDATA (string
), buf
, SBYTES (string
),
947 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
954 /* Convert STRING (if unibyte) to a multibyte string without changing
955 the number of characters. Characters 0200 trough 0237 are
956 converted to eight-bit characters. */
959 string_to_multibyte (Lisp_Object string
)
966 if (STRING_MULTIBYTE (string
))
969 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
970 /* If all the chars are ASCII, they won't need any more bytes once
972 if (nbytes
== SBYTES (string
))
973 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
975 buf
= SAFE_ALLOCA (nbytes
);
976 memcpy (buf
, SDATA (string
), SBYTES (string
));
977 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
979 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
986 /* Convert STRING to a single-byte string. */
989 string_make_unibyte (Lisp_Object string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 buf
= SAFE_ALLOCA (nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string ((char *) buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 \(When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1022 (Lisp_Object string
)
1024 CHECK_STRING (string
);
1026 return string_make_multibyte (string
);
1029 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1031 doc
: /* Return the unibyte equivalent of STRING.
1032 Multibyte character codes are converted to unibyte according to
1033 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1034 If the lookup in the translation table fails, this function takes just
1035 the low 8 bits of each character. */)
1036 (Lisp_Object string
)
1038 CHECK_STRING (string
);
1040 return string_make_unibyte (string
);
1043 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1045 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1046 If STRING is unibyte, the result is STRING itself.
1047 Otherwise it is a newly created string, with no text properties.
1048 If STRING is multibyte and contains a character of charset
1049 `eight-bit', it is converted to the corresponding single byte. */)
1050 (Lisp_Object string
)
1052 CHECK_STRING (string
);
1054 if (STRING_MULTIBYTE (string
))
1056 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1057 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1059 string
= make_unibyte_string ((char *) str
, bytes
);
1065 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1067 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1068 If STRING is multibyte, the result is STRING itself.
1069 Otherwise it is a newly created string, with no text properties.
1071 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1072 part of a correct utf-8 sequence), it is converted to the corresponding
1073 multibyte character of charset `eight-bit'.
1074 See also `string-to-multibyte'.
1076 Beware, this often doesn't really do what you think it does.
1077 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1078 If you're not sure, whether to use `string-as-multibyte' or
1079 `string-to-multibyte', use `string-to-multibyte'. */)
1080 (Lisp_Object string
)
1082 CHECK_STRING (string
);
1084 if (! STRING_MULTIBYTE (string
))
1086 Lisp_Object new_string
;
1087 ptrdiff_t nchars
, nbytes
;
1089 parse_str_as_multibyte (SDATA (string
),
1092 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1093 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1094 if (nbytes
!= SBYTES (string
))
1095 str_as_multibyte (SDATA (new_string
), nbytes
,
1096 SBYTES (string
), NULL
);
1097 string
= new_string
;
1098 set_string_intervals (string
, NULL
);
1103 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1105 doc
: /* Return a multibyte string with the same individual chars as STRING.
1106 If STRING is multibyte, the result is STRING itself.
1107 Otherwise it is a newly created string, with no text properties.
1109 If STRING is unibyte and contains an 8-bit byte, it is converted to
1110 the corresponding multibyte character of charset `eight-bit'.
1112 This differs from `string-as-multibyte' by converting each byte of a correct
1113 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1114 correct sequence. */)
1115 (Lisp_Object string
)
1117 CHECK_STRING (string
);
1119 return string_to_multibyte (string
);
1122 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1124 doc
: /* Return a unibyte string with the same individual chars as STRING.
1125 If STRING is unibyte, the result is STRING itself.
1126 Otherwise it is a newly created string, with no text properties,
1127 where each `eight-bit' character is converted to the corresponding byte.
1128 If STRING contains a non-ASCII, non-`eight-bit' character,
1129 an error is signaled. */)
1130 (Lisp_Object string
)
1132 CHECK_STRING (string
);
1134 if (STRING_MULTIBYTE (string
))
1136 ptrdiff_t chars
= SCHARS (string
);
1137 unsigned char *str
= xmalloc (chars
);
1138 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1140 if (converted
< chars
)
1141 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1142 string
= make_unibyte_string ((char *) str
, chars
);
1149 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1150 doc
: /* Return a copy of ALIST.
1151 This is an alist which represents the same mapping from objects to objects,
1152 but does not share the alist structure with ALIST.
1153 The objects mapped (cars and cdrs of elements of the alist)
1154 are shared, however.
1155 Elements of ALIST that are not conses are also shared. */)
1158 register Lisp_Object tem
;
1163 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1164 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1166 register Lisp_Object car
;
1170 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1175 /* Check that ARRAY can have a valid subarray [FROM..TO),
1176 given that its size is SIZE.
1177 If FROM is nil, use 0; if TO is nil, use SIZE.
1178 Count negative values backwards from the end.
1179 Set *IFROM and *ITO to the two indexes used. */
1182 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1183 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1187 if (INTEGERP (from
))
1193 else if (NILP (from
))
1196 wrong_type_argument (Qintegerp
, from
);
1207 wrong_type_argument (Qintegerp
, to
);
1209 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1210 args_out_of_range_3 (array
, from
, to
);
1216 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1217 doc
: /* Return a new string whose contents are a substring of STRING.
1218 The returned string consists of the characters between index FROM
1219 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1220 zero-indexed: 0 means the first character of STRING. Negative values
1221 are counted from the end of STRING. If TO is nil, the substring runs
1222 to the end of STRING.
1224 The STRING argument may also be a vector. In that case, the return
1225 value is a new vector that contains the elements between index FROM
1226 \(inclusive) and index TO (exclusive) of that vector argument.
1228 With one argument, just copy STRING (with properties, if any). */)
1229 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1232 ptrdiff_t size
, ifrom
, ito
;
1234 size
= CHECK_VECTOR_OR_STRING (string
);
1235 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1237 if (STRINGP (string
))
1240 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1242 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1243 res
= make_specified_string (SSDATA (string
) + from_byte
,
1244 ito
- ifrom
, to_byte
- from_byte
,
1245 STRING_MULTIBYTE (string
));
1246 copy_text_properties (make_number (ifrom
), make_number (ito
),
1247 string
, make_number (0), res
, Qnil
);
1250 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1256 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1257 doc
: /* Return a substring of STRING, without text properties.
1258 It starts at index FROM and ends before TO.
1259 TO may be nil or omitted; then the substring runs to the end of STRING.
1260 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1261 If FROM or TO is negative, it counts from the end.
1263 With one argument, just copy STRING without its properties. */)
1264 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1266 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1268 CHECK_STRING (string
);
1270 size
= SCHARS (string
);
1271 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1273 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1275 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1276 return make_specified_string (SSDATA (string
) + from_byte
,
1277 to_char
- from_char
, to_byte
- from_byte
,
1278 STRING_MULTIBYTE (string
));
1281 /* Extract a substring of STRING, giving start and end positions
1282 both in characters and in bytes. */
1285 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1286 ptrdiff_t to
, ptrdiff_t to_byte
)
1289 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1291 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1292 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1294 if (STRINGP (string
))
1296 res
= make_specified_string (SSDATA (string
) + from_byte
,
1297 to
- from
, to_byte
- from_byte
,
1298 STRING_MULTIBYTE (string
));
1299 copy_text_properties (make_number (from
), make_number (to
),
1300 string
, make_number (0), res
, Qnil
);
1303 res
= Fvector (to
- from
, aref_addr (string
, from
));
1308 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1309 doc
: /* Take cdr N times on LIST, return the result. */)
1310 (Lisp_Object n
, Lisp_Object list
)
1315 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1318 CHECK_LIST_CONS (list
, list
);
1324 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1325 doc
: /* Return the Nth element of LIST.
1326 N counts from zero. If LIST is not that long, nil is returned. */)
1327 (Lisp_Object n
, Lisp_Object list
)
1329 return Fcar (Fnthcdr (n
, list
));
1332 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1333 doc
: /* Return element of SEQUENCE at index N. */)
1334 (register Lisp_Object sequence
, Lisp_Object n
)
1337 if (CONSP (sequence
) || NILP (sequence
))
1338 return Fcar (Fnthcdr (n
, sequence
));
1340 /* Faref signals a "not array" error, so check here. */
1341 CHECK_ARRAY (sequence
, Qsequencep
);
1342 return Faref (sequence
, n
);
1345 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1346 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1347 The value is actually the tail of LIST whose car is ELT. */)
1348 (register Lisp_Object elt
, Lisp_Object list
)
1350 register Lisp_Object tail
;
1351 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1353 register Lisp_Object tem
;
1354 CHECK_LIST_CONS (tail
, list
);
1356 if (! NILP (Fequal (elt
, tem
)))
1363 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1364 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1365 The value is actually the tail of LIST whose car is ELT. */)
1366 (register Lisp_Object elt
, Lisp_Object list
)
1370 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1374 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1378 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1389 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1390 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1391 The value is actually the tail of LIST whose car is ELT. */)
1392 (register Lisp_Object elt
, Lisp_Object list
)
1394 register Lisp_Object tail
;
1397 return Fmemq (elt
, list
);
1399 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1401 register Lisp_Object tem
;
1402 CHECK_LIST_CONS (tail
, list
);
1404 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1411 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1412 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1413 The value is actually the first element of LIST whose car is KEY.
1414 Elements of LIST that are not conses are ignored. */)
1415 (Lisp_Object key
, Lisp_Object list
)
1420 || (CONSP (XCAR (list
))
1421 && EQ (XCAR (XCAR (list
)), key
)))
1426 || (CONSP (XCAR (list
))
1427 && EQ (XCAR (XCAR (list
)), key
)))
1432 || (CONSP (XCAR (list
))
1433 && EQ (XCAR (XCAR (list
)), key
)))
1443 /* Like Fassq but never report an error and do not allow quits.
1444 Use only on lists known never to be circular. */
1447 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1450 && (!CONSP (XCAR (list
))
1451 || !EQ (XCAR (XCAR (list
)), key
)))
1454 return CAR_SAFE (list
);
1457 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1458 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1459 The value is actually the first element of LIST whose car equals KEY. */)
1460 (Lisp_Object key
, Lisp_Object list
)
1467 || (CONSP (XCAR (list
))
1468 && (car
= XCAR (XCAR (list
)),
1469 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1474 || (CONSP (XCAR (list
))
1475 && (car
= XCAR (XCAR (list
)),
1476 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1481 || (CONSP (XCAR (list
))
1482 && (car
= XCAR (XCAR (list
)),
1483 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1493 /* Like Fassoc but never report an error and do not allow quits.
1494 Use only on lists known never to be circular. */
1497 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1500 && (!CONSP (XCAR (list
))
1501 || (!EQ (XCAR (XCAR (list
)), key
)
1502 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1505 return CONSP (list
) ? XCAR (list
) : Qnil
;
1508 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1509 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1510 The value is actually the first element of LIST whose cdr is KEY. */)
1511 (register Lisp_Object key
, Lisp_Object list
)
1516 || (CONSP (XCAR (list
))
1517 && EQ (XCDR (XCAR (list
)), key
)))
1522 || (CONSP (XCAR (list
))
1523 && EQ (XCDR (XCAR (list
)), key
)))
1528 || (CONSP (XCAR (list
))
1529 && EQ (XCDR (XCAR (list
)), key
)))
1539 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1540 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1541 The value is actually the first element of LIST whose cdr equals KEY. */)
1542 (Lisp_Object key
, Lisp_Object list
)
1549 || (CONSP (XCAR (list
))
1550 && (cdr
= XCDR (XCAR (list
)),
1551 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1556 || (CONSP (XCAR (list
))
1557 && (cdr
= XCDR (XCAR (list
)),
1558 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1563 || (CONSP (XCAR (list
))
1564 && (cdr
= XCDR (XCAR (list
)),
1565 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1575 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1576 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1577 More precisely, this function skips any members `eq' to ELT at the
1578 front of LIST, then removes members `eq' to ELT from the remaining
1579 sublist by modifying its list structure, then returns the resulting
1582 Write `(setq foo (delq element foo))' to be sure of correctly changing
1583 the value of a list `foo'. See also `remq', which does not modify the
1585 (register Lisp_Object elt
, Lisp_Object list
)
1587 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1590 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1592 Lisp_Object tem
= XCAR (tail
);
1598 Fsetcdr (prev
, XCDR (tail
));
1606 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1607 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1608 SEQ must be a sequence (i.e. a list, a vector, or a string).
1609 The return value is a sequence of the same type.
1611 If SEQ is a list, this behaves like `delq', except that it compares
1612 with `equal' instead of `eq'. In particular, it may remove elements
1613 by altering the list structure.
1615 If SEQ is not a list, deletion is never performed destructively;
1616 instead this function creates and returns a new vector or string.
1618 Write `(setq foo (delete element foo))' to be sure of correctly
1619 changing the value of a sequence `foo'. */)
1620 (Lisp_Object elt
, Lisp_Object seq
)
1626 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1627 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1630 if (n
!= ASIZE (seq
))
1632 struct Lisp_Vector
*p
= allocate_vector (n
);
1634 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1635 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1636 p
->contents
[n
++] = AREF (seq
, i
);
1638 XSETVECTOR (seq
, p
);
1641 else if (STRINGP (seq
))
1643 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1646 for (i
= nchars
= nbytes
= ibyte
= 0;
1648 ++i
, ibyte
+= cbytes
)
1650 if (STRING_MULTIBYTE (seq
))
1652 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1653 cbytes
= CHAR_BYTES (c
);
1661 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1668 if (nchars
!= SCHARS (seq
))
1672 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1673 if (!STRING_MULTIBYTE (seq
))
1674 STRING_SET_UNIBYTE (tem
);
1676 for (i
= nchars
= nbytes
= ibyte
= 0;
1678 ++i
, ibyte
+= cbytes
)
1680 if (STRING_MULTIBYTE (seq
))
1682 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1683 cbytes
= CHAR_BYTES (c
);
1691 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1693 unsigned char *from
= SDATA (seq
) + ibyte
;
1694 unsigned char *to
= SDATA (tem
) + nbytes
;
1700 for (n
= cbytes
; n
--; )
1710 Lisp_Object tail
, prev
;
1712 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1714 CHECK_LIST_CONS (tail
, seq
);
1716 if (!NILP (Fequal (elt
, XCAR (tail
))))
1721 Fsetcdr (prev
, XCDR (tail
));
1732 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1733 doc
: /* Reverse order of items in a list, vector or string SEQ.
1734 If SEQ is a list, it should be nil-terminated.
1735 This function may destructively modify SEQ to produce the value. */)
1740 else if (STRINGP (seq
))
1741 return Freverse (seq
);
1742 else if (CONSP (seq
))
1744 Lisp_Object prev
, tail
, next
;
1746 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1749 CHECK_LIST_CONS (tail
, tail
);
1751 Fsetcdr (tail
, prev
);
1756 else if (VECTORP (seq
))
1758 ptrdiff_t i
, size
= ASIZE (seq
);
1760 for (i
= 0; i
< size
/ 2; i
++)
1762 Lisp_Object tem
= AREF (seq
, i
);
1763 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1764 ASET (seq
, size
- i
- 1, tem
);
1767 else if (BOOL_VECTOR_P (seq
))
1769 ptrdiff_t i
, size
= bool_vector_size (seq
);
1771 for (i
= 0; i
< size
/ 2; i
++)
1773 bool tem
= bool_vector_bitref (seq
, i
);
1774 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1775 bool_vector_set (seq
, size
- i
- 1, tem
);
1779 wrong_type_argument (Qarrayp
, seq
);
1783 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1784 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1785 See also the function `nreverse', which is used more often. */)
1792 else if (CONSP (seq
))
1794 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1797 new = Fcons (XCAR (seq
), new);
1799 CHECK_LIST_END (seq
, seq
);
1801 else if (VECTORP (seq
))
1803 ptrdiff_t i
, size
= ASIZE (seq
);
1805 new = make_uninit_vector (size
);
1806 for (i
= 0; i
< size
; i
++)
1807 ASET (new, i
, AREF (seq
, size
- i
- 1));
1809 else if (BOOL_VECTOR_P (seq
))
1812 EMACS_INT nbits
= bool_vector_size (seq
);
1814 new = make_uninit_bool_vector (nbits
);
1815 for (i
= 0; i
< nbits
; i
++)
1816 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1818 else if (STRINGP (seq
))
1820 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1826 new = make_uninit_string (size
);
1827 for (i
= 0; i
< size
; i
++)
1828 SSET (new, i
, SREF (seq
, size
- i
- 1));
1832 unsigned char *p
, *q
;
1834 new = make_uninit_multibyte_string (size
, bytes
);
1835 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1836 while (q
> SDATA (new))
1840 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1842 CHAR_STRING (ch
, q
);
1847 wrong_type_argument (Qsequencep
, seq
);
1851 /* Sort LIST using PREDICATE, preserving original order of elements
1852 considered as equal. */
1855 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1857 Lisp_Object front
, back
;
1858 Lisp_Object len
, tem
;
1862 len
= Flength (list
);
1863 length
= XINT (len
);
1867 XSETINT (len
, (length
/ 2) - 1);
1868 tem
= Fnthcdr (len
, list
);
1870 Fsetcdr (tem
, Qnil
);
1872 front
= Fsort (front
, predicate
);
1873 back
= Fsort (back
, predicate
);
1874 return merge (front
, back
, predicate
);
1877 /* Using PRED to compare, return whether A and B are in order.
1878 Compare stably when A appeared before B in the input. */
1880 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1882 return NILP (call2 (pred
, b
, a
));
1885 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1886 into DEST. Argument arrays must be nonempty and must not overlap,
1887 except that B might be the last part of DEST. */
1889 merge_vectors (Lisp_Object pred
,
1890 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1891 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1892 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1894 eassume (0 < alen
&& 0 < blen
);
1895 Lisp_Object
const *alim
= a
+ alen
;
1896 Lisp_Object
const *blim
= b
+ blen
;
1900 if (inorder (pred
, a
[0], b
[0]))
1906 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1915 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1922 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1923 temporary storage. LEN must be at least 2. */
1925 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1926 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1927 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1930 ptrdiff_t halflen
= len
>> 1;
1931 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1932 if (1 < len
- halflen
)
1933 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1934 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1937 /* Using PRED to compare, sort from LEN-length SRC into DST.
1938 Len must be positive. */
1940 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1941 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1942 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1945 ptrdiff_t halflen
= len
>> 1;
1951 sort_vector_inplace (pred
, halflen
, src
, dest
);
1952 if (1 < len
- halflen
)
1953 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1954 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1958 /* Sort VECTOR in place using PREDICATE, preserving original order of
1959 elements considered as equal. */
1962 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1964 ptrdiff_t len
= ASIZE (vector
);
1967 ptrdiff_t halflen
= len
>> 1;
1970 SAFE_ALLOCA_LISP (tmp
, halflen
);
1971 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1972 tmp
[i
] = make_number (0);
1973 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1977 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1978 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1979 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1980 modified by side effects. PREDICATE is called with two elements of
1981 SEQ, and should return non-nil if the first element should sort before
1983 (Lisp_Object seq
, Lisp_Object predicate
)
1986 seq
= sort_list (seq
, predicate
);
1987 else if (VECTORP (seq
))
1988 sort_vector (seq
, predicate
);
1989 else if (!NILP (seq
))
1990 wrong_type_argument (Qsequencep
, seq
);
1995 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1997 Lisp_Object l1
= org_l1
;
1998 Lisp_Object l2
= org_l2
;
1999 Lisp_Object tail
= Qnil
;
2000 Lisp_Object value
= Qnil
;
2020 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2035 Fsetcdr (tail
, tem
);
2041 /* This does not check for quits. That is safe since it must terminate. */
2043 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2044 doc
: /* Extract a value from a property list.
2045 PLIST is a property list, which is a list of the form
2046 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2047 corresponding to the given PROP, or nil if PROP is not one of the
2048 properties on the list. This function never signals an error. */)
2049 (Lisp_Object plist
, Lisp_Object prop
)
2051 Lisp_Object tail
, halftail
;
2053 /* halftail is used to detect circular lists. */
2054 tail
= halftail
= plist
;
2055 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2057 if (EQ (prop
, XCAR (tail
)))
2058 return XCAR (XCDR (tail
));
2060 tail
= XCDR (XCDR (tail
));
2061 halftail
= XCDR (halftail
);
2062 if (EQ (tail
, halftail
))
2069 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2070 doc
: /* Return the value of SYMBOL's PROPNAME property.
2071 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2072 (Lisp_Object symbol
, Lisp_Object propname
)
2074 CHECK_SYMBOL (symbol
);
2075 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2078 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2079 doc
: /* Change value in PLIST of PROP to VAL.
2080 PLIST is a property list, which is a list of the form
2081 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2082 If PROP is already a property on the list, its value is set to VAL,
2083 otherwise the new PROP VAL pair is added. The new plist is returned;
2084 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2085 The PLIST is modified by side effects. */)
2086 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2088 register Lisp_Object tail
, prev
;
2089 Lisp_Object newcell
;
2091 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2092 tail
= XCDR (XCDR (tail
)))
2094 if (EQ (prop
, XCAR (tail
)))
2096 Fsetcar (XCDR (tail
), val
);
2103 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2107 Fsetcdr (XCDR (prev
), newcell
);
2111 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2112 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2113 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2114 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2116 CHECK_SYMBOL (symbol
);
2118 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2122 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2123 doc
: /* Extract a value from a property list, comparing with `equal'.
2124 PLIST is a property list, which is a list of the form
2125 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2126 corresponding to the given PROP, or nil if PROP is not
2127 one of the properties on the list. */)
2128 (Lisp_Object plist
, Lisp_Object prop
)
2133 CONSP (tail
) && CONSP (XCDR (tail
));
2134 tail
= XCDR (XCDR (tail
)))
2136 if (! NILP (Fequal (prop
, XCAR (tail
))))
2137 return XCAR (XCDR (tail
));
2142 CHECK_LIST_END (tail
, prop
);
2147 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2148 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2149 PLIST is a property list, which is a list of the form
2150 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2151 If PROP is already a property on the list, its value is set to VAL,
2152 otherwise the new PROP VAL pair is added. The new plist is returned;
2153 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2154 The PLIST is modified by side effects. */)
2155 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2157 register Lisp_Object tail
, prev
;
2158 Lisp_Object newcell
;
2160 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2161 tail
= XCDR (XCDR (tail
)))
2163 if (! NILP (Fequal (prop
, XCAR (tail
))))
2165 Fsetcar (XCDR (tail
), val
);
2172 newcell
= list2 (prop
, val
);
2176 Fsetcdr (XCDR (prev
), newcell
);
2180 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2181 doc
: /* Return t if the two args are the same Lisp object.
2182 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2183 (Lisp_Object obj1
, Lisp_Object obj2
)
2186 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2188 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2191 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2192 doc
: /* Return t if two Lisp objects have similar structure and contents.
2193 They must have the same data type.
2194 Conses are compared by comparing the cars and the cdrs.
2195 Vectors and strings are compared element by element.
2196 Numbers are compared by value, but integers cannot equal floats.
2197 (Use `=' if you want integers and floats to be able to be equal.)
2198 Symbols must match exactly. */)
2199 (register Lisp_Object o1
, Lisp_Object o2
)
2201 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2204 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2205 doc
: /* Return t if two Lisp objects have similar structure and contents.
2206 This is like `equal' except that it compares the text properties
2207 of strings. (`equal' ignores text properties.) */)
2208 (register Lisp_Object o1
, Lisp_Object o2
)
2210 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2213 /* DEPTH is current depth of recursion. Signal an error if it
2215 PROPS means compare string text properties too. */
2218 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2224 error ("Stack overflow in equal");
2226 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2229 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2231 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2233 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2235 { /* `o1' was seen already. */
2236 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2237 if (!NILP (Fmemq (o2
, o2s
)))
2240 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2243 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2253 if (XTYPE (o1
) != XTYPE (o2
))
2262 d1
= extract_float (o1
);
2263 d2
= extract_float (o2
);
2264 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2265 though they are not =. */
2266 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2270 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2274 /* FIXME: This inf-loops in a circular list! */
2278 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2282 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2283 depth
+ 1, props
, ht
)
2284 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2285 depth
+ 1, props
, ht
))
2287 o1
= XOVERLAY (o1
)->plist
;
2288 o2
= XOVERLAY (o2
)->plist
;
2293 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2294 && (XMARKER (o1
)->buffer
== 0
2295 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2299 case Lisp_Vectorlike
:
2302 ptrdiff_t size
= ASIZE (o1
);
2303 /* Pseudovectors have the type encoded in the size field, so this test
2304 actually checks that the objects have the same type as well as the
2306 if (ASIZE (o2
) != size
)
2308 /* Boolvectors are compared much like strings. */
2309 if (BOOL_VECTOR_P (o1
))
2311 EMACS_INT size
= bool_vector_size (o1
);
2312 if (size
!= bool_vector_size (o2
))
2314 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2315 bool_vector_bytes (size
)))
2319 if (WINDOW_CONFIGURATIONP (o1
))
2320 return compare_window_configurations (o1
, o2
, 0);
2322 /* Aside from them, only true vectors, char-tables, compiled
2323 functions, and fonts (font-spec, font-entity, font-object)
2324 are sensible to compare, so eliminate the others now. */
2325 if (size
& PSEUDOVECTOR_FLAG
)
2327 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2330 size
&= PSEUDOVECTOR_SIZE_MASK
;
2332 for (i
= 0; i
< size
; i
++)
2337 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2345 if (SCHARS (o1
) != SCHARS (o2
))
2347 if (SBYTES (o1
) != SBYTES (o2
))
2349 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2351 if (props
&& !compare_string_intervals (o1
, o2
))
2363 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2364 doc
: /* Store each element of ARRAY with ITEM.
2365 ARRAY is a vector, string, char-table, or bool-vector. */)
2366 (Lisp_Object array
, Lisp_Object item
)
2368 register ptrdiff_t size
, idx
;
2370 if (VECTORP (array
))
2371 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2372 ASET (array
, idx
, item
);
2373 else if (CHAR_TABLE_P (array
))
2377 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2378 set_char_table_contents (array
, i
, item
);
2379 set_char_table_defalt (array
, item
);
2381 else if (STRINGP (array
))
2383 register unsigned char *p
= SDATA (array
);
2385 CHECK_CHARACTER (item
);
2386 charval
= XFASTINT (item
);
2387 size
= SCHARS (array
);
2388 if (STRING_MULTIBYTE (array
))
2390 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2391 int len
= CHAR_STRING (charval
, str
);
2392 ptrdiff_t size_byte
= SBYTES (array
);
2395 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2396 error ("Attempt to change byte length of a string");
2397 for (idx
= 0; idx
< size_byte
; idx
++)
2398 *p
++ = str
[idx
% len
];
2401 for (idx
= 0; idx
< size
; idx
++)
2404 else if (BOOL_VECTOR_P (array
))
2405 return bool_vector_fill (array
, item
);
2407 wrong_type_argument (Qarrayp
, array
);
2411 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2413 doc
: /* Clear the contents of STRING.
2414 This makes STRING unibyte and may change its length. */)
2415 (Lisp_Object string
)
2418 CHECK_STRING (string
);
2419 len
= SBYTES (string
);
2420 memset (SDATA (string
), 0, len
);
2421 STRING_SET_CHARS (string
, len
);
2422 STRING_SET_UNIBYTE (string
);
2428 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2430 return CALLN (Fnconc
, s1
, s2
);
2433 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2434 doc
: /* Concatenate any number of lists by altering them.
2435 Only the last argument is not altered, and need not be a list.
2436 usage: (nconc &rest LISTS) */)
2437 (ptrdiff_t nargs
, Lisp_Object
*args
)
2440 register Lisp_Object tail
, tem
, val
;
2444 for (argnum
= 0; argnum
< nargs
; argnum
++)
2447 if (NILP (tem
)) continue;
2452 if (argnum
+ 1 == nargs
) break;
2454 CHECK_LIST_CONS (tem
, tem
);
2463 tem
= args
[argnum
+ 1];
2464 Fsetcdr (tail
, tem
);
2466 args
[argnum
+ 1] = tail
;
2472 /* This is the guts of all mapping functions.
2473 Apply FN to each element of SEQ, one by one,
2474 storing the results into elements of VALS, a C vector of Lisp_Objects.
2475 LENI is the length of VALS, which should also be the length of SEQ. */
2478 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2480 Lisp_Object tail
, dummy
;
2483 if (VECTORP (seq
) || COMPILEDP (seq
))
2485 for (i
= 0; i
< leni
; i
++)
2487 dummy
= call1 (fn
, AREF (seq
, i
));
2492 else if (BOOL_VECTOR_P (seq
))
2494 for (i
= 0; i
< leni
; i
++)
2496 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2501 else if (STRINGP (seq
))
2505 for (i
= 0, i_byte
= 0; i
< leni
;)
2508 ptrdiff_t i_before
= i
;
2510 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2511 XSETFASTINT (dummy
, c
);
2512 dummy
= call1 (fn
, dummy
);
2514 vals
[i_before
] = dummy
;
2517 else /* Must be a list, since Flength did not get an error */
2520 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2522 dummy
= call1 (fn
, XCAR (tail
));
2530 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2531 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2532 In between each pair of results, stick in SEPARATOR. Thus, " " as
2533 SEPARATOR results in spaces between the values returned by FUNCTION.
2534 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2535 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2545 len
= Flength (sequence
);
2546 if (CHAR_TABLE_P (sequence
))
2547 wrong_type_argument (Qlistp
, sequence
);
2549 nargs
= leni
+ leni
- 1;
2550 if (nargs
< 0) return empty_unibyte_string
;
2552 SAFE_ALLOCA_LISP (args
, nargs
);
2554 mapcar1 (leni
, args
, function
, sequence
);
2556 for (i
= leni
- 1; i
> 0; i
--)
2557 args
[i
+ i
] = args
[i
];
2559 for (i
= 1; i
< nargs
; i
+= 2)
2560 args
[i
] = separator
;
2562 ret
= Fconcat (nargs
, args
);
2568 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2569 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2570 The result is a list just as long as SEQUENCE.
2571 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2572 (Lisp_Object function
, Lisp_Object sequence
)
2574 register Lisp_Object len
;
2575 register EMACS_INT leni
;
2576 register Lisp_Object
*args
;
2580 len
= Flength (sequence
);
2581 if (CHAR_TABLE_P (sequence
))
2582 wrong_type_argument (Qlistp
, sequence
);
2583 leni
= XFASTINT (len
);
2585 SAFE_ALLOCA_LISP (args
, leni
);
2587 mapcar1 (leni
, args
, function
, sequence
);
2589 ret
= Flist (leni
, args
);
2595 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2596 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2597 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2598 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2599 (Lisp_Object function
, Lisp_Object sequence
)
2601 register EMACS_INT leni
;
2603 leni
= XFASTINT (Flength (sequence
));
2604 if (CHAR_TABLE_P (sequence
))
2605 wrong_type_argument (Qlistp
, sequence
);
2606 mapcar1 (leni
, 0, function
, sequence
);
2611 /* This is how C code calls `yes-or-no-p' and allows the user
2615 do_yes_or_no_p (Lisp_Object prompt
)
2617 return call1 (intern ("yes-or-no-p"), prompt
);
2620 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2621 doc
: /* Ask user a yes-or-no question.
2622 Return t if answer is yes, and nil if the answer is no.
2623 PROMPT is the string to display to ask the question. It should end in
2624 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2626 The user must confirm the answer with RET, and can edit it until it
2629 If dialog boxes are supported, a dialog box will be used
2630 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2631 (Lisp_Object prompt
)
2635 CHECK_STRING (prompt
);
2637 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2638 && use_dialog_box
&& ! NILP (last_input_event
))
2640 Lisp_Object pane
, menu
, obj
;
2641 redisplay_preserve_echo_area (4);
2642 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2643 Fcons (build_string ("No"), Qnil
));
2644 menu
= Fcons (prompt
, pane
);
2645 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2649 AUTO_STRING (yes_or_no
, "(yes or no) ");
2650 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2654 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2655 Qyes_or_no_p_history
, Qnil
,
2657 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2659 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2664 message1 ("Please answer yes or no.");
2665 Fsleep_for (make_number (2), Qnil
);
2669 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2670 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2672 Each of the three load averages is multiplied by 100, then converted
2675 When USE-FLOATS is non-nil, floats will be used instead of integers.
2676 These floats are not multiplied by 100.
2678 If the 5-minute or 15-minute load averages are not available, return a
2679 shortened list, containing only those averages which are available.
2681 An error is thrown if the load average can't be obtained. In some
2682 cases making it work would require Emacs being installed setuid or
2683 setgid so that it can read kernel information, and that usually isn't
2685 (Lisp_Object use_floats
)
2688 int loads
= getloadavg (load_ave
, 3);
2689 Lisp_Object ret
= Qnil
;
2692 error ("load-average not implemented for this operating system");
2696 Lisp_Object load
= (NILP (use_floats
)
2697 ? make_number (100.0 * load_ave
[loads
])
2698 : make_float (load_ave
[loads
]));
2699 ret
= Fcons (load
, ret
);
2705 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2706 doc
: /* Return t if FEATURE is present in this Emacs.
2708 Use this to conditionalize execution of lisp code based on the
2709 presence or absence of Emacs or environment extensions.
2710 Use `provide' to declare that a feature is available. This function
2711 looks at the value of the variable `features'. The optional argument
2712 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2713 (Lisp_Object feature
, Lisp_Object subfeature
)
2715 register Lisp_Object tem
;
2716 CHECK_SYMBOL (feature
);
2717 tem
= Fmemq (feature
, Vfeatures
);
2718 if (!NILP (tem
) && !NILP (subfeature
))
2719 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2720 return (NILP (tem
)) ? Qnil
: Qt
;
2723 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2724 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2725 The optional argument SUBFEATURES should be a list of symbols listing
2726 particular subfeatures supported in this version of FEATURE. */)
2727 (Lisp_Object feature
, Lisp_Object subfeatures
)
2729 register Lisp_Object tem
;
2730 CHECK_SYMBOL (feature
);
2731 CHECK_LIST (subfeatures
);
2732 if (!NILP (Vautoload_queue
))
2733 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2735 tem
= Fmemq (feature
, Vfeatures
);
2737 Vfeatures
= Fcons (feature
, Vfeatures
);
2738 if (!NILP (subfeatures
))
2739 Fput (feature
, Qsubfeatures
, subfeatures
);
2740 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2742 /* Run any load-hooks for this file. */
2743 tem
= Fassq (feature
, Vafter_load_alist
);
2745 Fmapc (Qfuncall
, XCDR (tem
));
2750 /* `require' and its subroutines. */
2752 /* List of features currently being require'd, innermost first. */
2754 static Lisp_Object require_nesting_list
;
2757 require_unwind (Lisp_Object old_value
)
2759 require_nesting_list
= old_value
;
2762 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2763 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2764 If FEATURE is not a member of the list `features', then the feature is
2765 not loaded; so load the file FILENAME.
2767 If FILENAME is omitted, the printname of FEATURE is used as the file
2768 name, and `load' will try to load this name appended with the suffix
2769 `.elc', `.el', or the system-dependent suffix for dynamic module
2770 files, in that order. The name without appended suffix will not be
2771 used. See `get-load-suffixes' for the complete list of suffixes.
2773 The directories in `load-path' are searched when trying to find the
2776 If the optional third argument NOERROR is non-nil, then return nil if
2777 the file is not found instead of signaling an error. Normally the
2778 return value is FEATURE.
2780 The normal messages at start and end of loading FILENAME are
2782 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2785 bool from_file
= load_in_progress
;
2787 CHECK_SYMBOL (feature
);
2789 /* Record the presence of `require' in this file
2790 even if the feature specified is already loaded.
2791 But not more than once in any file,
2792 and not when we aren't loading or reading from a file. */
2794 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2795 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2800 tem
= Fcons (Qrequire
, feature
);
2801 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2802 LOADHIST_ATTACH (tem
);
2804 tem
= Fmemq (feature
, Vfeatures
);
2808 ptrdiff_t count
= SPECPDL_INDEX ();
2811 /* This is to make sure that loadup.el gives a clear picture
2812 of what files are preloaded and when. */
2813 if (! NILP (Vpurify_flag
))
2814 error ("(require %s) while preparing to dump",
2815 SDATA (SYMBOL_NAME (feature
)));
2817 /* A certain amount of recursive `require' is legitimate,
2818 but if we require the same feature recursively 3 times,
2820 tem
= require_nesting_list
;
2821 while (! NILP (tem
))
2823 if (! NILP (Fequal (feature
, XCAR (tem
))))
2828 error ("Recursive `require' for feature `%s'",
2829 SDATA (SYMBOL_NAME (feature
)));
2831 /* Update the list for any nested `require's that occur. */
2832 record_unwind_protect (require_unwind
, require_nesting_list
);
2833 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2835 /* Value saved here is to be restored into Vautoload_queue */
2836 record_unwind_protect (un_autoload
, Vautoload_queue
);
2837 Vautoload_queue
= Qt
;
2839 /* Load the file. */
2840 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2841 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2843 /* If load failed entirely, return nil. */
2845 return unbind_to (count
, Qnil
);
2847 tem
= Fmemq (feature
, Vfeatures
);
2849 error ("Required feature `%s' was not provided",
2850 SDATA (SYMBOL_NAME (feature
)));
2852 /* Once loading finishes, don't undo it. */
2853 Vautoload_queue
= Qt
;
2854 feature
= unbind_to (count
, feature
);
2860 /* Primitives for work of the "widget" library.
2861 In an ideal world, this section would not have been necessary.
2862 However, lisp function calls being as slow as they are, it turns
2863 out that some functions in the widget library (wid-edit.el) are the
2864 bottleneck of Widget operation. Here is their translation to C,
2865 for the sole reason of efficiency. */
2867 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2868 doc
: /* Return non-nil if PLIST has the property PROP.
2869 PLIST is a property list, which is a list of the form
2870 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2871 Unlike `plist-get', this allows you to distinguish between a missing
2872 property and a property with the value nil.
2873 The value is actually the tail of PLIST whose car is PROP. */)
2874 (Lisp_Object plist
, Lisp_Object prop
)
2876 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2878 plist
= XCDR (plist
);
2879 plist
= CDR (plist
);
2885 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2886 doc
: /* In WIDGET, set PROPERTY to VALUE.
2887 The value can later be retrieved with `widget-get'. */)
2888 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2890 CHECK_CONS (widget
);
2891 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2895 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2896 doc
: /* In WIDGET, get the value of PROPERTY.
2897 The value could either be specified when the widget was created, or
2898 later with `widget-put'. */)
2899 (Lisp_Object widget
, Lisp_Object property
)
2907 CHECK_CONS (widget
);
2908 tmp
= Fplist_member (XCDR (widget
), property
);
2914 tmp
= XCAR (widget
);
2917 widget
= Fget (tmp
, Qwidget_type
);
2921 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2922 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2923 ARGS are passed as extra arguments to the function.
2924 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2925 (ptrdiff_t nargs
, Lisp_Object
*args
)
2927 Lisp_Object widget
= args
[0];
2928 Lisp_Object property
= args
[1];
2929 Lisp_Object propval
= Fwidget_get (widget
, property
);
2930 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2931 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2935 #ifdef HAVE_LANGINFO_CODESET
2936 #include <langinfo.h>
2939 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2940 doc
: /* Access locale data ITEM for the current C locale, if available.
2941 ITEM should be one of the following:
2943 `codeset', returning the character set as a string (locale item CODESET);
2945 `days', returning a 7-element vector of day names (locale items DAY_n);
2947 `months', returning a 12-element vector of month names (locale items MON_n);
2949 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2950 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2952 If the system can't provide such information through a call to
2953 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2955 See also Info node `(libc)Locales'.
2957 The data read from the system are decoded using `locale-coding-system'. */)
2961 #ifdef HAVE_LANGINFO_CODESET
2963 if (EQ (item
, Qcodeset
))
2965 str
= nl_langinfo (CODESET
);
2966 return build_string (str
);
2969 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2971 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2972 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2974 synchronize_system_time_locale ();
2975 for (i
= 0; i
< 7; i
++)
2977 str
= nl_langinfo (days
[i
]);
2978 val
= build_unibyte_string (str
);
2979 /* Fixme: Is this coding system necessarily right, even if
2980 it is consistent with CODESET? If not, what to do? */
2981 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2988 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2990 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2991 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2992 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2994 synchronize_system_time_locale ();
2995 for (i
= 0; i
< 12; i
++)
2997 str
= nl_langinfo (months
[i
]);
2998 val
= build_unibyte_string (str
);
2999 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3005 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3006 but is in the locale files. This could be used by ps-print. */
3008 else if (EQ (item
, Qpaper
))
3009 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3010 #endif /* PAPER_WIDTH */
3011 #endif /* HAVE_LANGINFO_CODESET*/
3015 /* base64 encode/decode functions (RFC 2045).
3016 Based on code from GNU recode. */
3018 #define MIME_LINE_LENGTH 76
3020 #define IS_ASCII(Character) \
3022 #define IS_BASE64(Character) \
3023 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3024 #define IS_BASE64_IGNORABLE(Character) \
3025 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3026 || (Character) == '\f' || (Character) == '\r')
3028 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3029 character or return retval if there are no characters left to
3031 #define READ_QUADRUPLET_BYTE(retval) \
3036 if (nchars_return) \
3037 *nchars_return = nchars; \
3042 while (IS_BASE64_IGNORABLE (c))
3044 /* Table of characters coding the 64 values. */
3045 static const char base64_value_to_char
[64] =
3047 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3048 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3049 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3050 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3051 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3052 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3053 '8', '9', '+', '/' /* 60-63 */
3056 /* Table of base64 values for first 128 characters. */
3057 static const short base64_char_to_value
[128] =
3059 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3060 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3061 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3062 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3063 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3064 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3065 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3066 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3067 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3068 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3069 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3070 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3071 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3074 /* The following diagram shows the logical steps by which three octets
3075 get transformed into four base64 characters.
3077 .--------. .--------. .--------.
3078 |aaaaaabb| |bbbbcccc| |ccdddddd|
3079 `--------' `--------' `--------'
3081 .--------+--------+--------+--------.
3082 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3083 `--------+--------+--------+--------'
3085 .--------+--------+--------+--------.
3086 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3087 `--------+--------+--------+--------'
3089 The octets are divided into 6 bit chunks, which are then encoded into
3090 base64 characters. */
3093 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3094 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3097 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3099 doc
: /* Base64-encode the region between BEG and END.
3100 Return the length of the encoded text.
3101 Optional third argument NO-LINE-BREAK means do not break long lines
3102 into shorter lines. */)
3103 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3106 ptrdiff_t allength
, length
;
3107 ptrdiff_t ibeg
, iend
, encoded_length
;
3108 ptrdiff_t old_pos
= PT
;
3111 validate_region (&beg
, &end
);
3113 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3114 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3115 move_gap_both (XFASTINT (beg
), ibeg
);
3117 /* We need to allocate enough room for encoding the text.
3118 We need 33 1/3% more space, plus a newline every 76
3119 characters, and then we round up. */
3120 length
= iend
- ibeg
;
3121 allength
= length
+ length
/3 + 1;
3122 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3124 encoded
= SAFE_ALLOCA (allength
);
3125 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3126 encoded
, length
, NILP (no_line_break
),
3127 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3128 if (encoded_length
> allength
)
3131 if (encoded_length
< 0)
3133 /* The encoding wasn't possible. */
3135 error ("Multibyte character in data for base64 encoding");
3138 /* Now we have encoded the region, so we insert the new contents
3139 and delete the old. (Insert first in order to preserve markers.) */
3140 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3141 insert (encoded
, encoded_length
);
3143 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3145 /* If point was outside of the region, restore it exactly; else just
3146 move to the beginning of the region. */
3147 if (old_pos
>= XFASTINT (end
))
3148 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3149 else if (old_pos
> XFASTINT (beg
))
3150 old_pos
= XFASTINT (beg
);
3153 /* We return the length of the encoded text. */
3154 return make_number (encoded_length
);
3157 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3159 doc
: /* Base64-encode STRING and return the result.
3160 Optional second argument NO-LINE-BREAK means do not break long lines
3161 into shorter lines. */)
3162 (Lisp_Object string
, Lisp_Object no_line_break
)
3164 ptrdiff_t allength
, length
, encoded_length
;
3166 Lisp_Object encoded_string
;
3169 CHECK_STRING (string
);
3171 /* We need to allocate enough room for encoding the text.
3172 We need 33 1/3% more space, plus a newline every 76
3173 characters, and then we round up. */
3174 length
= SBYTES (string
);
3175 allength
= length
+ length
/3 + 1;
3176 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3178 /* We need to allocate enough room for decoding the text. */
3179 encoded
= SAFE_ALLOCA (allength
);
3181 encoded_length
= base64_encode_1 (SSDATA (string
),
3182 encoded
, length
, NILP (no_line_break
),
3183 STRING_MULTIBYTE (string
));
3184 if (encoded_length
> allength
)
3187 if (encoded_length
< 0)
3189 /* The encoding wasn't possible. */
3190 error ("Multibyte character in data for base64 encoding");
3193 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3196 return encoded_string
;
3200 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3201 bool line_break
, bool multibyte
)
3214 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3215 if (CHAR_BYTE8_P (c
))
3216 c
= CHAR_TO_BYTE8 (c
);
3224 /* Wrap line every 76 characters. */
3228 if (counter
< MIME_LINE_LENGTH
/ 4)
3237 /* Process first byte of a triplet. */
3239 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3240 value
= (0x03 & c
) << 4;
3242 /* Process second byte of a triplet. */
3246 *e
++ = base64_value_to_char
[value
];
3254 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3255 if (CHAR_BYTE8_P (c
))
3256 c
= CHAR_TO_BYTE8 (c
);
3264 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3265 value
= (0x0f & c
) << 2;
3267 /* Process third byte of a triplet. */
3271 *e
++ = base64_value_to_char
[value
];
3278 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3279 if (CHAR_BYTE8_P (c
))
3280 c
= CHAR_TO_BYTE8 (c
);
3288 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3289 *e
++ = base64_value_to_char
[0x3f & c
];
3296 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3298 doc
: /* Base64-decode the region between BEG and END.
3299 Return the length of the decoded text.
3300 If the region can't be decoded, signal an error and don't modify the buffer. */)
3301 (Lisp_Object beg
, Lisp_Object end
)
3303 ptrdiff_t ibeg
, iend
, length
, allength
;
3305 ptrdiff_t old_pos
= PT
;
3306 ptrdiff_t decoded_length
;
3307 ptrdiff_t inserted_chars
;
3308 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3311 validate_region (&beg
, &end
);
3313 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3314 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3316 length
= iend
- ibeg
;
3318 /* We need to allocate enough room for decoding the text. If we are
3319 working on a multibyte buffer, each decoded code may occupy at
3321 allength
= multibyte
? length
* 2 : length
;
3322 decoded
= SAFE_ALLOCA (allength
);
3324 move_gap_both (XFASTINT (beg
), ibeg
);
3325 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3327 multibyte
, &inserted_chars
);
3328 if (decoded_length
> allength
)
3331 if (decoded_length
< 0)
3333 /* The decoding wasn't possible. */
3334 error ("Invalid base64 data");
3337 /* Now we have decoded the region, so we insert the new contents
3338 and delete the old. (Insert first in order to preserve markers.) */
3339 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3340 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3343 /* Delete the original text. */
3344 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3345 iend
+ decoded_length
, 1);
3347 /* If point was outside of the region, restore it exactly; else just
3348 move to the beginning of the region. */
3349 if (old_pos
>= XFASTINT (end
))
3350 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3351 else if (old_pos
> XFASTINT (beg
))
3352 old_pos
= XFASTINT (beg
);
3353 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3355 return make_number (inserted_chars
);
3358 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3360 doc
: /* Base64-decode STRING and return the result. */)
3361 (Lisp_Object string
)
3364 ptrdiff_t length
, decoded_length
;
3365 Lisp_Object decoded_string
;
3368 CHECK_STRING (string
);
3370 length
= SBYTES (string
);
3371 /* We need to allocate enough room for decoding the text. */
3372 decoded
= SAFE_ALLOCA (length
);
3374 /* The decoded result should be unibyte. */
3375 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3377 if (decoded_length
> length
)
3379 else if (decoded_length
>= 0)
3380 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3382 decoded_string
= Qnil
;
3385 if (!STRINGP (decoded_string
))
3386 error ("Invalid base64 data");
3388 return decoded_string
;
3391 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3392 MULTIBYTE, the decoded result should be in multibyte
3393 form. If NCHARS_RETURN is not NULL, store the number of produced
3394 characters in *NCHARS_RETURN. */
3397 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3398 bool multibyte
, ptrdiff_t *nchars_return
)
3400 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3403 unsigned long value
;
3404 ptrdiff_t nchars
= 0;
3408 /* Process first byte of a quadruplet. */
3410 READ_QUADRUPLET_BYTE (e
-to
);
3414 value
= base64_char_to_value
[c
] << 18;
3416 /* Process second byte of a quadruplet. */
3418 READ_QUADRUPLET_BYTE (-1);
3422 value
|= base64_char_to_value
[c
] << 12;
3424 c
= (unsigned char) (value
>> 16);
3425 if (multibyte
&& c
>= 128)
3426 e
+= BYTE8_STRING (c
, e
);
3431 /* Process third byte of a quadruplet. */
3433 READ_QUADRUPLET_BYTE (-1);
3437 READ_QUADRUPLET_BYTE (-1);
3446 value
|= base64_char_to_value
[c
] << 6;
3448 c
= (unsigned char) (0xff & value
>> 8);
3449 if (multibyte
&& c
>= 128)
3450 e
+= BYTE8_STRING (c
, e
);
3455 /* Process fourth byte of a quadruplet. */
3457 READ_QUADRUPLET_BYTE (-1);
3464 value
|= base64_char_to_value
[c
];
3466 c
= (unsigned char) (0xff & value
);
3467 if (multibyte
&& c
>= 128)
3468 e
+= BYTE8_STRING (c
, e
);
3477 /***********************************************************************
3479 ***** Hash Tables *****
3481 ***********************************************************************/
3483 /* Implemented by gerd@gnu.org. This hash table implementation was
3484 inspired by CMUCL hash tables. */
3488 1. For small tables, association lists are probably faster than
3489 hash tables because they have lower overhead.
3491 For uses of hash tables where the O(1) behavior of table
3492 operations is not a requirement, it might therefore be a good idea
3493 not to hash. Instead, we could just do a linear search in the
3494 key_and_value vector of the hash table. This could be done
3495 if a `:linear-search t' argument is given to make-hash-table. */
3498 /* The list of all weak hash tables. Don't staticpro this one. */
3500 static struct Lisp_Hash_Table
*weak_hash_tables
;
3503 /***********************************************************************
3505 ***********************************************************************/
3508 CHECK_HASH_TABLE (Lisp_Object x
)
3510 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3514 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3516 h
->key_and_value
= key_and_value
;
3519 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3524 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3526 gc_aset (h
->next
, idx
, val
);
3529 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3534 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3536 gc_aset (h
->hash
, idx
, val
);
3539 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3544 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3546 gc_aset (h
->index
, idx
, val
);
3549 /* If OBJ is a Lisp hash table, return a pointer to its struct
3550 Lisp_Hash_Table. Otherwise, signal an error. */
3552 static struct Lisp_Hash_Table
*
3553 check_hash_table (Lisp_Object obj
)
3555 CHECK_HASH_TABLE (obj
);
3556 return XHASH_TABLE (obj
);
3560 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3561 number. A number is "almost" a prime number if it is not divisible
3562 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3565 next_almost_prime (EMACS_INT n
)
3567 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3568 for (n
|= 1; ; n
+= 2)
3569 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3574 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3575 which USED[I] is non-zero. If found at index I in ARGS, set
3576 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3577 0. This function is used to extract a keyword/argument pair from
3578 a DEFUN parameter list. */
3581 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3585 for (i
= 1; i
< nargs
; i
++)
3586 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3597 /* Return a Lisp vector which has the same contents as VEC but has
3598 at least INCR_MIN more entries, where INCR_MIN is positive.
3599 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3600 than NITEMS_MAX. Entries in the resulting
3601 vector that are not copied from VEC are set to nil. */
3604 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3606 struct Lisp_Vector
*v
;
3607 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3608 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3609 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3610 ? nitems_max
: C_language_max
);
3611 eassert (VECTORP (vec
));
3612 eassert (0 < incr_min
&& -1 <= nitems_max
);
3613 old_size
= ASIZE (vec
);
3614 incr_max
= n_max
- old_size
;
3615 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3616 if (incr_max
< incr
)
3617 memory_full (SIZE_MAX
);
3618 new_size
= old_size
+ incr
;
3619 v
= allocate_vector (new_size
);
3620 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3621 memclear (v
->contents
+ old_size
, incr
* word_size
);
3622 XSETVECTOR (vec
, v
);
3627 /***********************************************************************
3629 ***********************************************************************/
3631 struct hash_table_test hashtest_eq
, hashtest_eql
, hashtest_equal
;
3633 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3634 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3635 KEY2 are the same. */
3638 cmpfn_eql (struct hash_table_test
*ht
,
3642 return (FLOATP (key1
)
3644 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3648 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3649 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3650 KEY2 are the same. */
3653 cmpfn_equal (struct hash_table_test
*ht
,
3657 return !NILP (Fequal (key1
, key2
));
3661 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3662 HASH2 in hash table H using H->user_cmp_function. Value is true
3663 if KEY1 and KEY2 are the same. */
3666 cmpfn_user_defined (struct hash_table_test
*ht
,
3670 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3674 /* Value is a hash code for KEY for use in hash table H which uses
3675 `eq' to compare keys. The hash code returned is guaranteed to fit
3676 in a Lisp integer. */
3679 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3681 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3685 /* Value is a hash code for KEY for use in hash table H which uses
3686 `eql' to compare keys. The hash code returned is guaranteed to fit
3687 in a Lisp integer. */
3690 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3694 hash
= sxhash (key
, 0);
3696 hash
= XHASH (key
) ^ XTYPE (key
);
3700 /* Value is a hash code for KEY for use in hash table H which uses
3701 `equal' to compare keys. The hash code returned is guaranteed to fit
3702 in a Lisp integer. */
3705 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3707 EMACS_UINT hash
= sxhash (key
, 0);
3711 /* Value is a hash code for KEY for use in hash table H which uses as
3712 user-defined function to compare keys. The hash code returned is
3713 guaranteed to fit in a Lisp integer. */
3716 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3718 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3719 return hashfn_eq (ht
, hash
);
3722 /* Allocate basically initialized hash table. */
3724 static struct Lisp_Hash_Table
*
3725 allocate_hash_table (void)
3727 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3728 count
, PVEC_HASH_TABLE
);
3731 /* An upper bound on the size of a hash table index. It must fit in
3732 ptrdiff_t and be a valid Emacs fixnum. */
3733 #define INDEX_SIZE_BOUND \
3734 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3736 /* Create and initialize a new hash table.
3738 TEST specifies the test the hash table will use to compare keys.
3739 It must be either one of the predefined tests `eq', `eql' or
3740 `equal' or a symbol denoting a user-defined test named TEST with
3741 test and hash functions USER_TEST and USER_HASH.
3743 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3745 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3746 new size when it becomes full is computed by adding REHASH_SIZE to
3747 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3748 table's new size is computed by multiplying its old size with
3751 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3752 be resized when the ratio of (number of entries in the table) /
3753 (table size) is >= REHASH_THRESHOLD.
3755 WEAK specifies the weakness of the table. If non-nil, it must be
3756 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3759 make_hash_table (struct hash_table_test test
,
3760 Lisp_Object size
, Lisp_Object rehash_size
,
3761 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3763 struct Lisp_Hash_Table
*h
;
3765 EMACS_INT index_size
, sz
;
3769 /* Preconditions. */
3770 eassert (SYMBOLP (test
.name
));
3771 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3772 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3773 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3774 eassert (FLOATP (rehash_threshold
)
3775 && 0 < XFLOAT_DATA (rehash_threshold
)
3776 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3778 if (XFASTINT (size
) == 0)
3779 size
= make_number (1);
3781 sz
= XFASTINT (size
);
3782 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3783 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3784 ? next_almost_prime (index_float
)
3785 : INDEX_SIZE_BOUND
+ 1);
3786 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3787 error ("Hash table too large");
3789 /* Allocate a table and initialize it. */
3790 h
= allocate_hash_table ();
3792 /* Initialize hash table slots. */
3795 h
->rehash_threshold
= rehash_threshold
;
3796 h
->rehash_size
= rehash_size
;
3798 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3799 h
->hash
= Fmake_vector (size
, Qnil
);
3800 h
->next
= Fmake_vector (size
, Qnil
);
3801 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3803 /* Set up the free list. */
3804 for (i
= 0; i
< sz
- 1; ++i
)
3805 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3806 h
->next_free
= make_number (0);
3808 XSET_HASH_TABLE (table
, h
);
3809 eassert (HASH_TABLE_P (table
));
3810 eassert (XHASH_TABLE (table
) == h
);
3812 /* Maybe add this hash table to the list of all weak hash tables. */
3814 h
->next_weak
= NULL
;
3817 h
->next_weak
= weak_hash_tables
;
3818 weak_hash_tables
= h
;
3825 /* Return a copy of hash table H1. Keys and values are not copied,
3826 only the table itself is. */
3829 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3832 struct Lisp_Hash_Table
*h2
;
3834 h2
= allocate_hash_table ();
3836 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3837 h2
->hash
= Fcopy_sequence (h1
->hash
);
3838 h2
->next
= Fcopy_sequence (h1
->next
);
3839 h2
->index
= Fcopy_sequence (h1
->index
);
3840 XSET_HASH_TABLE (table
, h2
);
3842 /* Maybe add this hash table to the list of all weak hash tables. */
3843 if (!NILP (h2
->weak
))
3845 h2
->next_weak
= weak_hash_tables
;
3846 weak_hash_tables
= h2
;
3853 /* Resize hash table H if it's too full. If H cannot be resized
3854 because it's already too large, throw an error. */
3857 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3859 if (NILP (h
->next_free
))
3861 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3862 EMACS_INT new_size
, index_size
, nsize
;
3866 if (INTEGERP (h
->rehash_size
))
3867 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3870 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3871 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3873 new_size
= float_new_size
;
3874 if (new_size
<= old_size
)
3875 new_size
= old_size
+ 1;
3878 new_size
= INDEX_SIZE_BOUND
+ 1;
3880 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3881 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3882 ? next_almost_prime (index_float
)
3883 : INDEX_SIZE_BOUND
+ 1);
3884 nsize
= max (index_size
, 2 * new_size
);
3885 if (INDEX_SIZE_BOUND
< nsize
)
3886 error ("Hash table too large to resize");
3888 #ifdef ENABLE_CHECKING
3889 if (HASH_TABLE_P (Vpurify_flag
)
3890 && XHASH_TABLE (Vpurify_flag
) == h
)
3891 message ("Growing hash table to: %"pI
"d", new_size
);
3894 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3895 2 * (new_size
- old_size
), -1));
3896 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3897 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3898 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3900 /* Update the free list. Do it so that new entries are added at
3901 the end of the free list. This makes some operations like
3903 for (i
= old_size
; i
< new_size
- 1; ++i
)
3904 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3906 if (!NILP (h
->next_free
))
3908 Lisp_Object last
, next
;
3910 last
= h
->next_free
;
3911 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3915 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3918 XSETFASTINT (h
->next_free
, old_size
);
3921 for (i
= 0; i
< old_size
; ++i
)
3922 if (!NILP (HASH_HASH (h
, i
)))
3924 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3925 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3926 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3927 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3933 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3934 the hash code of KEY. Value is the index of the entry in H
3935 matching KEY, or -1 if not found. */
3938 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3940 EMACS_UINT hash_code
;
3941 ptrdiff_t start_of_bucket
;
3944 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3945 eassert ((hash_code
& ~INTMASK
) == 0);
3949 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3950 idx
= HASH_INDEX (h
, start_of_bucket
);
3954 ptrdiff_t i
= XFASTINT (idx
);
3955 if (EQ (key
, HASH_KEY (h
, i
))
3957 && hash_code
== XUINT (HASH_HASH (h
, i
))
3958 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3960 idx
= HASH_NEXT (h
, i
);
3963 return NILP (idx
) ? -1 : XFASTINT (idx
);
3967 /* Put an entry into hash table H that associates KEY with VALUE.
3968 HASH is a previously computed hash code of KEY.
3969 Value is the index of the entry in H matching KEY. */
3972 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3975 ptrdiff_t start_of_bucket
, i
;
3977 eassert ((hash
& ~INTMASK
) == 0);
3979 /* Increment count after resizing because resizing may fail. */
3980 maybe_resize_hash_table (h
);
3983 /* Store key/value in the key_and_value vector. */
3984 i
= XFASTINT (h
->next_free
);
3985 h
->next_free
= HASH_NEXT (h
, i
);
3986 set_hash_key_slot (h
, i
, key
);
3987 set_hash_value_slot (h
, i
, value
);
3989 /* Remember its hash code. */
3990 set_hash_hash_slot (h
, i
, make_number (hash
));
3992 /* Add new entry to its collision chain. */
3993 start_of_bucket
= hash
% ASIZE (h
->index
);
3994 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3995 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4000 /* Remove the entry matching KEY from hash table H, if there is one. */
4003 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4005 EMACS_UINT hash_code
;
4006 ptrdiff_t start_of_bucket
;
4007 Lisp_Object idx
, prev
;
4009 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4010 eassert ((hash_code
& ~INTMASK
) == 0);
4011 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4012 idx
= HASH_INDEX (h
, start_of_bucket
);
4017 ptrdiff_t i
= XFASTINT (idx
);
4019 if (EQ (key
, HASH_KEY (h
, i
))
4021 && hash_code
== XUINT (HASH_HASH (h
, i
))
4022 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4024 /* Take entry out of collision chain. */
4026 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4028 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4030 /* Clear slots in key_and_value and add the slots to
4032 set_hash_key_slot (h
, i
, Qnil
);
4033 set_hash_value_slot (h
, i
, Qnil
);
4034 set_hash_hash_slot (h
, i
, Qnil
);
4035 set_hash_next_slot (h
, i
, h
->next_free
);
4036 h
->next_free
= make_number (i
);
4038 eassert (h
->count
>= 0);
4044 idx
= HASH_NEXT (h
, i
);
4050 /* Clear hash table H. */
4053 hash_clear (struct Lisp_Hash_Table
*h
)
4057 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4059 for (i
= 0; i
< size
; ++i
)
4061 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4062 set_hash_key_slot (h
, i
, Qnil
);
4063 set_hash_value_slot (h
, i
, Qnil
);
4064 set_hash_hash_slot (h
, i
, Qnil
);
4067 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4068 ASET (h
->index
, i
, Qnil
);
4070 h
->next_free
= make_number (0);
4077 /************************************************************************
4079 ************************************************************************/
4081 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4082 entries from the table that don't survive the current GC.
4083 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4084 true if anything was marked. */
4087 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4089 ptrdiff_t n
= gc_asize (h
->index
);
4090 bool marked
= false;
4092 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4094 Lisp_Object idx
, next
, prev
;
4096 /* Follow collision chain, removing entries that
4097 don't survive this garbage collection. */
4099 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4101 ptrdiff_t i
= XFASTINT (idx
);
4102 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4103 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4106 if (EQ (h
->weak
, Qkey
))
4107 remove_p
= !key_known_to_survive_p
;
4108 else if (EQ (h
->weak
, Qvalue
))
4109 remove_p
= !value_known_to_survive_p
;
4110 else if (EQ (h
->weak
, Qkey_or_value
))
4111 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4112 else if (EQ (h
->weak
, Qkey_and_value
))
4113 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4117 next
= HASH_NEXT (h
, i
);
4119 if (remove_entries_p
)
4123 /* Take out of collision chain. */
4125 set_hash_index_slot (h
, bucket
, next
);
4127 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4129 /* Add to free list. */
4130 set_hash_next_slot (h
, i
, h
->next_free
);
4133 /* Clear key, value, and hash. */
4134 set_hash_key_slot (h
, i
, Qnil
);
4135 set_hash_value_slot (h
, i
, Qnil
);
4136 set_hash_hash_slot (h
, i
, Qnil
);
4149 /* Make sure key and value survive. */
4150 if (!key_known_to_survive_p
)
4152 mark_object (HASH_KEY (h
, i
));
4156 if (!value_known_to_survive_p
)
4158 mark_object (HASH_VALUE (h
, i
));
4169 /* Remove elements from weak hash tables that don't survive the
4170 current garbage collection. Remove weak tables that don't survive
4171 from Vweak_hash_tables. Called from gc_sweep. */
4173 NO_INLINE
/* For better stack traces */
4175 sweep_weak_hash_tables (void)
4177 struct Lisp_Hash_Table
*h
, *used
, *next
;
4180 /* Mark all keys and values that are in use. Keep on marking until
4181 there is no more change. This is necessary for cases like
4182 value-weak table A containing an entry X -> Y, where Y is used in a
4183 key-weak table B, Z -> Y. If B comes after A in the list of weak
4184 tables, X -> Y might be removed from A, although when looking at B
4185 one finds that it shouldn't. */
4189 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4191 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4192 marked
|= sweep_weak_table (h
, 0);
4197 /* Remove tables and entries that aren't used. */
4198 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4200 next
= h
->next_weak
;
4202 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4204 /* TABLE is marked as used. Sweep its contents. */
4206 sweep_weak_table (h
, 1);
4208 /* Add table to the list of used weak hash tables. */
4209 h
->next_weak
= used
;
4214 weak_hash_tables
= used
;
4219 /***********************************************************************
4220 Hash Code Computation
4221 ***********************************************************************/
4223 /* Maximum depth up to which to dive into Lisp structures. */
4225 #define SXHASH_MAX_DEPTH 3
4227 /* Maximum length up to which to take list and vector elements into
4230 #define SXHASH_MAX_LEN 7
4232 /* Return a hash for string PTR which has length LEN. The hash value
4233 can be any EMACS_UINT value. */
4236 hash_string (char const *ptr
, ptrdiff_t len
)
4238 char const *p
= ptr
;
4239 char const *end
= p
+ len
;
4241 EMACS_UINT hash
= 0;
4246 hash
= sxhash_combine (hash
, c
);
4252 /* Return a hash for string PTR which has length LEN. The hash
4253 code returned is guaranteed to fit in a Lisp integer. */
4256 sxhash_string (char const *ptr
, ptrdiff_t len
)
4258 EMACS_UINT hash
= hash_string (ptr
, len
);
4259 return SXHASH_REDUCE (hash
);
4262 /* Return a hash for the floating point value VAL. */
4265 sxhash_float (double val
)
4267 EMACS_UINT hash
= 0;
4269 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4270 + (sizeof val
% sizeof hash
!= 0))
4274 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4278 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4279 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4280 hash
= sxhash_combine (hash
, u
.word
[i
]);
4281 return SXHASH_REDUCE (hash
);
4284 /* Return a hash for list LIST. DEPTH is the current depth in the
4285 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4288 sxhash_list (Lisp_Object list
, int depth
)
4290 EMACS_UINT hash
= 0;
4293 if (depth
< SXHASH_MAX_DEPTH
)
4295 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4296 list
= XCDR (list
), ++i
)
4298 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4299 hash
= sxhash_combine (hash
, hash2
);
4304 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4305 hash
= sxhash_combine (hash
, hash2
);
4308 return SXHASH_REDUCE (hash
);
4312 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4313 the Lisp structure. */
4316 sxhash_vector (Lisp_Object vec
, int depth
)
4318 EMACS_UINT hash
= ASIZE (vec
);
4321 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4322 for (i
= 0; i
< n
; ++i
)
4324 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4325 hash
= sxhash_combine (hash
, hash2
);
4328 return SXHASH_REDUCE (hash
);
4331 /* Return a hash for bool-vector VECTOR. */
4334 sxhash_bool_vector (Lisp_Object vec
)
4336 EMACS_INT size
= bool_vector_size (vec
);
4337 EMACS_UINT hash
= size
;
4340 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4341 for (i
= 0; i
< n
; ++i
)
4342 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4344 return SXHASH_REDUCE (hash
);
4348 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4349 structure. Value is an unsigned integer clipped to INTMASK. */
4352 sxhash (Lisp_Object obj
, int depth
)
4356 if (depth
> SXHASH_MAX_DEPTH
)
4359 switch (XTYPE (obj
))
4371 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4374 /* This can be everything from a vector to an overlay. */
4375 case Lisp_Vectorlike
:
4377 /* According to the CL HyperSpec, two arrays are equal only if
4378 they are `eq', except for strings and bit-vectors. In
4379 Emacs, this works differently. We have to compare element
4381 hash
= sxhash_vector (obj
, depth
);
4382 else if (BOOL_VECTOR_P (obj
))
4383 hash
= sxhash_bool_vector (obj
);
4385 /* Others are `equal' if they are `eq', so let's take their
4391 hash
= sxhash_list (obj
, depth
);
4395 hash
= sxhash_float (XFLOAT_DATA (obj
));
4407 /***********************************************************************
4409 ***********************************************************************/
4412 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4413 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4416 EMACS_UINT hash
= sxhash (obj
, 0);
4417 return make_number (hash
);
4421 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4422 doc
: /* Create and return a new hash table.
4424 Arguments are specified as keyword/argument pairs. The following
4425 arguments are defined:
4427 :test TEST -- TEST must be a symbol that specifies how to compare
4428 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4429 `equal'. User-supplied test and hash functions can be specified via
4430 `define-hash-table-test'.
4432 :size SIZE -- A hint as to how many elements will be put in the table.
4435 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4436 fills up. If REHASH-SIZE is an integer, increase the size by that
4437 amount. If it is a float, it must be > 1.0, and the new size is the
4438 old size multiplied by that factor. Default is 1.5.
4440 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4441 Resize the hash table when the ratio (number of entries / table size)
4442 is greater than or equal to THRESHOLD. Default is 0.8.
4444 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4445 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4446 returned is a weak table. Key/value pairs are removed from a weak
4447 hash table when there are no non-weak references pointing to their
4448 key, value, one of key or value, or both key and value, depending on
4449 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4452 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4453 (ptrdiff_t nargs
, Lisp_Object
*args
)
4455 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4456 struct hash_table_test testdesc
;
4460 /* The vector `used' is used to keep track of arguments that
4461 have been consumed. */
4462 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4463 memset (used
, 0, nargs
* sizeof *used
);
4465 /* See if there's a `:test TEST' among the arguments. */
4466 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4467 test
= i
? args
[i
] : Qeql
;
4469 testdesc
= hashtest_eq
;
4470 else if (EQ (test
, Qeql
))
4471 testdesc
= hashtest_eql
;
4472 else if (EQ (test
, Qequal
))
4473 testdesc
= hashtest_equal
;
4476 /* See if it is a user-defined test. */
4479 prop
= Fget (test
, Qhash_table_test
);
4480 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4481 signal_error ("Invalid hash table test", test
);
4482 testdesc
.name
= test
;
4483 testdesc
.user_cmp_function
= XCAR (prop
);
4484 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4485 testdesc
.hashfn
= hashfn_user_defined
;
4486 testdesc
.cmpfn
= cmpfn_user_defined
;
4489 /* See if there's a `:size SIZE' argument. */
4490 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4491 size
= i
? args
[i
] : Qnil
;
4493 size
= make_number (DEFAULT_HASH_SIZE
);
4494 else if (!INTEGERP (size
) || XINT (size
) < 0)
4495 signal_error ("Invalid hash table size", size
);
4497 /* Look for `:rehash-size SIZE'. */
4498 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4499 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4500 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4501 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4502 signal_error ("Invalid hash table rehash size", rehash_size
);
4504 /* Look for `:rehash-threshold THRESHOLD'. */
4505 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4506 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4507 if (! (FLOATP (rehash_threshold
)
4508 && 0 < XFLOAT_DATA (rehash_threshold
)
4509 && XFLOAT_DATA (rehash_threshold
) <= 1))
4510 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4512 /* Look for `:weakness WEAK'. */
4513 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4514 weak
= i
? args
[i
] : Qnil
;
4516 weak
= Qkey_and_value
;
4519 && !EQ (weak
, Qvalue
)
4520 && !EQ (weak
, Qkey_or_value
)
4521 && !EQ (weak
, Qkey_and_value
))
4522 signal_error ("Invalid hash table weakness", weak
);
4524 /* Now, all args should have been used up, or there's a problem. */
4525 for (i
= 0; i
< nargs
; ++i
)
4527 signal_error ("Invalid argument list", args
[i
]);
4530 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4534 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4535 doc
: /* Return a copy of hash table TABLE. */)
4538 return copy_hash_table (check_hash_table (table
));
4542 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4543 doc
: /* Return the number of elements in TABLE. */)
4546 return make_number (check_hash_table (table
)->count
);
4550 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4551 Shash_table_rehash_size
, 1, 1, 0,
4552 doc
: /* Return the current rehash size of TABLE. */)
4555 return check_hash_table (table
)->rehash_size
;
4559 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4560 Shash_table_rehash_threshold
, 1, 1, 0,
4561 doc
: /* Return the current rehash threshold of TABLE. */)
4564 return check_hash_table (table
)->rehash_threshold
;
4568 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4569 doc
: /* Return the size of TABLE.
4570 The size can be used as an argument to `make-hash-table' to create
4571 a hash table than can hold as many elements as TABLE holds
4572 without need for resizing. */)
4575 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4576 return make_number (HASH_TABLE_SIZE (h
));
4580 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4581 doc
: /* Return the test TABLE uses. */)
4584 return check_hash_table (table
)->test
.name
;
4588 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4590 doc
: /* Return the weakness of TABLE. */)
4593 return check_hash_table (table
)->weak
;
4597 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4598 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4601 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4605 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4606 doc
: /* Clear hash table TABLE and return it. */)
4609 hash_clear (check_hash_table (table
));
4610 /* Be compatible with XEmacs. */
4615 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4616 doc
: /* Look up KEY in TABLE and return its associated value.
4617 If KEY is not found, return DFLT which defaults to nil. */)
4618 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4620 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4621 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4622 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4626 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4627 doc
: /* Associate KEY with VALUE in hash table TABLE.
4628 If KEY is already present in table, replace its current value with
4629 VALUE. In any case, return VALUE. */)
4630 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4632 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4636 i
= hash_lookup (h
, key
, &hash
);
4638 set_hash_value_slot (h
, i
, value
);
4640 hash_put (h
, key
, value
, hash
);
4646 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4647 doc
: /* Remove KEY from TABLE. */)
4648 (Lisp_Object key
, Lisp_Object table
)
4650 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4651 hash_remove_from_table (h
, key
);
4656 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4657 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4658 FUNCTION is called with two arguments, KEY and VALUE.
4659 `maphash' always returns nil. */)
4660 (Lisp_Object function
, Lisp_Object table
)
4662 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4664 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4665 if (!NILP (HASH_HASH (h
, i
)))
4666 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4672 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4673 Sdefine_hash_table_test
, 3, 3, 0,
4674 doc
: /* Define a new hash table test with name NAME, a symbol.
4676 In hash tables created with NAME specified as test, use TEST to
4677 compare keys, and HASH for computing hash codes of keys.
4679 TEST must be a function taking two arguments and returning non-nil if
4680 both arguments are the same. HASH must be a function taking one
4681 argument and returning an object that is the hash code of the argument.
4682 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4683 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4684 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4686 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4691 /************************************************************************
4692 MD5, SHA-1, and SHA-2
4693 ************************************************************************/
4700 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4703 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4704 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4708 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4709 register EMACS_INT b
, e
;
4710 register struct buffer
*bp
;
4713 void *(*hash_func
) (const char *, size_t, void *);
4716 CHECK_SYMBOL (algorithm
);
4718 if (STRINGP (object
))
4720 if (NILP (coding_system
))
4722 /* Decide the coding-system to encode the data with. */
4724 if (STRING_MULTIBYTE (object
))
4725 /* use default, we can't guess correct value */
4726 coding_system
= preferred_coding_system ();
4728 coding_system
= Qraw_text
;
4731 if (NILP (Fcoding_system_p (coding_system
)))
4733 /* Invalid coding system. */
4735 if (!NILP (noerror
))
4736 coding_system
= Qraw_text
;
4738 xsignal1 (Qcoding_system_error
, coding_system
);
4741 if (STRING_MULTIBYTE (object
))
4742 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4744 size
= SCHARS (object
);
4745 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4747 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4748 end_byte
= (end_char
== size
4750 : string_char_to_byte (object
, end_char
));
4754 struct buffer
*prev
= current_buffer
;
4756 record_unwind_current_buffer ();
4758 CHECK_BUFFER (object
);
4760 bp
= XBUFFER (object
);
4761 set_buffer_internal (bp
);
4767 CHECK_NUMBER_COERCE_MARKER (start
);
4775 CHECK_NUMBER_COERCE_MARKER (end
);
4780 temp
= b
, b
= e
, e
= temp
;
4782 if (!(BEGV
<= b
&& e
<= ZV
))
4783 args_out_of_range (start
, end
);
4785 if (NILP (coding_system
))
4787 /* Decide the coding-system to encode the data with.
4788 See fileio.c:Fwrite-region */
4790 if (!NILP (Vcoding_system_for_write
))
4791 coding_system
= Vcoding_system_for_write
;
4794 bool force_raw_text
= 0;
4796 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4797 if (NILP (coding_system
)
4798 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4800 coding_system
= Qnil
;
4801 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4805 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4807 /* Check file-coding-system-alist. */
4808 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4809 Qwrite_region
, start
, end
,
4810 Fbuffer_file_name (object
));
4811 if (CONSP (val
) && !NILP (XCDR (val
)))
4812 coding_system
= XCDR (val
);
4815 if (NILP (coding_system
)
4816 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4818 /* If we still have not decided a coding system, use the
4819 default value of buffer-file-coding-system. */
4820 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4824 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4825 /* Confirm that VAL can surely encode the current region. */
4826 coding_system
= call4 (Vselect_safe_coding_system_function
,
4827 make_number (b
), make_number (e
),
4828 coding_system
, Qnil
);
4831 coding_system
= Qraw_text
;
4834 if (NILP (Fcoding_system_p (coding_system
)))
4836 /* Invalid coding system. */
4838 if (!NILP (noerror
))
4839 coding_system
= Qraw_text
;
4841 xsignal1 (Qcoding_system_error
, coding_system
);
4845 object
= make_buffer_string (b
, e
, 0);
4846 set_buffer_internal (prev
);
4847 /* Discard the unwind protect for recovering the current
4851 if (STRING_MULTIBYTE (object
))
4852 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4854 end_byte
= SBYTES (object
);
4857 if (EQ (algorithm
, Qmd5
))
4859 digest_size
= MD5_DIGEST_SIZE
;
4860 hash_func
= md5_buffer
;
4862 else if (EQ (algorithm
, Qsha1
))
4864 digest_size
= SHA1_DIGEST_SIZE
;
4865 hash_func
= sha1_buffer
;
4867 else if (EQ (algorithm
, Qsha224
))
4869 digest_size
= SHA224_DIGEST_SIZE
;
4870 hash_func
= sha224_buffer
;
4872 else if (EQ (algorithm
, Qsha256
))
4874 digest_size
= SHA256_DIGEST_SIZE
;
4875 hash_func
= sha256_buffer
;
4877 else if (EQ (algorithm
, Qsha384
))
4879 digest_size
= SHA384_DIGEST_SIZE
;
4880 hash_func
= sha384_buffer
;
4882 else if (EQ (algorithm
, Qsha512
))
4884 digest_size
= SHA512_DIGEST_SIZE
;
4885 hash_func
= sha512_buffer
;
4888 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4890 /* allocate 2 x digest_size so that it can be re-used to hold the
4892 digest
= make_uninit_string (digest_size
* 2);
4894 hash_func (SSDATA (object
) + start_byte
,
4895 end_byte
- start_byte
,
4900 unsigned char *p
= SDATA (digest
);
4901 for (i
= digest_size
- 1; i
>= 0; i
--)
4903 static char const hexdigit
[16] = "0123456789abcdef";
4905 p
[2 * i
] = hexdigit
[p_i
>> 4];
4906 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4911 return make_unibyte_string (SSDATA (digest
), digest_size
);
4914 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4915 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4917 A message digest is a cryptographic checksum of a document, and the
4918 algorithm to calculate it is defined in RFC 1321.
4920 The two optional arguments START and END are character positions
4921 specifying for which part of OBJECT the message digest should be
4922 computed. If nil or omitted, the digest is computed for the whole
4925 The MD5 message digest is computed from the result of encoding the
4926 text in a coding system, not directly from the internal Emacs form of
4927 the text. The optional fourth argument CODING-SYSTEM specifies which
4928 coding system to encode the text with. It should be the same coding
4929 system that you used or will use when actually writing the text into a
4932 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4933 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4934 system would be chosen by default for writing this text into a file.
4936 If OBJECT is a string, the most preferred coding system (see the
4937 command `prefer-coding-system') is used.
4939 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4940 guesswork fails. Normally, an error is signaled in such case. */)
4941 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4943 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4946 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4947 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4948 ALGORITHM is a symbol specifying the hash to use:
4949 md5, sha1, sha224, sha256, sha384 or sha512.
4951 The two optional arguments START and END are positions specifying for
4952 which part of OBJECT to compute the hash. If nil or omitted, uses the
4955 If BINARY is non-nil, returns a string in binary form. */)
4956 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4958 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4964 DEFSYM (Qmd5
, "md5");
4965 DEFSYM (Qsha1
, "sha1");
4966 DEFSYM (Qsha224
, "sha224");
4967 DEFSYM (Qsha256
, "sha256");
4968 DEFSYM (Qsha384
, "sha384");
4969 DEFSYM (Qsha512
, "sha512");
4971 /* Hash table stuff. */
4972 DEFSYM (Qhash_table_p
, "hash-table-p");
4974 DEFSYM (Qeql
, "eql");
4975 DEFSYM (Qequal
, "equal");
4976 DEFSYM (QCtest
, ":test");
4977 DEFSYM (QCsize
, ":size");
4978 DEFSYM (QCrehash_size
, ":rehash-size");
4979 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4980 DEFSYM (QCweakness
, ":weakness");
4981 DEFSYM (Qkey
, "key");
4982 DEFSYM (Qvalue
, "value");
4983 DEFSYM (Qhash_table_test
, "hash-table-test");
4984 DEFSYM (Qkey_or_value
, "key-or-value");
4985 DEFSYM (Qkey_and_value
, "key-and-value");
4988 defsubr (&Smake_hash_table
);
4989 defsubr (&Scopy_hash_table
);
4990 defsubr (&Shash_table_count
);
4991 defsubr (&Shash_table_rehash_size
);
4992 defsubr (&Shash_table_rehash_threshold
);
4993 defsubr (&Shash_table_size
);
4994 defsubr (&Shash_table_test
);
4995 defsubr (&Shash_table_weakness
);
4996 defsubr (&Shash_table_p
);
4997 defsubr (&Sclrhash
);
4998 defsubr (&Sgethash
);
4999 defsubr (&Sputhash
);
5000 defsubr (&Sremhash
);
5001 defsubr (&Smaphash
);
5002 defsubr (&Sdefine_hash_table_test
);
5004 DEFSYM (Qstring_lessp
, "string-lessp");
5005 DEFSYM (Qprovide
, "provide");
5006 DEFSYM (Qrequire
, "require");
5007 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5008 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5009 DEFSYM (Qwidget_type
, "widget-type");
5011 staticpro (&string_char_byte_cache_string
);
5012 string_char_byte_cache_string
= Qnil
;
5014 require_nesting_list
= Qnil
;
5015 staticpro (&require_nesting_list
);
5017 Fset (Qyes_or_no_p_history
, Qnil
);
5019 DEFVAR_LISP ("features", Vfeatures
,
5020 doc
: /* A list of symbols which are the features of the executing Emacs.
5021 Used by `featurep' and `require', and altered by `provide'. */);
5022 Vfeatures
= list1 (Qemacs
);
5023 DEFSYM (Qsubfeatures
, "subfeatures");
5024 DEFSYM (Qfuncall
, "funcall");
5026 #ifdef HAVE_LANGINFO_CODESET
5027 DEFSYM (Qcodeset
, "codeset");
5028 DEFSYM (Qdays
, "days");
5029 DEFSYM (Qmonths
, "months");
5030 DEFSYM (Qpaper
, "paper");
5031 #endif /* HAVE_LANGINFO_CODESET */
5033 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5034 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5035 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5036 invoked by mouse clicks and mouse menu items.
5038 On some platforms, file selection dialogs are also enabled if this is
5042 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5043 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5044 This applies to commands from menus and tool bar buttons even when
5045 they are initiated from the keyboard. If `use-dialog-box' is nil,
5046 that disables the use of a file dialog, regardless of the value of
5048 use_file_dialog
= 1;
5050 defsubr (&Sidentity
);
5053 defsubr (&Ssafe_length
);
5054 defsubr (&Sstring_bytes
);
5055 defsubr (&Sstring_equal
);
5056 defsubr (&Scompare_strings
);
5057 defsubr (&Sstring_lessp
);
5058 defsubr (&Sstring_collate_lessp
);
5059 defsubr (&Sstring_collate_equalp
);
5062 defsubr (&Svconcat
);
5063 defsubr (&Scopy_sequence
);
5064 defsubr (&Sstring_make_multibyte
);
5065 defsubr (&Sstring_make_unibyte
);
5066 defsubr (&Sstring_as_multibyte
);
5067 defsubr (&Sstring_as_unibyte
);
5068 defsubr (&Sstring_to_multibyte
);
5069 defsubr (&Sstring_to_unibyte
);
5070 defsubr (&Scopy_alist
);
5071 defsubr (&Ssubstring
);
5072 defsubr (&Ssubstring_no_properties
);
5085 defsubr (&Snreverse
);
5086 defsubr (&Sreverse
);
5088 defsubr (&Splist_get
);
5090 defsubr (&Splist_put
);
5092 defsubr (&Slax_plist_get
);
5093 defsubr (&Slax_plist_put
);
5096 defsubr (&Sequal_including_properties
);
5097 defsubr (&Sfillarray
);
5098 defsubr (&Sclear_string
);
5102 defsubr (&Smapconcat
);
5103 defsubr (&Syes_or_no_p
);
5104 defsubr (&Sload_average
);
5105 defsubr (&Sfeaturep
);
5106 defsubr (&Srequire
);
5107 defsubr (&Sprovide
);
5108 defsubr (&Splist_member
);
5109 defsubr (&Swidget_put
);
5110 defsubr (&Swidget_get
);
5111 defsubr (&Swidget_apply
);
5112 defsubr (&Sbase64_encode_region
);
5113 defsubr (&Sbase64_decode_region
);
5114 defsubr (&Sbase64_encode_string
);
5115 defsubr (&Sbase64_decode_string
);
5117 defsubr (&Ssecure_hash
);
5118 defsubr (&Slocale_info
);
5120 hashtest_eq
.name
= Qeq
;
5121 hashtest_eq
.user_hash_function
= Qnil
;
5122 hashtest_eq
.user_cmp_function
= Qnil
;
5123 hashtest_eq
.cmpfn
= 0;
5124 hashtest_eq
.hashfn
= hashfn_eq
;
5126 hashtest_eql
.name
= Qeql
;
5127 hashtest_eql
.user_hash_function
= Qnil
;
5128 hashtest_eql
.user_cmp_function
= Qnil
;
5129 hashtest_eql
.cmpfn
= cmpfn_eql
;
5130 hashtest_eql
.hashfn
= hashfn_eql
;
5132 hashtest_equal
.name
= Qequal
;
5133 hashtest_equal
.user_hash_function
= Qnil
;
5134 hashtest_equal
.user_cmp_function
= Qnil
;
5135 hashtest_equal
.cmpfn
= cmpfn_equal
;
5136 hashtest_equal
.hashfn
= hashfn_equal
;