1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
31 #include "character.h"
36 #include "intervals.h"
39 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
44 Lisp_Object Qstring_lessp
, Qstring_collate_lessp
, Qstring_collate_equalp
;
45 static Lisp_Object Qprovide
, Qrequire
;
46 static Lisp_Object Qyes_or_no_p_history
;
47 Lisp_Object Qcursor_in_echo_area
;
48 static Lisp_Object Qwidget_type
;
49 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
51 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
53 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
54 Lisp_Object
[restrict
], Lisp_Object
[restrict
]);
55 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
57 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
58 doc
: /* Return the argument unchanged. */)
64 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
65 doc
: /* Return a pseudo-random number.
66 All integers representable in Lisp, i.e. between `most-negative-fixnum'
67 and `most-positive-fixnum', inclusive, are equally likely.
69 With positive integer LIMIT, return random number in interval [0,LIMIT).
70 With argument t, set the random number seed from the current time and pid.
71 With a string argument, set the seed based on the string's contents.
72 Other values of LIMIT are ignored.
74 See Info node `(elisp)Random Numbers' for more details. */)
81 else if (STRINGP (limit
))
82 seed_random (SSDATA (limit
), SBYTES (limit
));
85 if (INTEGERP (limit
) && 0 < XINT (limit
))
88 /* Return the remainder, except reject the rare case where
89 get_random returns a number so close to INTMASK that the
90 remainder isn't random. */
91 EMACS_INT remainder
= val
% XINT (limit
);
92 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
93 return make_number (remainder
);
96 return make_number (val
);
99 /* Heuristic on how many iterations of a tight loop can be safely done
100 before it's time to do a QUIT. This must be a power of 2. */
101 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
103 /* Random data-structure functions. */
106 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
108 CHECK_TYPE (NILP (x
), Qlistp
, y
);
111 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
112 doc
: /* Return the length of vector, list or string SEQUENCE.
113 A byte-code function object is also allowed.
114 If the string contains multibyte characters, this is not necessarily
115 the number of bytes in the string; it is the number of characters.
116 To get the number of bytes, use `string-bytes'. */)
117 (register Lisp_Object sequence
)
119 register Lisp_Object val
;
121 if (STRINGP (sequence
))
122 XSETFASTINT (val
, SCHARS (sequence
));
123 else if (VECTORP (sequence
))
124 XSETFASTINT (val
, ASIZE (sequence
));
125 else if (CHAR_TABLE_P (sequence
))
126 XSETFASTINT (val
, MAX_CHAR
);
127 else if (BOOL_VECTOR_P (sequence
))
128 XSETFASTINT (val
, bool_vector_size (sequence
));
129 else if (COMPILEDP (sequence
))
130 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
131 else if (CONSP (sequence
))
138 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
140 if (MOST_POSITIVE_FIXNUM
< i
)
141 error ("List too long");
144 sequence
= XCDR (sequence
);
146 while (CONSP (sequence
));
148 CHECK_LIST_END (sequence
, sequence
);
150 val
= make_number (i
);
152 else if (NILP (sequence
))
153 XSETFASTINT (val
, 0);
155 wrong_type_argument (Qsequencep
, sequence
);
160 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
161 doc
: /* Return the length of a list, but avoid error or infinite loop.
162 This function never gets an error. If LIST is not really a list,
163 it returns 0. If LIST is circular, it returns a finite value
164 which is at least the number of distinct elements. */)
167 Lisp_Object tail
, halftail
;
172 return make_number (0);
174 /* halftail is used to detect circular lists. */
175 for (tail
= halftail
= list
; ; )
180 if (EQ (tail
, halftail
))
183 if ((lolen
& 1) == 0)
185 halftail
= XCDR (halftail
);
186 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
190 hilen
+= UINTMAX_MAX
+ 1.0;
195 /* If the length does not fit into a fixnum, return a float.
196 On all known practical machines this returns an upper bound on
198 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
201 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
202 doc
: /* Return the number of bytes in STRING.
203 If STRING is multibyte, this may be greater than the length of STRING. */)
206 CHECK_STRING (string
);
207 return make_number (SBYTES (string
));
210 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
211 doc
: /* Return t if two strings have identical contents.
212 Case is significant, but text properties are ignored.
213 Symbols are also allowed; their print names are used instead. */)
214 (register Lisp_Object s1
, Lisp_Object s2
)
217 s1
= SYMBOL_NAME (s1
);
219 s2
= SYMBOL_NAME (s2
);
223 if (SCHARS (s1
) != SCHARS (s2
)
224 || SBYTES (s1
) != SBYTES (s2
)
225 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
230 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
231 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
232 The arguments START1, END1, START2, and END2, if non-nil, are
233 positions specifying which parts of STR1 or STR2 to compare. In
234 string STR1, compare the part between START1 (inclusive) and END1
235 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
236 the string; if END1 is nil, it defaults to the length of the string.
237 Likewise, in string STR2, compare the part between START2 and END2.
238 Like in `substring', negative values are counted from the end.
240 The strings are compared by the numeric values of their characters.
241 For instance, STR1 is "less than" STR2 if its first differing
242 character has a smaller numeric value. If IGNORE-CASE is non-nil,
243 characters are converted to lower-case before comparing them. Unibyte
244 strings are converted to multibyte for comparison.
246 The value is t if the strings (or specified portions) match.
247 If string STR1 is less, the value is a negative number N;
248 - 1 - N is the number of characters that match at the beginning.
249 If string STR1 is greater, the value is a positive number N;
250 N - 1 is the number of characters that match at the beginning. */)
251 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
252 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
254 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
259 /* For backward compatibility, silently bring too-large positive end
260 values into range. */
261 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
262 end1
= make_number (SCHARS (str1
));
263 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
264 end2
= make_number (SCHARS (str2
));
266 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
267 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
272 i1_byte
= string_char_to_byte (str1
, i1
);
273 i2_byte
= string_char_to_byte (str2
, i2
);
275 while (i1
< to1
&& i2
< to2
)
277 /* When we find a mismatch, we must compare the
278 characters, not just the bytes. */
281 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
282 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
287 if (! NILP (ignore_case
))
289 c1
= XINT (Fupcase (make_number (c1
)));
290 c2
= XINT (Fupcase (make_number (c2
)));
296 /* Note that I1 has already been incremented
297 past the character that we are comparing;
298 hence we don't add or subtract 1 here. */
300 return make_number (- i1
+ from1
);
302 return make_number (i1
- from1
);
306 return make_number (i1
- from1
+ 1);
308 return make_number (- i1
+ from1
- 1);
313 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
314 doc
: /* Return t if first arg string is less than second in lexicographic order.
316 Symbols are also allowed; their print names are used instead. */)
317 (register Lisp_Object s1
, Lisp_Object s2
)
319 register ptrdiff_t end
;
320 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
323 s1
= SYMBOL_NAME (s1
);
325 s2
= SYMBOL_NAME (s2
);
329 i1
= i1_byte
= i2
= i2_byte
= 0;
332 if (end
> SCHARS (s2
))
337 /* When we find a mismatch, we must compare the
338 characters, not just the bytes. */
341 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
342 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
345 return c1
< c2
? Qt
: Qnil
;
347 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
350 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
351 doc
: /* Return t if first arg string is less than second in collation order.
352 Symbols are also allowed; their print names are used instead.
354 This function obeys the conventions for collation order in your
355 locale settings. For example, punctuation and whitespace characters
356 might be considered less significant for sorting:
358 \(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
359 => \("11" "1 1" "1.1" "12" "1 2" "1.2")
361 The optional argument LOCALE, a string, overrides the setting of your
362 current locale identifier for collation. The value is system
363 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
364 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
366 If IGNORE-CASE is non-nil, characters are converted to lower-case
367 before comparing them.
369 To emulate Unicode-compliant collation on MS-Windows systems,
370 bind `w32-collate-ignore-punctuation' to a non-nil value, since
371 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
373 If your system does not support a locale environment, this function
374 behaves like `string-lessp'. */)
375 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
377 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
378 /* Check parameters. */
380 s1
= SYMBOL_NAME (s1
);
382 s2
= SYMBOL_NAME (s2
);
386 CHECK_STRING (locale
);
388 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
390 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
391 return Fstring_lessp (s1
, s2
);
392 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
395 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
396 doc
: /* Return t if two strings have identical contents.
397 Symbols are also allowed; their print names are used instead.
399 This function obeys the conventions for collation order in your locale
400 settings. For example, characters with different coding points but
401 the same meaning might be considered as equal, like different grave
402 accent Unicode characters:
404 \(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
407 The optional argument LOCALE, a string, overrides the setting of your
408 current locale identifier for collation. The value is system
409 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
410 while it would be \"enu_USA.1252\" on MS Windows systems.
412 If IGNORE-CASE is non-nil, characters are converted to lower-case
413 before comparing them.
415 To emulate Unicode-compliant collation on MS-Windows systems,
416 bind `w32-collate-ignore-punctuation' to a non-nil value, since
417 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
419 If your system does not support a locale environment, this function
420 behaves like `string-equal'.
422 Do NOT use this function to compare file names for equality, only
423 for sorting them. */)
424 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
426 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
427 /* Check parameters. */
429 s1
= SYMBOL_NAME (s1
);
431 s2
= SYMBOL_NAME (s2
);
435 CHECK_STRING (locale
);
437 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
439 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
440 return Fstring_equal (s1
, s2
);
441 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
444 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
445 enum Lisp_Type target_type
, bool last_special
);
449 concat2 (Lisp_Object s1
, Lisp_Object s2
)
454 return concat (2, args
, Lisp_String
, 0);
459 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
465 return concat (3, args
, Lisp_String
, 0);
468 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
469 doc
: /* Concatenate all the arguments and make the result a list.
470 The result is a list whose elements are the elements of all the arguments.
471 Each argument may be a list, vector or string.
472 The last argument is not copied, just used as the tail of the new list.
473 usage: (append &rest SEQUENCES) */)
474 (ptrdiff_t nargs
, Lisp_Object
*args
)
476 return concat (nargs
, args
, Lisp_Cons
, 1);
479 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
480 doc
: /* Concatenate all the arguments and make the result a string.
481 The result is a string whose elements are the elements of all the arguments.
482 Each argument may be a string or a list or vector of characters (integers).
483 usage: (concat &rest SEQUENCES) */)
484 (ptrdiff_t nargs
, Lisp_Object
*args
)
486 return concat (nargs
, args
, Lisp_String
, 0);
489 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
490 doc
: /* Concatenate all the arguments and make the result a vector.
491 The result is a vector whose elements are the elements of all the arguments.
492 Each argument may be a list, vector or string.
493 usage: (vconcat &rest SEQUENCES) */)
494 (ptrdiff_t nargs
, Lisp_Object
*args
)
496 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
500 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
501 doc
: /* Return a copy of a list, vector, string or char-table.
502 The elements of a list or vector are not copied; they are shared
503 with the original. */)
506 if (NILP (arg
)) return arg
;
508 if (CHAR_TABLE_P (arg
))
510 return copy_char_table (arg
);
513 if (BOOL_VECTOR_P (arg
))
515 EMACS_INT nbits
= bool_vector_size (arg
);
516 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
517 Lisp_Object val
= make_uninit_bool_vector (nbits
);
518 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
522 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
523 wrong_type_argument (Qsequencep
, arg
);
525 return concat (1, &arg
, XTYPE (arg
), 0);
528 /* This structure holds information of an argument of `concat' that is
529 a string and has text properties to be copied. */
532 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
533 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
534 ptrdiff_t to
; /* refer to VAL (the target string) */
538 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
539 enum Lisp_Type target_type
, bool last_special
)
545 ptrdiff_t toindex_byte
= 0;
546 EMACS_INT result_len
;
547 EMACS_INT result_len_byte
;
549 Lisp_Object last_tail
;
552 /* When we make a multibyte string, we can't copy text properties
553 while concatenating each string because the length of resulting
554 string can't be decided until we finish the whole concatenation.
555 So, we record strings that have text properties to be copied
556 here, and copy the text properties after the concatenation. */
557 struct textprop_rec
*textprops
= NULL
;
558 /* Number of elements in textprops. */
559 ptrdiff_t num_textprops
= 0;
564 /* In append, the last arg isn't treated like the others */
565 if (last_special
&& nargs
> 0)
568 last_tail
= args
[nargs
];
573 /* Check each argument. */
574 for (argnum
= 0; argnum
< nargs
; argnum
++)
577 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
578 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
579 wrong_type_argument (Qsequencep
, this);
582 /* Compute total length in chars of arguments in RESULT_LEN.
583 If desired output is a string, also compute length in bytes
584 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
585 whether the result should be a multibyte string. */
589 for (argnum
= 0; argnum
< nargs
; argnum
++)
593 len
= XFASTINT (Flength (this));
594 if (target_type
== Lisp_String
)
596 /* We must count the number of bytes needed in the string
597 as well as the number of characters. */
601 ptrdiff_t this_len_byte
;
603 if (VECTORP (this) || COMPILEDP (this))
604 for (i
= 0; i
< len
; i
++)
607 CHECK_CHARACTER (ch
);
609 this_len_byte
= CHAR_BYTES (c
);
610 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
612 result_len_byte
+= this_len_byte
;
613 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
616 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
617 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
618 else if (CONSP (this))
619 for (; CONSP (this); this = XCDR (this))
622 CHECK_CHARACTER (ch
);
624 this_len_byte
= CHAR_BYTES (c
);
625 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
627 result_len_byte
+= this_len_byte
;
628 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
631 else if (STRINGP (this))
633 if (STRING_MULTIBYTE (this))
636 this_len_byte
= SBYTES (this);
639 this_len_byte
= count_size_as_multibyte (SDATA (this),
641 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
643 result_len_byte
+= this_len_byte
;
648 if (MOST_POSITIVE_FIXNUM
< result_len
)
649 memory_full (SIZE_MAX
);
652 if (! some_multibyte
)
653 result_len_byte
= result_len
;
655 /* Create the output object. */
656 if (target_type
== Lisp_Cons
)
657 val
= Fmake_list (make_number (result_len
), Qnil
);
658 else if (target_type
== Lisp_Vectorlike
)
659 val
= Fmake_vector (make_number (result_len
), Qnil
);
660 else if (some_multibyte
)
661 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
663 val
= make_uninit_string (result_len
);
665 /* In `append', if all but last arg are nil, return last arg. */
666 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
669 /* Copy the contents of the args into the result. */
671 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
673 toindex
= 0, toindex_byte
= 0;
677 SAFE_NALLOCA (textprops
, 1, nargs
);
679 for (argnum
= 0; argnum
< nargs
; argnum
++)
682 ptrdiff_t thisleni
= 0;
683 register ptrdiff_t thisindex
= 0;
684 register ptrdiff_t thisindex_byte
= 0;
688 thislen
= Flength (this), thisleni
= XINT (thislen
);
690 /* Between strings of the same kind, copy fast. */
691 if (STRINGP (this) && STRINGP (val
)
692 && STRING_MULTIBYTE (this) == some_multibyte
)
694 ptrdiff_t thislen_byte
= SBYTES (this);
696 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
697 if (string_intervals (this))
699 textprops
[num_textprops
].argnum
= argnum
;
700 textprops
[num_textprops
].from
= 0;
701 textprops
[num_textprops
++].to
= toindex
;
703 toindex_byte
+= thislen_byte
;
706 /* Copy a single-byte string to a multibyte string. */
707 else if (STRINGP (this) && STRINGP (val
))
709 if (string_intervals (this))
711 textprops
[num_textprops
].argnum
= argnum
;
712 textprops
[num_textprops
].from
= 0;
713 textprops
[num_textprops
++].to
= toindex
;
715 toindex_byte
+= copy_text (SDATA (this),
716 SDATA (val
) + toindex_byte
,
717 SCHARS (this), 0, 1);
721 /* Copy element by element. */
724 register Lisp_Object elt
;
726 /* Fetch next element of `this' arg into `elt', or break if
727 `this' is exhausted. */
728 if (NILP (this)) break;
730 elt
= XCAR (this), this = XCDR (this);
731 else if (thisindex
>= thisleni
)
733 else if (STRINGP (this))
736 if (STRING_MULTIBYTE (this))
737 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
742 c
= SREF (this, thisindex
); thisindex
++;
743 if (some_multibyte
&& !ASCII_CHAR_P (c
))
744 c
= BYTE8_TO_CHAR (c
);
746 XSETFASTINT (elt
, c
);
748 else if (BOOL_VECTOR_P (this))
750 elt
= bool_vector_ref (this, thisindex
);
755 elt
= AREF (this, thisindex
);
759 /* Store this element into the result. */
766 else if (VECTORP (val
))
768 ASET (val
, toindex
, elt
);
774 CHECK_CHARACTER (elt
);
777 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
779 SSET (val
, toindex_byte
++, c
);
785 XSETCDR (prev
, last_tail
);
787 if (num_textprops
> 0)
790 ptrdiff_t last_to_end
= -1;
792 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
794 this = args
[textprops
[argnum
].argnum
];
795 props
= text_property_list (this,
797 make_number (SCHARS (this)),
799 /* If successive arguments have properties, be sure that the
800 value of `composition' property be the copy. */
801 if (last_to_end
== textprops
[argnum
].to
)
802 make_composition_value_copy (props
);
803 add_text_properties_from_list (val
, props
,
804 make_number (textprops
[argnum
].to
));
805 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
813 static Lisp_Object string_char_byte_cache_string
;
814 static ptrdiff_t string_char_byte_cache_charpos
;
815 static ptrdiff_t string_char_byte_cache_bytepos
;
818 clear_string_char_byte_cache (void)
820 string_char_byte_cache_string
= Qnil
;
823 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
826 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
829 ptrdiff_t best_below
, best_below_byte
;
830 ptrdiff_t best_above
, best_above_byte
;
832 best_below
= best_below_byte
= 0;
833 best_above
= SCHARS (string
);
834 best_above_byte
= SBYTES (string
);
835 if (best_above
== best_above_byte
)
838 if (EQ (string
, string_char_byte_cache_string
))
840 if (string_char_byte_cache_charpos
< char_index
)
842 best_below
= string_char_byte_cache_charpos
;
843 best_below_byte
= string_char_byte_cache_bytepos
;
847 best_above
= string_char_byte_cache_charpos
;
848 best_above_byte
= string_char_byte_cache_bytepos
;
852 if (char_index
- best_below
< best_above
- char_index
)
854 unsigned char *p
= SDATA (string
) + best_below_byte
;
856 while (best_below
< char_index
)
858 p
+= BYTES_BY_CHAR_HEAD (*p
);
861 i_byte
= p
- SDATA (string
);
865 unsigned char *p
= SDATA (string
) + best_above_byte
;
867 while (best_above
> char_index
)
870 while (!CHAR_HEAD_P (*p
)) p
--;
873 i_byte
= p
- SDATA (string
);
876 string_char_byte_cache_bytepos
= i_byte
;
877 string_char_byte_cache_charpos
= char_index
;
878 string_char_byte_cache_string
= string
;
883 /* Return the character index corresponding to BYTE_INDEX in STRING. */
886 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
889 ptrdiff_t best_below
, best_below_byte
;
890 ptrdiff_t best_above
, best_above_byte
;
892 best_below
= best_below_byte
= 0;
893 best_above
= SCHARS (string
);
894 best_above_byte
= SBYTES (string
);
895 if (best_above
== best_above_byte
)
898 if (EQ (string
, string_char_byte_cache_string
))
900 if (string_char_byte_cache_bytepos
< byte_index
)
902 best_below
= string_char_byte_cache_charpos
;
903 best_below_byte
= string_char_byte_cache_bytepos
;
907 best_above
= string_char_byte_cache_charpos
;
908 best_above_byte
= string_char_byte_cache_bytepos
;
912 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
914 unsigned char *p
= SDATA (string
) + best_below_byte
;
915 unsigned char *pend
= SDATA (string
) + byte_index
;
919 p
+= BYTES_BY_CHAR_HEAD (*p
);
923 i_byte
= p
- SDATA (string
);
927 unsigned char *p
= SDATA (string
) + best_above_byte
;
928 unsigned char *pbeg
= SDATA (string
) + byte_index
;
933 while (!CHAR_HEAD_P (*p
)) p
--;
937 i_byte
= p
- SDATA (string
);
940 string_char_byte_cache_bytepos
= i_byte
;
941 string_char_byte_cache_charpos
= i
;
942 string_char_byte_cache_string
= string
;
947 /* Convert STRING to a multibyte string. */
950 string_make_multibyte (Lisp_Object string
)
957 if (STRING_MULTIBYTE (string
))
960 nbytes
= count_size_as_multibyte (SDATA (string
),
962 /* If all the chars are ASCII, they won't need any more bytes
963 once converted. In that case, we can return STRING itself. */
964 if (nbytes
== SBYTES (string
))
967 buf
= SAFE_ALLOCA (nbytes
);
968 copy_text (SDATA (string
), buf
, SBYTES (string
),
971 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
978 /* Convert STRING (if unibyte) to a multibyte string without changing
979 the number of characters. Characters 0200 trough 0237 are
980 converted to eight-bit characters. */
983 string_to_multibyte (Lisp_Object string
)
990 if (STRING_MULTIBYTE (string
))
993 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
994 /* If all the chars are ASCII, they won't need any more bytes once
996 if (nbytes
== SBYTES (string
))
997 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
999 buf
= SAFE_ALLOCA (nbytes
);
1000 memcpy (buf
, SDATA (string
), SBYTES (string
));
1001 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1003 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1010 /* Convert STRING to a single-byte string. */
1013 string_make_unibyte (Lisp_Object string
)
1020 if (! STRING_MULTIBYTE (string
))
1023 nchars
= SCHARS (string
);
1025 buf
= SAFE_ALLOCA (nchars
);
1026 copy_text (SDATA (string
), buf
, SBYTES (string
),
1029 ret
= make_unibyte_string ((char *) buf
, nchars
);
1035 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1037 doc
: /* Return the multibyte equivalent of STRING.
1038 If STRING is unibyte and contains non-ASCII characters, the function
1039 `unibyte-char-to-multibyte' is used to convert each unibyte character
1040 to a multibyte character. In this case, the returned string is a
1041 newly created string with no text properties. If STRING is multibyte
1042 or entirely ASCII, it is returned unchanged. In particular, when
1043 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1044 \(When the characters are all ASCII, Emacs primitives will treat the
1045 string the same way whether it is unibyte or multibyte.) */)
1046 (Lisp_Object string
)
1048 CHECK_STRING (string
);
1050 return string_make_multibyte (string
);
1053 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1055 doc
: /* Return the unibyte equivalent of STRING.
1056 Multibyte character codes are converted to unibyte according to
1057 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1058 If the lookup in the translation table fails, this function takes just
1059 the low 8 bits of each character. */)
1060 (Lisp_Object string
)
1062 CHECK_STRING (string
);
1064 return string_make_unibyte (string
);
1067 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1069 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1070 If STRING is unibyte, the result is STRING itself.
1071 Otherwise it is a newly created string, with no text properties.
1072 If STRING is multibyte and contains a character of charset
1073 `eight-bit', it is converted to the corresponding single byte. */)
1074 (Lisp_Object string
)
1076 CHECK_STRING (string
);
1078 if (STRING_MULTIBYTE (string
))
1080 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1081 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1083 string
= make_unibyte_string ((char *) str
, bytes
);
1089 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1091 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1092 If STRING is multibyte, the result is STRING itself.
1093 Otherwise it is a newly created string, with no text properties.
1095 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1096 part of a correct utf-8 sequence), it is converted to the corresponding
1097 multibyte character of charset `eight-bit'.
1098 See also `string-to-multibyte'.
1100 Beware, this often doesn't really do what you think it does.
1101 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1102 If you're not sure, whether to use `string-as-multibyte' or
1103 `string-to-multibyte', use `string-to-multibyte'. */)
1104 (Lisp_Object string
)
1106 CHECK_STRING (string
);
1108 if (! STRING_MULTIBYTE (string
))
1110 Lisp_Object new_string
;
1111 ptrdiff_t nchars
, nbytes
;
1113 parse_str_as_multibyte (SDATA (string
),
1116 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1117 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1118 if (nbytes
!= SBYTES (string
))
1119 str_as_multibyte (SDATA (new_string
), nbytes
,
1120 SBYTES (string
), NULL
);
1121 string
= new_string
;
1122 set_string_intervals (string
, NULL
);
1127 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1129 doc
: /* Return a multibyte string with the same individual chars as STRING.
1130 If STRING is multibyte, the result is STRING itself.
1131 Otherwise it is a newly created string, with no text properties.
1133 If STRING is unibyte and contains an 8-bit byte, it is converted to
1134 the corresponding multibyte character of charset `eight-bit'.
1136 This differs from `string-as-multibyte' by converting each byte of a correct
1137 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1138 correct sequence. */)
1139 (Lisp_Object string
)
1141 CHECK_STRING (string
);
1143 return string_to_multibyte (string
);
1146 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1148 doc
: /* Return a unibyte string with the same individual chars as STRING.
1149 If STRING is unibyte, the result is STRING itself.
1150 Otherwise it is a newly created string, with no text properties,
1151 where each `eight-bit' character is converted to the corresponding byte.
1152 If STRING contains a non-ASCII, non-`eight-bit' character,
1153 an error is signaled. */)
1154 (Lisp_Object string
)
1156 CHECK_STRING (string
);
1158 if (STRING_MULTIBYTE (string
))
1160 ptrdiff_t chars
= SCHARS (string
);
1161 unsigned char *str
= xmalloc (chars
);
1162 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1164 if (converted
< chars
)
1165 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1166 string
= make_unibyte_string ((char *) str
, chars
);
1173 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1174 doc
: /* Return a copy of ALIST.
1175 This is an alist which represents the same mapping from objects to objects,
1176 but does not share the alist structure with ALIST.
1177 The objects mapped (cars and cdrs of elements of the alist)
1178 are shared, however.
1179 Elements of ALIST that are not conses are also shared. */)
1182 register Lisp_Object tem
;
1187 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1188 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1190 register Lisp_Object car
;
1194 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1199 /* Check that ARRAY can have a valid subarray [FROM..TO),
1200 given that its size is SIZE.
1201 If FROM is nil, use 0; if TO is nil, use SIZE.
1202 Count negative values backwards from the end.
1203 Set *IFROM and *ITO to the two indexes used. */
1206 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1207 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1211 if (INTEGERP (from
))
1217 else if (NILP (from
))
1220 wrong_type_argument (Qintegerp
, from
);
1231 wrong_type_argument (Qintegerp
, to
);
1233 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1234 args_out_of_range_3 (array
, from
, to
);
1240 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1241 doc
: /* Return a new string whose contents are a substring of STRING.
1242 The returned string consists of the characters between index FROM
1243 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1244 zero-indexed: 0 means the first character of STRING. Negative values
1245 are counted from the end of STRING. If TO is nil, the substring runs
1246 to the end of STRING.
1248 The STRING argument may also be a vector. In that case, the return
1249 value is a new vector that contains the elements between index FROM
1250 \(inclusive) and index TO (exclusive) of that vector argument.
1252 With one argument, just copy STRING (with properties, if any). */)
1253 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1256 ptrdiff_t size
, ifrom
, ito
;
1258 size
= CHECK_VECTOR_OR_STRING (string
);
1259 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1261 if (STRINGP (string
))
1264 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1266 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1267 res
= make_specified_string (SSDATA (string
) + from_byte
,
1268 ito
- ifrom
, to_byte
- from_byte
,
1269 STRING_MULTIBYTE (string
));
1270 copy_text_properties (make_number (ifrom
), make_number (ito
),
1271 string
, make_number (0), res
, Qnil
);
1274 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1280 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1281 doc
: /* Return a substring of STRING, without text properties.
1282 It starts at index FROM and ends before TO.
1283 TO may be nil or omitted; then the substring runs to the end of STRING.
1284 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1285 If FROM or TO is negative, it counts from the end.
1287 With one argument, just copy STRING without its properties. */)
1288 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1290 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1292 CHECK_STRING (string
);
1294 size
= SCHARS (string
);
1295 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1297 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1299 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1300 return make_specified_string (SSDATA (string
) + from_byte
,
1301 to_char
- from_char
, to_byte
- from_byte
,
1302 STRING_MULTIBYTE (string
));
1305 /* Extract a substring of STRING, giving start and end positions
1306 both in characters and in bytes. */
1309 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1310 ptrdiff_t to
, ptrdiff_t to_byte
)
1313 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1315 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1316 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1318 if (STRINGP (string
))
1320 res
= make_specified_string (SSDATA (string
) + from_byte
,
1321 to
- from
, to_byte
- from_byte
,
1322 STRING_MULTIBYTE (string
));
1323 copy_text_properties (make_number (from
), make_number (to
),
1324 string
, make_number (0), res
, Qnil
);
1327 res
= Fvector (to
- from
, aref_addr (string
, from
));
1332 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1333 doc
: /* Take cdr N times on LIST, return the result. */)
1334 (Lisp_Object n
, Lisp_Object list
)
1339 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1342 CHECK_LIST_CONS (list
, list
);
1348 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1349 doc
: /* Return the Nth element of LIST.
1350 N counts from zero. If LIST is not that long, nil is returned. */)
1351 (Lisp_Object n
, Lisp_Object list
)
1353 return Fcar (Fnthcdr (n
, list
));
1356 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1357 doc
: /* Return element of SEQUENCE at index N. */)
1358 (register Lisp_Object sequence
, Lisp_Object n
)
1361 if (CONSP (sequence
) || NILP (sequence
))
1362 return Fcar (Fnthcdr (n
, sequence
));
1364 /* Faref signals a "not array" error, so check here. */
1365 CHECK_ARRAY (sequence
, Qsequencep
);
1366 return Faref (sequence
, n
);
1369 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1370 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1371 The value is actually the tail of LIST whose car is ELT. */)
1372 (register Lisp_Object elt
, Lisp_Object list
)
1374 register Lisp_Object tail
;
1375 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1377 register Lisp_Object tem
;
1378 CHECK_LIST_CONS (tail
, list
);
1380 if (! NILP (Fequal (elt
, tem
)))
1387 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1388 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1389 The value is actually the tail of LIST whose car is ELT. */)
1390 (register Lisp_Object elt
, Lisp_Object list
)
1394 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1398 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1402 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1413 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1414 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1415 The value is actually the tail of LIST whose car is ELT. */)
1416 (register Lisp_Object elt
, Lisp_Object list
)
1418 register Lisp_Object tail
;
1421 return Fmemq (elt
, list
);
1423 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1425 register Lisp_Object tem
;
1426 CHECK_LIST_CONS (tail
, list
);
1428 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1435 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1436 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1437 The value is actually the first element of LIST whose car is KEY.
1438 Elements of LIST that are not conses are ignored. */)
1439 (Lisp_Object key
, Lisp_Object list
)
1444 || (CONSP (XCAR (list
))
1445 && EQ (XCAR (XCAR (list
)), key
)))
1450 || (CONSP (XCAR (list
))
1451 && EQ (XCAR (XCAR (list
)), key
)))
1456 || (CONSP (XCAR (list
))
1457 && EQ (XCAR (XCAR (list
)), key
)))
1467 /* Like Fassq but never report an error and do not allow quits.
1468 Use only on lists known never to be circular. */
1471 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1474 && (!CONSP (XCAR (list
))
1475 || !EQ (XCAR (XCAR (list
)), key
)))
1478 return CAR_SAFE (list
);
1481 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1482 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1483 The value is actually the first element of LIST whose car equals KEY. */)
1484 (Lisp_Object key
, Lisp_Object list
)
1491 || (CONSP (XCAR (list
))
1492 && (car
= XCAR (XCAR (list
)),
1493 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1498 || (CONSP (XCAR (list
))
1499 && (car
= XCAR (XCAR (list
)),
1500 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1505 || (CONSP (XCAR (list
))
1506 && (car
= XCAR (XCAR (list
)),
1507 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1517 /* Like Fassoc but never report an error and do not allow quits.
1518 Use only on lists known never to be circular. */
1521 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1524 && (!CONSP (XCAR (list
))
1525 || (!EQ (XCAR (XCAR (list
)), key
)
1526 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1529 return CONSP (list
) ? XCAR (list
) : Qnil
;
1532 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1533 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1534 The value is actually the first element of LIST whose cdr is KEY. */)
1535 (register Lisp_Object key
, Lisp_Object list
)
1540 || (CONSP (XCAR (list
))
1541 && EQ (XCDR (XCAR (list
)), key
)))
1546 || (CONSP (XCAR (list
))
1547 && EQ (XCDR (XCAR (list
)), key
)))
1552 || (CONSP (XCAR (list
))
1553 && EQ (XCDR (XCAR (list
)), key
)))
1563 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1564 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1565 The value is actually the first element of LIST whose cdr equals KEY. */)
1566 (Lisp_Object key
, Lisp_Object list
)
1573 || (CONSP (XCAR (list
))
1574 && (cdr
= XCDR (XCAR (list
)),
1575 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1580 || (CONSP (XCAR (list
))
1581 && (cdr
= XCDR (XCAR (list
)),
1582 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1587 || (CONSP (XCAR (list
))
1588 && (cdr
= XCDR (XCAR (list
)),
1589 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1599 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1600 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1601 More precisely, this function skips any members `eq' to ELT at the
1602 front of LIST, then removes members `eq' to ELT from the remaining
1603 sublist by modifying its list structure, then returns the resulting
1606 Write `(setq foo (delq element foo))' to be sure of correctly changing
1607 the value of a list `foo'. */)
1608 (register Lisp_Object elt
, Lisp_Object list
)
1610 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1613 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1615 Lisp_Object tem
= XCAR (tail
);
1621 Fsetcdr (prev
, XCDR (tail
));
1629 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1630 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1631 SEQ must be a sequence (i.e. a list, a vector, or a string).
1632 The return value is a sequence of the same type.
1634 If SEQ is a list, this behaves like `delq', except that it compares
1635 with `equal' instead of `eq'. In particular, it may remove elements
1636 by altering the list structure.
1638 If SEQ is not a list, deletion is never performed destructively;
1639 instead this function creates and returns a new vector or string.
1641 Write `(setq foo (delete element foo))' to be sure of correctly
1642 changing the value of a sequence `foo'. */)
1643 (Lisp_Object elt
, Lisp_Object seq
)
1649 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1650 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1653 if (n
!= ASIZE (seq
))
1655 struct Lisp_Vector
*p
= allocate_vector (n
);
1657 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1658 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1659 p
->contents
[n
++] = AREF (seq
, i
);
1661 XSETVECTOR (seq
, p
);
1664 else if (STRINGP (seq
))
1666 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1669 for (i
= nchars
= nbytes
= ibyte
= 0;
1671 ++i
, ibyte
+= cbytes
)
1673 if (STRING_MULTIBYTE (seq
))
1675 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1676 cbytes
= CHAR_BYTES (c
);
1684 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1691 if (nchars
!= SCHARS (seq
))
1695 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1696 if (!STRING_MULTIBYTE (seq
))
1697 STRING_SET_UNIBYTE (tem
);
1699 for (i
= nchars
= nbytes
= ibyte
= 0;
1701 ++i
, ibyte
+= cbytes
)
1703 if (STRING_MULTIBYTE (seq
))
1705 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1706 cbytes
= CHAR_BYTES (c
);
1714 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1716 unsigned char *from
= SDATA (seq
) + ibyte
;
1717 unsigned char *to
= SDATA (tem
) + nbytes
;
1723 for (n
= cbytes
; n
--; )
1733 Lisp_Object tail
, prev
;
1735 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1737 CHECK_LIST_CONS (tail
, seq
);
1739 if (!NILP (Fequal (elt
, XCAR (tail
))))
1744 Fsetcdr (prev
, XCDR (tail
));
1755 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1756 doc
: /* Reverse order of items in a list, vector or string SEQ.
1757 If SEQ is a list, it should be nil-terminated.
1758 This function may destructively modify SEQ to produce the value. */)
1763 else if (STRINGP (seq
))
1764 return Freverse (seq
);
1765 else if (CONSP (seq
))
1767 Lisp_Object prev
, tail
, next
;
1769 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1772 CHECK_LIST_CONS (tail
, tail
);
1774 Fsetcdr (tail
, prev
);
1779 else if (VECTORP (seq
))
1781 ptrdiff_t i
, size
= ASIZE (seq
);
1783 for (i
= 0; i
< size
/ 2; i
++)
1785 Lisp_Object tem
= AREF (seq
, i
);
1786 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1787 ASET (seq
, size
- i
- 1, tem
);
1790 else if (BOOL_VECTOR_P (seq
))
1792 ptrdiff_t i
, size
= bool_vector_size (seq
);
1794 for (i
= 0; i
< size
/ 2; i
++)
1796 bool tem
= bool_vector_bitref (seq
, i
);
1797 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1798 bool_vector_set (seq
, size
- i
- 1, tem
);
1802 wrong_type_argument (Qarrayp
, seq
);
1806 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1807 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1808 See also the function `nreverse', which is used more often. */)
1815 else if (CONSP (seq
))
1817 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1820 new = Fcons (XCAR (seq
), new);
1822 CHECK_LIST_END (seq
, seq
);
1824 else if (VECTORP (seq
))
1826 ptrdiff_t i
, size
= ASIZE (seq
);
1828 new = make_uninit_vector (size
);
1829 for (i
= 0; i
< size
; i
++)
1830 ASET (new, i
, AREF (seq
, size
- i
- 1));
1832 else if (BOOL_VECTOR_P (seq
))
1835 EMACS_INT nbits
= bool_vector_size (seq
);
1837 new = make_uninit_bool_vector (nbits
);
1838 for (i
= 0; i
< nbits
; i
++)
1839 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1841 else if (STRINGP (seq
))
1843 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1849 new = make_uninit_string (size
);
1850 for (i
= 0; i
< size
; i
++)
1851 SSET (new, i
, SREF (seq
, size
- i
- 1));
1855 unsigned char *p
, *q
;
1857 new = make_uninit_multibyte_string (size
, bytes
);
1858 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1859 while (q
> SDATA (new))
1863 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1865 CHAR_STRING (ch
, q
);
1870 wrong_type_argument (Qsequencep
, seq
);
1874 /* Sort LIST using PREDICATE, preserving original order of elements
1875 considered as equal. */
1878 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1880 Lisp_Object front
, back
;
1881 register Lisp_Object len
, tem
;
1882 struct gcpro gcpro1
, gcpro2
;
1886 len
= Flength (list
);
1887 length
= XINT (len
);
1891 XSETINT (len
, (length
/ 2) - 1);
1892 tem
= Fnthcdr (len
, list
);
1894 Fsetcdr (tem
, Qnil
);
1896 GCPRO2 (front
, back
);
1897 front
= Fsort (front
, predicate
);
1898 back
= Fsort (back
, predicate
);
1900 return merge (front
, back
, predicate
);
1903 /* Using PRED to compare, return whether A and B are in order.
1904 Compare stably when A appeared before B in the input. */
1906 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1908 return NILP (call2 (pred
, b
, a
));
1911 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1912 into DEST. Argument arrays must be nonempty and must not overlap,
1913 except that B might be the last part of DEST. */
1915 merge_vectors (Lisp_Object pred
,
1916 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1917 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1918 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1920 eassume (0 < alen
&& 0 < blen
);
1921 Lisp_Object
const *alim
= a
+ alen
;
1922 Lisp_Object
const *blim
= b
+ blen
;
1926 if (inorder (pred
, a
[0], b
[0]))
1932 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1941 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1948 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1949 temporary storage. LEN must be at least 2. */
1951 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1952 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1953 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1956 ptrdiff_t halflen
= len
>> 1;
1957 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1958 if (1 < len
- halflen
)
1959 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1960 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1963 /* Using PRED to compare, sort from LEN-length SRC into DST.
1964 Len must be positive. */
1966 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1967 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1968 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1971 ptrdiff_t halflen
= len
>> 1;
1977 sort_vector_inplace (pred
, halflen
, src
, dest
);
1978 if (1 < len
- halflen
)
1979 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1980 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1984 /* Sort VECTOR in place using PREDICATE, preserving original order of
1985 elements considered as equal. */
1988 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1990 ptrdiff_t len
= ASIZE (vector
);
1993 ptrdiff_t halflen
= len
>> 1;
1995 Lisp_Object tmpvec
= Qnil
;
1996 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1997 GCPRO3 (vector
, predicate
, tmpvec
);
1998 if (halflen
< MAX_ALLOCA
/ word_size
)
1999 tmp
= alloca (halflen
* word_size
);
2002 tmpvec
= Fmake_vector (make_number (halflen
), make_number (0));
2003 tmp
= XVECTOR (tmpvec
)->contents
;
2005 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2009 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2010 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2011 Returns the sorted sequence. SEQ should be a list or vector.
2012 If SEQ is a list, it is modified by side effects. PREDICATE
2013 is called with two elements of SEQ, and should return non-nil
2014 if the first element should sort before the second. */)
2015 (Lisp_Object seq
, Lisp_Object predicate
)
2018 seq
= sort_list (seq
, predicate
);
2019 else if (VECTORP (seq
))
2020 sort_vector (seq
, predicate
);
2021 else if (!NILP (seq
))
2022 wrong_type_argument (Qsequencep
, seq
);
2027 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2030 register Lisp_Object tail
;
2032 register Lisp_Object l1
, l2
;
2033 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2040 /* It is sufficient to protect org_l1 and org_l2.
2041 When l1 and l2 are updated, we copy the new values
2042 back into the org_ vars. */
2043 GCPRO4 (org_l1
, org_l2
, pred
, value
);
2063 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2078 Fsetcdr (tail
, tem
);
2084 /* This does not check for quits. That is safe since it must terminate. */
2086 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2087 doc
: /* Extract a value from a property list.
2088 PLIST is a property list, which is a list of the form
2089 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2090 corresponding to the given PROP, or nil if PROP is not one of the
2091 properties on the list. This function never signals an error. */)
2092 (Lisp_Object plist
, Lisp_Object prop
)
2094 Lisp_Object tail
, halftail
;
2096 /* halftail is used to detect circular lists. */
2097 tail
= halftail
= plist
;
2098 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2100 if (EQ (prop
, XCAR (tail
)))
2101 return XCAR (XCDR (tail
));
2103 tail
= XCDR (XCDR (tail
));
2104 halftail
= XCDR (halftail
);
2105 if (EQ (tail
, halftail
))
2112 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2113 doc
: /* Return the value of SYMBOL's PROPNAME property.
2114 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2115 (Lisp_Object symbol
, Lisp_Object propname
)
2117 CHECK_SYMBOL (symbol
);
2118 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2121 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2122 doc
: /* Change value in PLIST of PROP to VAL.
2123 PLIST is a property list, which is a list of the form
2124 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2125 If PROP is already a property on the list, its value is set to VAL,
2126 otherwise the new PROP VAL pair is added. The new plist is returned;
2127 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2128 The PLIST is modified by side effects. */)
2129 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2131 register Lisp_Object tail
, prev
;
2132 Lisp_Object newcell
;
2134 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2135 tail
= XCDR (XCDR (tail
)))
2137 if (EQ (prop
, XCAR (tail
)))
2139 Fsetcar (XCDR (tail
), val
);
2146 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2150 Fsetcdr (XCDR (prev
), newcell
);
2154 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2155 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2156 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2157 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2159 CHECK_SYMBOL (symbol
);
2161 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2165 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2166 doc
: /* Extract a value from a property list, comparing with `equal'.
2167 PLIST is a property list, which is a list of the form
2168 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2169 corresponding to the given PROP, or nil if PROP is not
2170 one of the properties on the list. */)
2171 (Lisp_Object plist
, Lisp_Object prop
)
2176 CONSP (tail
) && CONSP (XCDR (tail
));
2177 tail
= XCDR (XCDR (tail
)))
2179 if (! NILP (Fequal (prop
, XCAR (tail
))))
2180 return XCAR (XCDR (tail
));
2185 CHECK_LIST_END (tail
, prop
);
2190 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2191 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2192 PLIST is a property list, which is a list of the form
2193 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2194 If PROP is already a property on the list, its value is set to VAL,
2195 otherwise the new PROP VAL pair is added. The new plist is returned;
2196 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2197 The PLIST is modified by side effects. */)
2198 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2200 register Lisp_Object tail
, prev
;
2201 Lisp_Object newcell
;
2203 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2204 tail
= XCDR (XCDR (tail
)))
2206 if (! NILP (Fequal (prop
, XCAR (tail
))))
2208 Fsetcar (XCDR (tail
), val
);
2215 newcell
= list2 (prop
, val
);
2219 Fsetcdr (XCDR (prev
), newcell
);
2223 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2224 doc
: /* Return t if the two args are the same Lisp object.
2225 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2226 (Lisp_Object obj1
, Lisp_Object obj2
)
2229 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2231 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2234 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2235 doc
: /* Return t if two Lisp objects have similar structure and contents.
2236 They must have the same data type.
2237 Conses are compared by comparing the cars and the cdrs.
2238 Vectors and strings are compared element by element.
2239 Numbers are compared by value, but integers cannot equal floats.
2240 (Use `=' if you want integers and floats to be able to be equal.)
2241 Symbols must match exactly. */)
2242 (register Lisp_Object o1
, Lisp_Object o2
)
2244 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2247 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2248 doc
: /* Return t if two Lisp objects have similar structure and contents.
2249 This is like `equal' except that it compares the text properties
2250 of strings. (`equal' ignores text properties.) */)
2251 (register Lisp_Object o1
, Lisp_Object o2
)
2253 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2256 /* DEPTH is current depth of recursion. Signal an error if it
2258 PROPS means compare string text properties too. */
2261 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2267 error ("Stack overflow in equal");
2270 Lisp_Object args
[2];
2273 ht
= Fmake_hash_table (2, args
);
2277 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2279 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2281 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2283 { /* `o1' was seen already. */
2284 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2285 if (!NILP (Fmemq (o2
, o2s
)))
2288 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2291 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2301 if (XTYPE (o1
) != XTYPE (o2
))
2310 d1
= extract_float (o1
);
2311 d2
= extract_float (o2
);
2312 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2313 though they are not =. */
2314 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2318 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2322 /* FIXME: This inf-loops in a circular list! */
2326 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2330 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2331 depth
+ 1, props
, ht
)
2332 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2333 depth
+ 1, props
, ht
))
2335 o1
= XOVERLAY (o1
)->plist
;
2336 o2
= XOVERLAY (o2
)->plist
;
2341 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2342 && (XMARKER (o1
)->buffer
== 0
2343 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2347 case Lisp_Vectorlike
:
2350 ptrdiff_t size
= ASIZE (o1
);
2351 /* Pseudovectors have the type encoded in the size field, so this test
2352 actually checks that the objects have the same type as well as the
2354 if (ASIZE (o2
) != size
)
2356 /* Boolvectors are compared much like strings. */
2357 if (BOOL_VECTOR_P (o1
))
2359 EMACS_INT size
= bool_vector_size (o1
);
2360 if (size
!= bool_vector_size (o2
))
2362 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2363 bool_vector_bytes (size
)))
2367 if (WINDOW_CONFIGURATIONP (o1
))
2368 return compare_window_configurations (o1
, o2
, 0);
2370 /* Aside from them, only true vectors, char-tables, compiled
2371 functions, and fonts (font-spec, font-entity, font-object)
2372 are sensible to compare, so eliminate the others now. */
2373 if (size
& PSEUDOVECTOR_FLAG
)
2375 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2378 size
&= PSEUDOVECTOR_SIZE_MASK
;
2380 for (i
= 0; i
< size
; i
++)
2385 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2393 if (SCHARS (o1
) != SCHARS (o2
))
2395 if (SBYTES (o1
) != SBYTES (o2
))
2397 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2399 if (props
&& !compare_string_intervals (o1
, o2
))
2411 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2412 doc
: /* Store each element of ARRAY with ITEM.
2413 ARRAY is a vector, string, char-table, or bool-vector. */)
2414 (Lisp_Object array
, Lisp_Object item
)
2416 register ptrdiff_t size
, idx
;
2418 if (VECTORP (array
))
2419 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2420 ASET (array
, idx
, item
);
2421 else if (CHAR_TABLE_P (array
))
2425 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2426 set_char_table_contents (array
, i
, item
);
2427 set_char_table_defalt (array
, item
);
2429 else if (STRINGP (array
))
2431 register unsigned char *p
= SDATA (array
);
2433 CHECK_CHARACTER (item
);
2434 charval
= XFASTINT (item
);
2435 size
= SCHARS (array
);
2436 if (STRING_MULTIBYTE (array
))
2438 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2439 int len
= CHAR_STRING (charval
, str
);
2440 ptrdiff_t size_byte
= SBYTES (array
);
2442 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2443 || SCHARS (array
) * len
!= size_byte
)
2444 error ("Attempt to change byte length of a string");
2445 for (idx
= 0; idx
< size_byte
; idx
++)
2446 *p
++ = str
[idx
% len
];
2449 for (idx
= 0; idx
< size
; idx
++)
2452 else if (BOOL_VECTOR_P (array
))
2453 return bool_vector_fill (array
, item
);
2455 wrong_type_argument (Qarrayp
, array
);
2459 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2461 doc
: /* Clear the contents of STRING.
2462 This makes STRING unibyte and may change its length. */)
2463 (Lisp_Object string
)
2466 CHECK_STRING (string
);
2467 len
= SBYTES (string
);
2468 memset (SDATA (string
), 0, len
);
2469 STRING_SET_CHARS (string
, len
);
2470 STRING_SET_UNIBYTE (string
);
2476 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2478 Lisp_Object args
[2];
2481 return Fnconc (2, args
);
2484 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2485 doc
: /* Concatenate any number of lists by altering them.
2486 Only the last argument is not altered, and need not be a list.
2487 usage: (nconc &rest LISTS) */)
2488 (ptrdiff_t nargs
, Lisp_Object
*args
)
2491 register Lisp_Object tail
, tem
, val
;
2495 for (argnum
= 0; argnum
< nargs
; argnum
++)
2498 if (NILP (tem
)) continue;
2503 if (argnum
+ 1 == nargs
) break;
2505 CHECK_LIST_CONS (tem
, tem
);
2514 tem
= args
[argnum
+ 1];
2515 Fsetcdr (tail
, tem
);
2517 args
[argnum
+ 1] = tail
;
2523 /* This is the guts of all mapping functions.
2524 Apply FN to each element of SEQ, one by one,
2525 storing the results into elements of VALS, a C vector of Lisp_Objects.
2526 LENI is the length of VALS, which should also be the length of SEQ. */
2529 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2531 register Lisp_Object tail
;
2533 register EMACS_INT i
;
2534 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2538 /* Don't let vals contain any garbage when GC happens. */
2539 for (i
= 0; i
< leni
; i
++)
2542 GCPRO3 (dummy
, fn
, seq
);
2544 gcpro1
.nvars
= leni
;
2548 /* We need not explicitly protect `tail' because it is used only on lists, and
2549 1) lists are not relocated and 2) the list is marked via `seq' so will not
2552 if (VECTORP (seq
) || COMPILEDP (seq
))
2554 for (i
= 0; i
< leni
; i
++)
2556 dummy
= call1 (fn
, AREF (seq
, i
));
2561 else if (BOOL_VECTOR_P (seq
))
2563 for (i
= 0; i
< leni
; i
++)
2565 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2570 else if (STRINGP (seq
))
2574 for (i
= 0, i_byte
= 0; i
< leni
;)
2577 ptrdiff_t i_before
= i
;
2579 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2580 XSETFASTINT (dummy
, c
);
2581 dummy
= call1 (fn
, dummy
);
2583 vals
[i_before
] = dummy
;
2586 else /* Must be a list, since Flength did not get an error */
2589 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2591 dummy
= call1 (fn
, XCAR (tail
));
2601 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2602 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2603 In between each pair of results, stick in SEPARATOR. Thus, " " as
2604 SEPARATOR results in spaces between the values returned by FUNCTION.
2605 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2606 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2609 register EMACS_INT leni
;
2612 register Lisp_Object
*args
;
2613 struct gcpro gcpro1
;
2617 len
= Flength (sequence
);
2618 if (CHAR_TABLE_P (sequence
))
2619 wrong_type_argument (Qlistp
, sequence
);
2621 nargs
= leni
+ leni
- 1;
2622 if (nargs
< 0) return empty_unibyte_string
;
2624 SAFE_ALLOCA_LISP (args
, nargs
);
2627 mapcar1 (leni
, args
, function
, sequence
);
2630 for (i
= leni
- 1; i
> 0; i
--)
2631 args
[i
+ i
] = args
[i
];
2633 for (i
= 1; i
< nargs
; i
+= 2)
2634 args
[i
] = separator
;
2636 ret
= Fconcat (nargs
, args
);
2642 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2643 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2644 The result is a list just as long as SEQUENCE.
2645 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2646 (Lisp_Object function
, Lisp_Object sequence
)
2648 register Lisp_Object len
;
2649 register EMACS_INT leni
;
2650 register Lisp_Object
*args
;
2654 len
= Flength (sequence
);
2655 if (CHAR_TABLE_P (sequence
))
2656 wrong_type_argument (Qlistp
, sequence
);
2657 leni
= XFASTINT (len
);
2659 SAFE_ALLOCA_LISP (args
, leni
);
2661 mapcar1 (leni
, args
, function
, sequence
);
2663 ret
= Flist (leni
, args
);
2669 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2670 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2671 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2672 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2673 (Lisp_Object function
, Lisp_Object sequence
)
2675 register EMACS_INT leni
;
2677 leni
= XFASTINT (Flength (sequence
));
2678 if (CHAR_TABLE_P (sequence
))
2679 wrong_type_argument (Qlistp
, sequence
);
2680 mapcar1 (leni
, 0, function
, sequence
);
2685 /* This is how C code calls `yes-or-no-p' and allows the user
2688 Anything that calls this function must protect from GC! */
2691 do_yes_or_no_p (Lisp_Object prompt
)
2693 return call1 (intern ("yes-or-no-p"), prompt
);
2696 /* Anything that calls this function must protect from GC! */
2698 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2699 doc
: /* Ask user a yes-or-no question.
2700 Return t if answer is yes, and nil if the answer is no.
2701 PROMPT is the string to display to ask the question. It should end in
2702 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2704 The user must confirm the answer with RET, and can edit it until it
2707 If dialog boxes are supported, a dialog box will be used
2708 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2709 (Lisp_Object prompt
)
2711 register Lisp_Object ans
;
2712 Lisp_Object args
[2];
2713 struct gcpro gcpro1
;
2715 CHECK_STRING (prompt
);
2717 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2720 Lisp_Object pane
, menu
, obj
;
2721 redisplay_preserve_echo_area (4);
2722 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2723 Fcons (build_string ("No"), Qnil
));
2725 menu
= Fcons (prompt
, pane
);
2726 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2732 args
[1] = build_string ("(yes or no) ");
2733 prompt
= Fconcat (2, args
);
2739 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2740 Qyes_or_no_p_history
, Qnil
,
2742 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2747 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2755 message1 ("Please answer yes or no.");
2756 Fsleep_for (make_number (2), Qnil
);
2760 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2761 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2763 Each of the three load averages is multiplied by 100, then converted
2766 When USE-FLOATS is non-nil, floats will be used instead of integers.
2767 These floats are not multiplied by 100.
2769 If the 5-minute or 15-minute load averages are not available, return a
2770 shortened list, containing only those averages which are available.
2772 An error is thrown if the load average can't be obtained. In some
2773 cases making it work would require Emacs being installed setuid or
2774 setgid so that it can read kernel information, and that usually isn't
2776 (Lisp_Object use_floats
)
2779 int loads
= getloadavg (load_ave
, 3);
2780 Lisp_Object ret
= Qnil
;
2783 error ("load-average not implemented for this operating system");
2787 Lisp_Object load
= (NILP (use_floats
)
2788 ? make_number (100.0 * load_ave
[loads
])
2789 : make_float (load_ave
[loads
]));
2790 ret
= Fcons (load
, ret
);
2796 static Lisp_Object Qsubfeatures
;
2798 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2799 doc
: /* Return t if FEATURE is present in this Emacs.
2801 Use this to conditionalize execution of lisp code based on the
2802 presence or absence of Emacs or environment extensions.
2803 Use `provide' to declare that a feature is available. This function
2804 looks at the value of the variable `features'. The optional argument
2805 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2806 (Lisp_Object feature
, Lisp_Object subfeature
)
2808 register Lisp_Object tem
;
2809 CHECK_SYMBOL (feature
);
2810 tem
= Fmemq (feature
, Vfeatures
);
2811 if (!NILP (tem
) && !NILP (subfeature
))
2812 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2813 return (NILP (tem
)) ? Qnil
: Qt
;
2816 static Lisp_Object Qfuncall
;
2818 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2819 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2820 The optional argument SUBFEATURES should be a list of symbols listing
2821 particular subfeatures supported in this version of FEATURE. */)
2822 (Lisp_Object feature
, Lisp_Object subfeatures
)
2824 register Lisp_Object tem
;
2825 CHECK_SYMBOL (feature
);
2826 CHECK_LIST (subfeatures
);
2827 if (!NILP (Vautoload_queue
))
2828 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2830 tem
= Fmemq (feature
, Vfeatures
);
2832 Vfeatures
= Fcons (feature
, Vfeatures
);
2833 if (!NILP (subfeatures
))
2834 Fput (feature
, Qsubfeatures
, subfeatures
);
2835 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2837 /* Run any load-hooks for this file. */
2838 tem
= Fassq (feature
, Vafter_load_alist
);
2840 Fmapc (Qfuncall
, XCDR (tem
));
2845 /* `require' and its subroutines. */
2847 /* List of features currently being require'd, innermost first. */
2849 static Lisp_Object require_nesting_list
;
2852 require_unwind (Lisp_Object old_value
)
2854 require_nesting_list
= old_value
;
2857 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2858 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2859 If FEATURE is not a member of the list `features', then the feature
2860 is not loaded; so load the file FILENAME.
2861 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2862 and `load' will try to load this name appended with the suffix `.elc' or
2863 `.el', in that order. The name without appended suffix will not be used.
2864 See `get-load-suffixes' for the complete list of suffixes.
2865 If the optional third argument NOERROR is non-nil,
2866 then return nil if the file is not found instead of signaling an error.
2867 Normally the return value is FEATURE.
2868 The normal messages at start and end of loading FILENAME are suppressed. */)
2869 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2872 struct gcpro gcpro1
, gcpro2
;
2873 bool from_file
= load_in_progress
;
2875 CHECK_SYMBOL (feature
);
2877 /* Record the presence of `require' in this file
2878 even if the feature specified is already loaded.
2879 But not more than once in any file,
2880 and not when we aren't loading or reading from a file. */
2882 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2883 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2888 tem
= Fcons (Qrequire
, feature
);
2889 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2890 LOADHIST_ATTACH (tem
);
2892 tem
= Fmemq (feature
, Vfeatures
);
2896 ptrdiff_t count
= SPECPDL_INDEX ();
2899 /* This is to make sure that loadup.el gives a clear picture
2900 of what files are preloaded and when. */
2901 if (! NILP (Vpurify_flag
))
2902 error ("(require %s) while preparing to dump",
2903 SDATA (SYMBOL_NAME (feature
)));
2905 /* A certain amount of recursive `require' is legitimate,
2906 but if we require the same feature recursively 3 times,
2908 tem
= require_nesting_list
;
2909 while (! NILP (tem
))
2911 if (! NILP (Fequal (feature
, XCAR (tem
))))
2916 error ("Recursive `require' for feature `%s'",
2917 SDATA (SYMBOL_NAME (feature
)));
2919 /* Update the list for any nested `require's that occur. */
2920 record_unwind_protect (require_unwind
, require_nesting_list
);
2921 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2923 /* Value saved here is to be restored into Vautoload_queue */
2924 record_unwind_protect (un_autoload
, Vautoload_queue
);
2925 Vautoload_queue
= Qt
;
2927 /* Load the file. */
2928 GCPRO2 (feature
, filename
);
2929 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2930 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2933 /* If load failed entirely, return nil. */
2935 return unbind_to (count
, Qnil
);
2937 tem
= Fmemq (feature
, Vfeatures
);
2939 error ("Required feature `%s' was not provided",
2940 SDATA (SYMBOL_NAME (feature
)));
2942 /* Once loading finishes, don't undo it. */
2943 Vautoload_queue
= Qt
;
2944 feature
= unbind_to (count
, feature
);
2950 /* Primitives for work of the "widget" library.
2951 In an ideal world, this section would not have been necessary.
2952 However, lisp function calls being as slow as they are, it turns
2953 out that some functions in the widget library (wid-edit.el) are the
2954 bottleneck of Widget operation. Here is their translation to C,
2955 for the sole reason of efficiency. */
2957 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2958 doc
: /* Return non-nil if PLIST has the property PROP.
2959 PLIST is a property list, which is a list of the form
2960 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2961 Unlike `plist-get', this allows you to distinguish between a missing
2962 property and a property with the value nil.
2963 The value is actually the tail of PLIST whose car is PROP. */)
2964 (Lisp_Object plist
, Lisp_Object prop
)
2966 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2969 plist
= XCDR (plist
);
2970 plist
= CDR (plist
);
2975 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2976 doc
: /* In WIDGET, set PROPERTY to VALUE.
2977 The value can later be retrieved with `widget-get'. */)
2978 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2980 CHECK_CONS (widget
);
2981 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2985 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2986 doc
: /* In WIDGET, get the value of PROPERTY.
2987 The value could either be specified when the widget was created, or
2988 later with `widget-put'. */)
2989 (Lisp_Object widget
, Lisp_Object property
)
2997 CHECK_CONS (widget
);
2998 tmp
= Fplist_member (XCDR (widget
), property
);
3004 tmp
= XCAR (widget
);
3007 widget
= Fget (tmp
, Qwidget_type
);
3011 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3012 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3013 ARGS are passed as extra arguments to the function.
3014 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3015 (ptrdiff_t nargs
, Lisp_Object
*args
)
3017 /* This function can GC. */
3018 Lisp_Object newargs
[3];
3019 struct gcpro gcpro1
, gcpro2
;
3022 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3023 newargs
[1] = args
[0];
3024 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3025 GCPRO2 (newargs
[0], newargs
[2]);
3026 result
= Fapply (3, newargs
);
3031 #ifdef HAVE_LANGINFO_CODESET
3032 #include <langinfo.h>
3035 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3036 doc
: /* Access locale data ITEM for the current C locale, if available.
3037 ITEM should be one of the following:
3039 `codeset', returning the character set as a string (locale item CODESET);
3041 `days', returning a 7-element vector of day names (locale items DAY_n);
3043 `months', returning a 12-element vector of month names (locale items MON_n);
3045 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3046 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3048 If the system can't provide such information through a call to
3049 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3051 See also Info node `(libc)Locales'.
3053 The data read from the system are decoded using `locale-coding-system'. */)
3057 #ifdef HAVE_LANGINFO_CODESET
3059 if (EQ (item
, Qcodeset
))
3061 str
= nl_langinfo (CODESET
);
3062 return build_string (str
);
3065 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3067 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3068 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3070 struct gcpro gcpro1
;
3072 synchronize_system_time_locale ();
3073 for (i
= 0; i
< 7; i
++)
3075 str
= nl_langinfo (days
[i
]);
3076 val
= build_unibyte_string (str
);
3077 /* Fixme: Is this coding system necessarily right, even if
3078 it is consistent with CODESET? If not, what to do? */
3079 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3087 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3089 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3090 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3091 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3093 struct gcpro gcpro1
;
3095 synchronize_system_time_locale ();
3096 for (i
= 0; i
< 12; i
++)
3098 str
= nl_langinfo (months
[i
]);
3099 val
= build_unibyte_string (str
);
3100 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3107 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3108 but is in the locale files. This could be used by ps-print. */
3110 else if (EQ (item
, Qpaper
))
3111 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3112 #endif /* PAPER_WIDTH */
3113 #endif /* HAVE_LANGINFO_CODESET*/
3117 /* base64 encode/decode functions (RFC 2045).
3118 Based on code from GNU recode. */
3120 #define MIME_LINE_LENGTH 76
3122 #define IS_ASCII(Character) \
3124 #define IS_BASE64(Character) \
3125 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3126 #define IS_BASE64_IGNORABLE(Character) \
3127 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3128 || (Character) == '\f' || (Character) == '\r')
3130 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3131 character or return retval if there are no characters left to
3133 #define READ_QUADRUPLET_BYTE(retval) \
3138 if (nchars_return) \
3139 *nchars_return = nchars; \
3144 while (IS_BASE64_IGNORABLE (c))
3146 /* Table of characters coding the 64 values. */
3147 static const char base64_value_to_char
[64] =
3149 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3150 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3151 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3152 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3153 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3154 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3155 '8', '9', '+', '/' /* 60-63 */
3158 /* Table of base64 values for first 128 characters. */
3159 static const short base64_char_to_value
[128] =
3161 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3162 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3163 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3164 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3165 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3166 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3167 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3168 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3169 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3170 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3171 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3172 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3173 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3176 /* The following diagram shows the logical steps by which three octets
3177 get transformed into four base64 characters.
3179 .--------. .--------. .--------.
3180 |aaaaaabb| |bbbbcccc| |ccdddddd|
3181 `--------' `--------' `--------'
3183 .--------+--------+--------+--------.
3184 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3185 `--------+--------+--------+--------'
3187 .--------+--------+--------+--------.
3188 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3189 `--------+--------+--------+--------'
3191 The octets are divided into 6 bit chunks, which are then encoded into
3192 base64 characters. */
3195 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3196 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3199 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3201 doc
: /* Base64-encode the region between BEG and END.
3202 Return the length of the encoded text.
3203 Optional third argument NO-LINE-BREAK means do not break long lines
3204 into shorter lines. */)
3205 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3208 ptrdiff_t allength
, length
;
3209 ptrdiff_t ibeg
, iend
, encoded_length
;
3210 ptrdiff_t old_pos
= PT
;
3213 validate_region (&beg
, &end
);
3215 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3216 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3217 move_gap_both (XFASTINT (beg
), ibeg
);
3219 /* We need to allocate enough room for encoding the text.
3220 We need 33 1/3% more space, plus a newline every 76
3221 characters, and then we round up. */
3222 length
= iend
- ibeg
;
3223 allength
= length
+ length
/3 + 1;
3224 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3226 encoded
= SAFE_ALLOCA (allength
);
3227 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3228 encoded
, length
, NILP (no_line_break
),
3229 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3230 if (encoded_length
> allength
)
3233 if (encoded_length
< 0)
3235 /* The encoding wasn't possible. */
3237 error ("Multibyte character in data for base64 encoding");
3240 /* Now we have encoded the region, so we insert the new contents
3241 and delete the old. (Insert first in order to preserve markers.) */
3242 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3243 insert (encoded
, encoded_length
);
3245 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3247 /* If point was outside of the region, restore it exactly; else just
3248 move to the beginning of the region. */
3249 if (old_pos
>= XFASTINT (end
))
3250 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3251 else if (old_pos
> XFASTINT (beg
))
3252 old_pos
= XFASTINT (beg
);
3255 /* We return the length of the encoded text. */
3256 return make_number (encoded_length
);
3259 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3261 doc
: /* Base64-encode STRING and return the result.
3262 Optional second argument NO-LINE-BREAK means do not break long lines
3263 into shorter lines. */)
3264 (Lisp_Object string
, Lisp_Object no_line_break
)
3266 ptrdiff_t allength
, length
, encoded_length
;
3268 Lisp_Object encoded_string
;
3271 CHECK_STRING (string
);
3273 /* We need to allocate enough room for encoding the text.
3274 We need 33 1/3% more space, plus a newline every 76
3275 characters, and then we round up. */
3276 length
= SBYTES (string
);
3277 allength
= length
+ length
/3 + 1;
3278 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3280 /* We need to allocate enough room for decoding the text. */
3281 encoded
= SAFE_ALLOCA (allength
);
3283 encoded_length
= base64_encode_1 (SSDATA (string
),
3284 encoded
, length
, NILP (no_line_break
),
3285 STRING_MULTIBYTE (string
));
3286 if (encoded_length
> allength
)
3289 if (encoded_length
< 0)
3291 /* The encoding wasn't possible. */
3293 error ("Multibyte character in data for base64 encoding");
3296 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3299 return encoded_string
;
3303 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3304 bool line_break
, bool multibyte
)
3317 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3318 if (CHAR_BYTE8_P (c
))
3319 c
= CHAR_TO_BYTE8 (c
);
3327 /* Wrap line every 76 characters. */
3331 if (counter
< MIME_LINE_LENGTH
/ 4)
3340 /* Process first byte of a triplet. */
3342 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3343 value
= (0x03 & c
) << 4;
3345 /* Process second byte of a triplet. */
3349 *e
++ = base64_value_to_char
[value
];
3357 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3358 if (CHAR_BYTE8_P (c
))
3359 c
= CHAR_TO_BYTE8 (c
);
3367 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3368 value
= (0x0f & c
) << 2;
3370 /* Process third byte of a triplet. */
3374 *e
++ = base64_value_to_char
[value
];
3381 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3382 if (CHAR_BYTE8_P (c
))
3383 c
= CHAR_TO_BYTE8 (c
);
3391 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3392 *e
++ = base64_value_to_char
[0x3f & c
];
3399 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3401 doc
: /* Base64-decode the region between BEG and END.
3402 Return the length of the decoded text.
3403 If the region can't be decoded, signal an error and don't modify the buffer. */)
3404 (Lisp_Object beg
, Lisp_Object end
)
3406 ptrdiff_t ibeg
, iend
, length
, allength
;
3408 ptrdiff_t old_pos
= PT
;
3409 ptrdiff_t decoded_length
;
3410 ptrdiff_t inserted_chars
;
3411 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3414 validate_region (&beg
, &end
);
3416 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3417 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3419 length
= iend
- ibeg
;
3421 /* We need to allocate enough room for decoding the text. If we are
3422 working on a multibyte buffer, each decoded code may occupy at
3424 allength
= multibyte
? length
* 2 : length
;
3425 decoded
= SAFE_ALLOCA (allength
);
3427 move_gap_both (XFASTINT (beg
), ibeg
);
3428 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3430 multibyte
, &inserted_chars
);
3431 if (decoded_length
> allength
)
3434 if (decoded_length
< 0)
3436 /* The decoding wasn't possible. */
3438 error ("Invalid base64 data");
3441 /* Now we have decoded the region, so we insert the new contents
3442 and delete the old. (Insert first in order to preserve markers.) */
3443 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3444 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3447 /* Delete the original text. */
3448 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3449 iend
+ decoded_length
, 1);
3451 /* If point was outside of the region, restore it exactly; else just
3452 move to the beginning of the region. */
3453 if (old_pos
>= XFASTINT (end
))
3454 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3455 else if (old_pos
> XFASTINT (beg
))
3456 old_pos
= XFASTINT (beg
);
3457 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3459 return make_number (inserted_chars
);
3462 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3464 doc
: /* Base64-decode STRING and return the result. */)
3465 (Lisp_Object string
)
3468 ptrdiff_t length
, decoded_length
;
3469 Lisp_Object decoded_string
;
3472 CHECK_STRING (string
);
3474 length
= SBYTES (string
);
3475 /* We need to allocate enough room for decoding the text. */
3476 decoded
= SAFE_ALLOCA (length
);
3478 /* The decoded result should be unibyte. */
3479 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3481 if (decoded_length
> length
)
3483 else if (decoded_length
>= 0)
3484 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3486 decoded_string
= Qnil
;
3489 if (!STRINGP (decoded_string
))
3490 error ("Invalid base64 data");
3492 return decoded_string
;
3495 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3496 MULTIBYTE, the decoded result should be in multibyte
3497 form. If NCHARS_RETURN is not NULL, store the number of produced
3498 characters in *NCHARS_RETURN. */
3501 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3502 bool multibyte
, ptrdiff_t *nchars_return
)
3504 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3507 unsigned long value
;
3508 ptrdiff_t nchars
= 0;
3512 /* Process first byte of a quadruplet. */
3514 READ_QUADRUPLET_BYTE (e
-to
);
3518 value
= base64_char_to_value
[c
] << 18;
3520 /* Process second byte of a quadruplet. */
3522 READ_QUADRUPLET_BYTE (-1);
3526 value
|= base64_char_to_value
[c
] << 12;
3528 c
= (unsigned char) (value
>> 16);
3529 if (multibyte
&& c
>= 128)
3530 e
+= BYTE8_STRING (c
, e
);
3535 /* Process third byte of a quadruplet. */
3537 READ_QUADRUPLET_BYTE (-1);
3541 READ_QUADRUPLET_BYTE (-1);
3550 value
|= base64_char_to_value
[c
] << 6;
3552 c
= (unsigned char) (0xff & value
>> 8);
3553 if (multibyte
&& c
>= 128)
3554 e
+= BYTE8_STRING (c
, e
);
3559 /* Process fourth byte of a quadruplet. */
3561 READ_QUADRUPLET_BYTE (-1);
3568 value
|= base64_char_to_value
[c
];
3570 c
= (unsigned char) (0xff & value
);
3571 if (multibyte
&& c
>= 128)
3572 e
+= BYTE8_STRING (c
, e
);
3581 /***********************************************************************
3583 ***** Hash Tables *****
3585 ***********************************************************************/
3587 /* Implemented by gerd@gnu.org. This hash table implementation was
3588 inspired by CMUCL hash tables. */
3592 1. For small tables, association lists are probably faster than
3593 hash tables because they have lower overhead.
3595 For uses of hash tables where the O(1) behavior of table
3596 operations is not a requirement, it might therefore be a good idea
3597 not to hash. Instead, we could just do a linear search in the
3598 key_and_value vector of the hash table. This could be done
3599 if a `:linear-search t' argument is given to make-hash-table. */
3602 /* The list of all weak hash tables. Don't staticpro this one. */
3604 static struct Lisp_Hash_Table
*weak_hash_tables
;
3606 /* Various symbols. */
3608 static Lisp_Object Qhash_table_p
;
3609 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3610 Lisp_Object Qeq
, Qequal
;
3611 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3612 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3615 /***********************************************************************
3617 ***********************************************************************/
3620 CHECK_HASH_TABLE (Lisp_Object x
)
3622 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3626 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3628 h
->key_and_value
= key_and_value
;
3631 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3636 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3638 gc_aset (h
->next
, idx
, val
);
3641 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3646 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3648 gc_aset (h
->hash
, idx
, val
);
3651 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3656 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3658 gc_aset (h
->index
, idx
, val
);
3661 /* If OBJ is a Lisp hash table, return a pointer to its struct
3662 Lisp_Hash_Table. Otherwise, signal an error. */
3664 static struct Lisp_Hash_Table
*
3665 check_hash_table (Lisp_Object obj
)
3667 CHECK_HASH_TABLE (obj
);
3668 return XHASH_TABLE (obj
);
3672 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3673 number. A number is "almost" a prime number if it is not divisible
3674 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3677 next_almost_prime (EMACS_INT n
)
3679 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3680 for (n
|= 1; ; n
+= 2)
3681 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3686 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3687 which USED[I] is non-zero. If found at index I in ARGS, set
3688 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3689 0. This function is used to extract a keyword/argument pair from
3690 a DEFUN parameter list. */
3693 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3697 for (i
= 1; i
< nargs
; i
++)
3698 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3709 /* Return a Lisp vector which has the same contents as VEC but has
3710 at least INCR_MIN more entries, where INCR_MIN is positive.
3711 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3712 than NITEMS_MAX. Entries in the resulting
3713 vector that are not copied from VEC are set to nil. */
3716 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3718 struct Lisp_Vector
*v
;
3719 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3720 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3721 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3722 ? nitems_max
: C_language_max
);
3723 eassert (VECTORP (vec
));
3724 eassert (0 < incr_min
&& -1 <= nitems_max
);
3725 old_size
= ASIZE (vec
);
3726 incr_max
= n_max
- old_size
;
3727 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3728 if (incr_max
< incr
)
3729 memory_full (SIZE_MAX
);
3730 new_size
= old_size
+ incr
;
3731 v
= allocate_vector (new_size
);
3732 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3733 for (i
= old_size
; i
< new_size
; ++i
)
3734 v
->contents
[i
] = Qnil
;
3735 XSETVECTOR (vec
, v
);
3740 /***********************************************************************
3742 ***********************************************************************/
3744 static struct hash_table_test hashtest_eq
;
3745 struct hash_table_test hashtest_eql
, hashtest_equal
;
3747 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3748 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3749 KEY2 are the same. */
3752 cmpfn_eql (struct hash_table_test
*ht
,
3756 return (FLOATP (key1
)
3758 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3762 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3763 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3764 KEY2 are the same. */
3767 cmpfn_equal (struct hash_table_test
*ht
,
3771 return !NILP (Fequal (key1
, key2
));
3775 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3776 HASH2 in hash table H using H->user_cmp_function. Value is true
3777 if KEY1 and KEY2 are the same. */
3780 cmpfn_user_defined (struct hash_table_test
*ht
,
3784 Lisp_Object args
[3];
3786 args
[0] = ht
->user_cmp_function
;
3789 return !NILP (Ffuncall (3, args
));
3793 /* Value is a hash code for KEY for use in hash table H which uses
3794 `eq' to compare keys. The hash code returned is guaranteed to fit
3795 in a Lisp integer. */
3798 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3800 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3804 /* Value is a hash code for KEY for use in hash table H which uses
3805 `eql' to compare keys. The hash code returned is guaranteed to fit
3806 in a Lisp integer. */
3809 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3813 hash
= sxhash (key
, 0);
3815 hash
= XHASH (key
) ^ XTYPE (key
);
3819 /* Value is a hash code for KEY for use in hash table H which uses
3820 `equal' to compare keys. The hash code returned is guaranteed to fit
3821 in a Lisp integer. */
3824 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3826 EMACS_UINT hash
= sxhash (key
, 0);
3830 /* Value is a hash code for KEY for use in hash table H which uses as
3831 user-defined function to compare keys. The hash code returned is
3832 guaranteed to fit in a Lisp integer. */
3835 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3837 Lisp_Object args
[2], hash
;
3839 args
[0] = ht
->user_hash_function
;
3841 hash
= Ffuncall (2, args
);
3842 return hashfn_eq (ht
, hash
);
3845 /* An upper bound on the size of a hash table index. It must fit in
3846 ptrdiff_t and be a valid Emacs fixnum. */
3847 #define INDEX_SIZE_BOUND \
3848 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3850 /* Create and initialize a new hash table.
3852 TEST specifies the test the hash table will use to compare keys.
3853 It must be either one of the predefined tests `eq', `eql' or
3854 `equal' or a symbol denoting a user-defined test named TEST with
3855 test and hash functions USER_TEST and USER_HASH.
3857 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3859 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3860 new size when it becomes full is computed by adding REHASH_SIZE to
3861 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3862 table's new size is computed by multiplying its old size with
3865 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3866 be resized when the ratio of (number of entries in the table) /
3867 (table size) is >= REHASH_THRESHOLD.
3869 WEAK specifies the weakness of the table. If non-nil, it must be
3870 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3873 make_hash_table (struct hash_table_test test
,
3874 Lisp_Object size
, Lisp_Object rehash_size
,
3875 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3877 struct Lisp_Hash_Table
*h
;
3879 EMACS_INT index_size
, sz
;
3883 /* Preconditions. */
3884 eassert (SYMBOLP (test
.name
));
3885 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3886 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3887 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3888 eassert (FLOATP (rehash_threshold
)
3889 && 0 < XFLOAT_DATA (rehash_threshold
)
3890 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3892 if (XFASTINT (size
) == 0)
3893 size
= make_number (1);
3895 sz
= XFASTINT (size
);
3896 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3897 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3898 ? next_almost_prime (index_float
)
3899 : INDEX_SIZE_BOUND
+ 1);
3900 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3901 error ("Hash table too large");
3903 /* Allocate a table and initialize it. */
3904 h
= allocate_hash_table ();
3906 /* Initialize hash table slots. */
3909 h
->rehash_threshold
= rehash_threshold
;
3910 h
->rehash_size
= rehash_size
;
3912 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3913 h
->hash
= Fmake_vector (size
, Qnil
);
3914 h
->next
= Fmake_vector (size
, Qnil
);
3915 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3917 /* Set up the free list. */
3918 for (i
= 0; i
< sz
- 1; ++i
)
3919 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3920 h
->next_free
= make_number (0);
3922 XSET_HASH_TABLE (table
, h
);
3923 eassert (HASH_TABLE_P (table
));
3924 eassert (XHASH_TABLE (table
) == h
);
3926 /* Maybe add this hash table to the list of all weak hash tables. */
3928 h
->next_weak
= NULL
;
3931 h
->next_weak
= weak_hash_tables
;
3932 weak_hash_tables
= h
;
3939 /* Return a copy of hash table H1. Keys and values are not copied,
3940 only the table itself is. */
3943 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3946 struct Lisp_Hash_Table
*h2
;
3948 h2
= allocate_hash_table ();
3950 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3951 h2
->hash
= Fcopy_sequence (h1
->hash
);
3952 h2
->next
= Fcopy_sequence (h1
->next
);
3953 h2
->index
= Fcopy_sequence (h1
->index
);
3954 XSET_HASH_TABLE (table
, h2
);
3956 /* Maybe add this hash table to the list of all weak hash tables. */
3957 if (!NILP (h2
->weak
))
3959 h2
->next_weak
= weak_hash_tables
;
3960 weak_hash_tables
= h2
;
3967 /* Resize hash table H if it's too full. If H cannot be resized
3968 because it's already too large, throw an error. */
3971 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3973 if (NILP (h
->next_free
))
3975 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3976 EMACS_INT new_size
, index_size
, nsize
;
3980 if (INTEGERP (h
->rehash_size
))
3981 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3984 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3985 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3987 new_size
= float_new_size
;
3988 if (new_size
<= old_size
)
3989 new_size
= old_size
+ 1;
3992 new_size
= INDEX_SIZE_BOUND
+ 1;
3994 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3995 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3996 ? next_almost_prime (index_float
)
3997 : INDEX_SIZE_BOUND
+ 1);
3998 nsize
= max (index_size
, 2 * new_size
);
3999 if (INDEX_SIZE_BOUND
< nsize
)
4000 error ("Hash table too large to resize");
4002 #ifdef ENABLE_CHECKING
4003 if (HASH_TABLE_P (Vpurify_flag
)
4004 && XHASH_TABLE (Vpurify_flag
) == h
)
4006 Lisp_Object args
[2];
4007 args
[0] = build_string ("Growing hash table to: %d");
4008 args
[1] = make_number (new_size
);
4013 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
4014 2 * (new_size
- old_size
), -1));
4015 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
4016 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
4017 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
4019 /* Update the free list. Do it so that new entries are added at
4020 the end of the free list. This makes some operations like
4022 for (i
= old_size
; i
< new_size
- 1; ++i
)
4023 set_hash_next_slot (h
, i
, make_number (i
+ 1));
4025 if (!NILP (h
->next_free
))
4027 Lisp_Object last
, next
;
4029 last
= h
->next_free
;
4030 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4034 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
4037 XSETFASTINT (h
->next_free
, old_size
);
4040 for (i
= 0; i
< old_size
; ++i
)
4041 if (!NILP (HASH_HASH (h
, i
)))
4043 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4044 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4045 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4046 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4052 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4053 the hash code of KEY. Value is the index of the entry in H
4054 matching KEY, or -1 if not found. */
4057 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4059 EMACS_UINT hash_code
;
4060 ptrdiff_t start_of_bucket
;
4063 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4064 eassert ((hash_code
& ~INTMASK
) == 0);
4068 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4069 idx
= HASH_INDEX (h
, start_of_bucket
);
4071 /* We need not gcpro idx since it's either an integer or nil. */
4074 ptrdiff_t i
= XFASTINT (idx
);
4075 if (EQ (key
, HASH_KEY (h
, i
))
4077 && hash_code
== XUINT (HASH_HASH (h
, i
))
4078 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4080 idx
= HASH_NEXT (h
, i
);
4083 return NILP (idx
) ? -1 : XFASTINT (idx
);
4087 /* Put an entry into hash table H that associates KEY with VALUE.
4088 HASH is a previously computed hash code of KEY.
4089 Value is the index of the entry in H matching KEY. */
4092 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4095 ptrdiff_t start_of_bucket
, i
;
4097 eassert ((hash
& ~INTMASK
) == 0);
4099 /* Increment count after resizing because resizing may fail. */
4100 maybe_resize_hash_table (h
);
4103 /* Store key/value in the key_and_value vector. */
4104 i
= XFASTINT (h
->next_free
);
4105 h
->next_free
= HASH_NEXT (h
, i
);
4106 set_hash_key_slot (h
, i
, key
);
4107 set_hash_value_slot (h
, i
, value
);
4109 /* Remember its hash code. */
4110 set_hash_hash_slot (h
, i
, make_number (hash
));
4112 /* Add new entry to its collision chain. */
4113 start_of_bucket
= hash
% ASIZE (h
->index
);
4114 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4115 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4120 /* Remove the entry matching KEY from hash table H, if there is one. */
4123 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4125 EMACS_UINT hash_code
;
4126 ptrdiff_t start_of_bucket
;
4127 Lisp_Object idx
, prev
;
4129 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4130 eassert ((hash_code
& ~INTMASK
) == 0);
4131 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4132 idx
= HASH_INDEX (h
, start_of_bucket
);
4135 /* We need not gcpro idx, prev since they're either integers or nil. */
4138 ptrdiff_t i
= XFASTINT (idx
);
4140 if (EQ (key
, HASH_KEY (h
, i
))
4142 && hash_code
== XUINT (HASH_HASH (h
, i
))
4143 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4145 /* Take entry out of collision chain. */
4147 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4149 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4151 /* Clear slots in key_and_value and add the slots to
4153 set_hash_key_slot (h
, i
, Qnil
);
4154 set_hash_value_slot (h
, i
, Qnil
);
4155 set_hash_hash_slot (h
, i
, Qnil
);
4156 set_hash_next_slot (h
, i
, h
->next_free
);
4157 h
->next_free
= make_number (i
);
4159 eassert (h
->count
>= 0);
4165 idx
= HASH_NEXT (h
, i
);
4171 /* Clear hash table H. */
4174 hash_clear (struct Lisp_Hash_Table
*h
)
4178 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4180 for (i
= 0; i
< size
; ++i
)
4182 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4183 set_hash_key_slot (h
, i
, Qnil
);
4184 set_hash_value_slot (h
, i
, Qnil
);
4185 set_hash_hash_slot (h
, i
, Qnil
);
4188 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4189 ASET (h
->index
, i
, Qnil
);
4191 h
->next_free
= make_number (0);
4198 /************************************************************************
4200 ************************************************************************/
4202 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4203 entries from the table that don't survive the current GC.
4204 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4205 true if anything was marked. */
4208 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4210 ptrdiff_t bucket
, n
;
4213 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4216 for (bucket
= 0; bucket
< n
; ++bucket
)
4218 Lisp_Object idx
, next
, prev
;
4220 /* Follow collision chain, removing entries that
4221 don't survive this garbage collection. */
4223 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4225 ptrdiff_t i
= XFASTINT (idx
);
4226 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4227 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4230 if (EQ (h
->weak
, Qkey
))
4231 remove_p
= !key_known_to_survive_p
;
4232 else if (EQ (h
->weak
, Qvalue
))
4233 remove_p
= !value_known_to_survive_p
;
4234 else if (EQ (h
->weak
, Qkey_or_value
))
4235 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4236 else if (EQ (h
->weak
, Qkey_and_value
))
4237 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4241 next
= HASH_NEXT (h
, i
);
4243 if (remove_entries_p
)
4247 /* Take out of collision chain. */
4249 set_hash_index_slot (h
, bucket
, next
);
4251 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4253 /* Add to free list. */
4254 set_hash_next_slot (h
, i
, h
->next_free
);
4257 /* Clear key, value, and hash. */
4258 set_hash_key_slot (h
, i
, Qnil
);
4259 set_hash_value_slot (h
, i
, Qnil
);
4260 set_hash_hash_slot (h
, i
, Qnil
);
4273 /* Make sure key and value survive. */
4274 if (!key_known_to_survive_p
)
4276 mark_object (HASH_KEY (h
, i
));
4280 if (!value_known_to_survive_p
)
4282 mark_object (HASH_VALUE (h
, i
));
4293 /* Remove elements from weak hash tables that don't survive the
4294 current garbage collection. Remove weak tables that don't survive
4295 from Vweak_hash_tables. Called from gc_sweep. */
4297 NO_INLINE
/* For better stack traces */
4299 sweep_weak_hash_tables (void)
4301 struct Lisp_Hash_Table
*h
, *used
, *next
;
4304 /* Mark all keys and values that are in use. Keep on marking until
4305 there is no more change. This is necessary for cases like
4306 value-weak table A containing an entry X -> Y, where Y is used in a
4307 key-weak table B, Z -> Y. If B comes after A in the list of weak
4308 tables, X -> Y might be removed from A, although when looking at B
4309 one finds that it shouldn't. */
4313 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4315 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4316 marked
|= sweep_weak_table (h
, 0);
4321 /* Remove tables and entries that aren't used. */
4322 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4324 next
= h
->next_weak
;
4326 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4328 /* TABLE is marked as used. Sweep its contents. */
4330 sweep_weak_table (h
, 1);
4332 /* Add table to the list of used weak hash tables. */
4333 h
->next_weak
= used
;
4338 weak_hash_tables
= used
;
4343 /***********************************************************************
4344 Hash Code Computation
4345 ***********************************************************************/
4347 /* Maximum depth up to which to dive into Lisp structures. */
4349 #define SXHASH_MAX_DEPTH 3
4351 /* Maximum length up to which to take list and vector elements into
4354 #define SXHASH_MAX_LEN 7
4356 /* Return a hash for string PTR which has length LEN. The hash value
4357 can be any EMACS_UINT value. */
4360 hash_string (char const *ptr
, ptrdiff_t len
)
4362 char const *p
= ptr
;
4363 char const *end
= p
+ len
;
4365 EMACS_UINT hash
= 0;
4370 hash
= sxhash_combine (hash
, c
);
4376 /* Return a hash for string PTR which has length LEN. The hash
4377 code returned is guaranteed to fit in a Lisp integer. */
4380 sxhash_string (char const *ptr
, ptrdiff_t len
)
4382 EMACS_UINT hash
= hash_string (ptr
, len
);
4383 return SXHASH_REDUCE (hash
);
4386 /* Return a hash for the floating point value VAL. */
4389 sxhash_float (double val
)
4391 EMACS_UINT hash
= 0;
4393 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4394 + (sizeof val
% sizeof hash
!= 0))
4398 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4402 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4403 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4404 hash
= sxhash_combine (hash
, u
.word
[i
]);
4405 return SXHASH_REDUCE (hash
);
4408 /* Return a hash for list LIST. DEPTH is the current depth in the
4409 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4412 sxhash_list (Lisp_Object list
, int depth
)
4414 EMACS_UINT hash
= 0;
4417 if (depth
< SXHASH_MAX_DEPTH
)
4419 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4420 list
= XCDR (list
), ++i
)
4422 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4423 hash
= sxhash_combine (hash
, hash2
);
4428 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4429 hash
= sxhash_combine (hash
, hash2
);
4432 return SXHASH_REDUCE (hash
);
4436 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4437 the Lisp structure. */
4440 sxhash_vector (Lisp_Object vec
, int depth
)
4442 EMACS_UINT hash
= ASIZE (vec
);
4445 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4446 for (i
= 0; i
< n
; ++i
)
4448 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4449 hash
= sxhash_combine (hash
, hash2
);
4452 return SXHASH_REDUCE (hash
);
4455 /* Return a hash for bool-vector VECTOR. */
4458 sxhash_bool_vector (Lisp_Object vec
)
4460 EMACS_INT size
= bool_vector_size (vec
);
4461 EMACS_UINT hash
= size
;
4464 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4465 for (i
= 0; i
< n
; ++i
)
4466 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4468 return SXHASH_REDUCE (hash
);
4472 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4473 structure. Value is an unsigned integer clipped to INTMASK. */
4476 sxhash (Lisp_Object obj
, int depth
)
4480 if (depth
> SXHASH_MAX_DEPTH
)
4483 switch (XTYPE (obj
))
4494 obj
= SYMBOL_NAME (obj
);
4498 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4501 /* This can be everything from a vector to an overlay. */
4502 case Lisp_Vectorlike
:
4504 /* According to the CL HyperSpec, two arrays are equal only if
4505 they are `eq', except for strings and bit-vectors. In
4506 Emacs, this works differently. We have to compare element
4508 hash
= sxhash_vector (obj
, depth
);
4509 else if (BOOL_VECTOR_P (obj
))
4510 hash
= sxhash_bool_vector (obj
);
4512 /* Others are `equal' if they are `eq', so let's take their
4518 hash
= sxhash_list (obj
, depth
);
4522 hash
= sxhash_float (XFLOAT_DATA (obj
));
4534 /***********************************************************************
4536 ***********************************************************************/
4539 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4540 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4543 EMACS_UINT hash
= sxhash (obj
, 0);
4544 return make_number (hash
);
4548 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4549 doc
: /* Create and return a new hash table.
4551 Arguments are specified as keyword/argument pairs. The following
4552 arguments are defined:
4554 :test TEST -- TEST must be a symbol that specifies how to compare
4555 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4556 `equal'. User-supplied test and hash functions can be specified via
4557 `define-hash-table-test'.
4559 :size SIZE -- A hint as to how many elements will be put in the table.
4562 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4563 fills up. If REHASH-SIZE is an integer, increase the size by that
4564 amount. If it is a float, it must be > 1.0, and the new size is the
4565 old size multiplied by that factor. Default is 1.5.
4567 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4568 Resize the hash table when the ratio (number of entries / table size)
4569 is greater than or equal to THRESHOLD. Default is 0.8.
4571 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4572 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4573 returned is a weak table. Key/value pairs are removed from a weak
4574 hash table when there are no non-weak references pointing to their
4575 key, value, one of key or value, or both key and value, depending on
4576 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4579 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4580 (ptrdiff_t nargs
, Lisp_Object
*args
)
4582 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4583 struct hash_table_test testdesc
;
4587 /* The vector `used' is used to keep track of arguments that
4588 have been consumed. */
4589 used
= alloca (nargs
* sizeof *used
);
4590 memset (used
, 0, nargs
* sizeof *used
);
4592 /* See if there's a `:test TEST' among the arguments. */
4593 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4594 test
= i
? args
[i
] : Qeql
;
4596 testdesc
= hashtest_eq
;
4597 else if (EQ (test
, Qeql
))
4598 testdesc
= hashtest_eql
;
4599 else if (EQ (test
, Qequal
))
4600 testdesc
= hashtest_equal
;
4603 /* See if it is a user-defined test. */
4606 prop
= Fget (test
, Qhash_table_test
);
4607 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4608 signal_error ("Invalid hash table test", test
);
4609 testdesc
.name
= test
;
4610 testdesc
.user_cmp_function
= XCAR (prop
);
4611 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4612 testdesc
.hashfn
= hashfn_user_defined
;
4613 testdesc
.cmpfn
= cmpfn_user_defined
;
4616 /* See if there's a `:size SIZE' argument. */
4617 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4618 size
= i
? args
[i
] : Qnil
;
4620 size
= make_number (DEFAULT_HASH_SIZE
);
4621 else if (!INTEGERP (size
) || XINT (size
) < 0)
4622 signal_error ("Invalid hash table size", size
);
4624 /* Look for `:rehash-size SIZE'. */
4625 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4626 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4627 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4628 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4629 signal_error ("Invalid hash table rehash size", rehash_size
);
4631 /* Look for `:rehash-threshold THRESHOLD'. */
4632 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4633 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4634 if (! (FLOATP (rehash_threshold
)
4635 && 0 < XFLOAT_DATA (rehash_threshold
)
4636 && XFLOAT_DATA (rehash_threshold
) <= 1))
4637 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4639 /* Look for `:weakness WEAK'. */
4640 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4641 weak
= i
? args
[i
] : Qnil
;
4643 weak
= Qkey_and_value
;
4646 && !EQ (weak
, Qvalue
)
4647 && !EQ (weak
, Qkey_or_value
)
4648 && !EQ (weak
, Qkey_and_value
))
4649 signal_error ("Invalid hash table weakness", weak
);
4651 /* Now, all args should have been used up, or there's a problem. */
4652 for (i
= 0; i
< nargs
; ++i
)
4654 signal_error ("Invalid argument list", args
[i
]);
4656 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4660 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4661 doc
: /* Return a copy of hash table TABLE. */)
4664 return copy_hash_table (check_hash_table (table
));
4668 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4669 doc
: /* Return the number of elements in TABLE. */)
4672 return make_number (check_hash_table (table
)->count
);
4676 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4677 Shash_table_rehash_size
, 1, 1, 0,
4678 doc
: /* Return the current rehash size of TABLE. */)
4681 return check_hash_table (table
)->rehash_size
;
4685 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4686 Shash_table_rehash_threshold
, 1, 1, 0,
4687 doc
: /* Return the current rehash threshold of TABLE. */)
4690 return check_hash_table (table
)->rehash_threshold
;
4694 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4695 doc
: /* Return the size of TABLE.
4696 The size can be used as an argument to `make-hash-table' to create
4697 a hash table than can hold as many elements as TABLE holds
4698 without need for resizing. */)
4701 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4702 return make_number (HASH_TABLE_SIZE (h
));
4706 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4707 doc
: /* Return the test TABLE uses. */)
4710 return check_hash_table (table
)->test
.name
;
4714 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4716 doc
: /* Return the weakness of TABLE. */)
4719 return check_hash_table (table
)->weak
;
4723 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4724 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4727 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4731 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4732 doc
: /* Clear hash table TABLE and return it. */)
4735 hash_clear (check_hash_table (table
));
4736 /* Be compatible with XEmacs. */
4741 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4742 doc
: /* Look up KEY in TABLE and return its associated value.
4743 If KEY is not found, return DFLT which defaults to nil. */)
4744 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4746 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4747 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4748 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4752 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4753 doc
: /* Associate KEY with VALUE in hash table TABLE.
4754 If KEY is already present in table, replace its current value with
4755 VALUE. In any case, return VALUE. */)
4756 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4758 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4762 i
= hash_lookup (h
, key
, &hash
);
4764 set_hash_value_slot (h
, i
, value
);
4766 hash_put (h
, key
, value
, hash
);
4772 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4773 doc
: /* Remove KEY from TABLE. */)
4774 (Lisp_Object key
, Lisp_Object table
)
4776 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4777 hash_remove_from_table (h
, key
);
4782 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4783 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4784 FUNCTION is called with two arguments, KEY and VALUE.
4785 `maphash' always returns nil. */)
4786 (Lisp_Object function
, Lisp_Object table
)
4788 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4789 Lisp_Object args
[3];
4792 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4793 if (!NILP (HASH_HASH (h
, i
)))
4796 args
[1] = HASH_KEY (h
, i
);
4797 args
[2] = HASH_VALUE (h
, i
);
4805 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4806 Sdefine_hash_table_test
, 3, 3, 0,
4807 doc
: /* Define a new hash table test with name NAME, a symbol.
4809 In hash tables created with NAME specified as test, use TEST to
4810 compare keys, and HASH for computing hash codes of keys.
4812 TEST must be a function taking two arguments and returning non-nil if
4813 both arguments are the same. HASH must be a function taking one
4814 argument and returning an object that is the hash code of the argument.
4815 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4816 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4817 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4819 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4824 /************************************************************************
4825 MD5, SHA-1, and SHA-2
4826 ************************************************************************/
4833 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4836 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4837 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4841 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4842 register EMACS_INT b
, e
;
4843 register struct buffer
*bp
;
4846 void *(*hash_func
) (const char *, size_t, void *);
4849 CHECK_SYMBOL (algorithm
);
4851 if (STRINGP (object
))
4853 if (NILP (coding_system
))
4855 /* Decide the coding-system to encode the data with. */
4857 if (STRING_MULTIBYTE (object
))
4858 /* use default, we can't guess correct value */
4859 coding_system
= preferred_coding_system ();
4861 coding_system
= Qraw_text
;
4864 if (NILP (Fcoding_system_p (coding_system
)))
4866 /* Invalid coding system. */
4868 if (!NILP (noerror
))
4869 coding_system
= Qraw_text
;
4871 xsignal1 (Qcoding_system_error
, coding_system
);
4874 if (STRING_MULTIBYTE (object
))
4875 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4877 size
= SCHARS (object
);
4878 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4880 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4881 end_byte
= (end_char
== size
4883 : string_char_to_byte (object
, end_char
));
4887 struct buffer
*prev
= current_buffer
;
4889 record_unwind_current_buffer ();
4891 CHECK_BUFFER (object
);
4893 bp
= XBUFFER (object
);
4894 set_buffer_internal (bp
);
4900 CHECK_NUMBER_COERCE_MARKER (start
);
4908 CHECK_NUMBER_COERCE_MARKER (end
);
4913 temp
= b
, b
= e
, e
= temp
;
4915 if (!(BEGV
<= b
&& e
<= ZV
))
4916 args_out_of_range (start
, end
);
4918 if (NILP (coding_system
))
4920 /* Decide the coding-system to encode the data with.
4921 See fileio.c:Fwrite-region */
4923 if (!NILP (Vcoding_system_for_write
))
4924 coding_system
= Vcoding_system_for_write
;
4927 bool force_raw_text
= 0;
4929 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4930 if (NILP (coding_system
)
4931 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4933 coding_system
= Qnil
;
4934 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4938 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4940 /* Check file-coding-system-alist. */
4941 Lisp_Object args
[4], val
;
4943 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4944 args
[3] = Fbuffer_file_name (object
);
4945 val
= Ffind_operation_coding_system (4, args
);
4946 if (CONSP (val
) && !NILP (XCDR (val
)))
4947 coding_system
= XCDR (val
);
4950 if (NILP (coding_system
)
4951 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4953 /* If we still have not decided a coding system, use the
4954 default value of buffer-file-coding-system. */
4955 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4959 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4960 /* Confirm that VAL can surely encode the current region. */
4961 coding_system
= call4 (Vselect_safe_coding_system_function
,
4962 make_number (b
), make_number (e
),
4963 coding_system
, Qnil
);
4966 coding_system
= Qraw_text
;
4969 if (NILP (Fcoding_system_p (coding_system
)))
4971 /* Invalid coding system. */
4973 if (!NILP (noerror
))
4974 coding_system
= Qraw_text
;
4976 xsignal1 (Qcoding_system_error
, coding_system
);
4980 object
= make_buffer_string (b
, e
, 0);
4981 set_buffer_internal (prev
);
4982 /* Discard the unwind protect for recovering the current
4986 if (STRING_MULTIBYTE (object
))
4987 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4989 end_byte
= SBYTES (object
);
4992 if (EQ (algorithm
, Qmd5
))
4994 digest_size
= MD5_DIGEST_SIZE
;
4995 hash_func
= md5_buffer
;
4997 else if (EQ (algorithm
, Qsha1
))
4999 digest_size
= SHA1_DIGEST_SIZE
;
5000 hash_func
= sha1_buffer
;
5002 else if (EQ (algorithm
, Qsha224
))
5004 digest_size
= SHA224_DIGEST_SIZE
;
5005 hash_func
= sha224_buffer
;
5007 else if (EQ (algorithm
, Qsha256
))
5009 digest_size
= SHA256_DIGEST_SIZE
;
5010 hash_func
= sha256_buffer
;
5012 else if (EQ (algorithm
, Qsha384
))
5014 digest_size
= SHA384_DIGEST_SIZE
;
5015 hash_func
= sha384_buffer
;
5017 else if (EQ (algorithm
, Qsha512
))
5019 digest_size
= SHA512_DIGEST_SIZE
;
5020 hash_func
= sha512_buffer
;
5023 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5025 /* allocate 2 x digest_size so that it can be re-used to hold the
5027 digest
= make_uninit_string (digest_size
* 2);
5029 hash_func (SSDATA (object
) + start_byte
,
5030 end_byte
- start_byte
,
5035 unsigned char *p
= SDATA (digest
);
5036 for (i
= digest_size
- 1; i
>= 0; i
--)
5038 static char const hexdigit
[16] = "0123456789abcdef";
5040 p
[2 * i
] = hexdigit
[p_i
>> 4];
5041 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5046 return make_unibyte_string (SSDATA (digest
), digest_size
);
5049 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5050 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5052 A message digest is a cryptographic checksum of a document, and the
5053 algorithm to calculate it is defined in RFC 1321.
5055 The two optional arguments START and END are character positions
5056 specifying for which part of OBJECT the message digest should be
5057 computed. If nil or omitted, the digest is computed for the whole
5060 The MD5 message digest is computed from the result of encoding the
5061 text in a coding system, not directly from the internal Emacs form of
5062 the text. The optional fourth argument CODING-SYSTEM specifies which
5063 coding system to encode the text with. It should be the same coding
5064 system that you used or will use when actually writing the text into a
5067 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5068 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5069 system would be chosen by default for writing this text into a file.
5071 If OBJECT is a string, the most preferred coding system (see the
5072 command `prefer-coding-system') is used.
5074 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5075 guesswork fails. Normally, an error is signaled in such case. */)
5076 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5078 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5081 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5082 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5083 ALGORITHM is a symbol specifying the hash to use:
5084 md5, sha1, sha224, sha256, sha384 or sha512.
5086 The two optional arguments START and END are positions specifying for
5087 which part of OBJECT to compute the hash. If nil or omitted, uses the
5090 If BINARY is non-nil, returns a string in binary form. */)
5091 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5093 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5099 DEFSYM (Qmd5
, "md5");
5100 DEFSYM (Qsha1
, "sha1");
5101 DEFSYM (Qsha224
, "sha224");
5102 DEFSYM (Qsha256
, "sha256");
5103 DEFSYM (Qsha384
, "sha384");
5104 DEFSYM (Qsha512
, "sha512");
5106 /* Hash table stuff. */
5107 DEFSYM (Qhash_table_p
, "hash-table-p");
5109 DEFSYM (Qeql
, "eql");
5110 DEFSYM (Qequal
, "equal");
5111 DEFSYM (QCtest
, ":test");
5112 DEFSYM (QCsize
, ":size");
5113 DEFSYM (QCrehash_size
, ":rehash-size");
5114 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5115 DEFSYM (QCweakness
, ":weakness");
5116 DEFSYM (Qkey
, "key");
5117 DEFSYM (Qvalue
, "value");
5118 DEFSYM (Qhash_table_test
, "hash-table-test");
5119 DEFSYM (Qkey_or_value
, "key-or-value");
5120 DEFSYM (Qkey_and_value
, "key-and-value");
5123 defsubr (&Smake_hash_table
);
5124 defsubr (&Scopy_hash_table
);
5125 defsubr (&Shash_table_count
);
5126 defsubr (&Shash_table_rehash_size
);
5127 defsubr (&Shash_table_rehash_threshold
);
5128 defsubr (&Shash_table_size
);
5129 defsubr (&Shash_table_test
);
5130 defsubr (&Shash_table_weakness
);
5131 defsubr (&Shash_table_p
);
5132 defsubr (&Sclrhash
);
5133 defsubr (&Sgethash
);
5134 defsubr (&Sputhash
);
5135 defsubr (&Sremhash
);
5136 defsubr (&Smaphash
);
5137 defsubr (&Sdefine_hash_table_test
);
5139 DEFSYM (Qstring_lessp
, "string-lessp");
5140 DEFSYM (Qstring_collate_lessp
, "string-collate-lessp");
5141 DEFSYM (Qstring_collate_equalp
, "string-collate-equalp");
5142 DEFSYM (Qprovide
, "provide");
5143 DEFSYM (Qrequire
, "require");
5144 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5145 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5146 DEFSYM (Qwidget_type
, "widget-type");
5148 staticpro (&string_char_byte_cache_string
);
5149 string_char_byte_cache_string
= Qnil
;
5151 require_nesting_list
= Qnil
;
5152 staticpro (&require_nesting_list
);
5154 Fset (Qyes_or_no_p_history
, Qnil
);
5156 DEFVAR_LISP ("features", Vfeatures
,
5157 doc
: /* A list of symbols which are the features of the executing Emacs.
5158 Used by `featurep' and `require', and altered by `provide'. */);
5159 Vfeatures
= list1 (intern_c_string ("emacs"));
5160 DEFSYM (Qsubfeatures
, "subfeatures");
5161 DEFSYM (Qfuncall
, "funcall");
5163 #ifdef HAVE_LANGINFO_CODESET
5164 DEFSYM (Qcodeset
, "codeset");
5165 DEFSYM (Qdays
, "days");
5166 DEFSYM (Qmonths
, "months");
5167 DEFSYM (Qpaper
, "paper");
5168 #endif /* HAVE_LANGINFO_CODESET */
5170 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5171 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5172 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5173 invoked by mouse clicks and mouse menu items.
5175 On some platforms, file selection dialogs are also enabled if this is
5179 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5180 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5181 This applies to commands from menus and tool bar buttons even when
5182 they are initiated from the keyboard. If `use-dialog-box' is nil,
5183 that disables the use of a file dialog, regardless of the value of
5185 use_file_dialog
= 1;
5187 defsubr (&Sidentity
);
5190 defsubr (&Ssafe_length
);
5191 defsubr (&Sstring_bytes
);
5192 defsubr (&Sstring_equal
);
5193 defsubr (&Scompare_strings
);
5194 defsubr (&Sstring_lessp
);
5195 defsubr (&Sstring_collate_lessp
);
5196 defsubr (&Sstring_collate_equalp
);
5199 defsubr (&Svconcat
);
5200 defsubr (&Scopy_sequence
);
5201 defsubr (&Sstring_make_multibyte
);
5202 defsubr (&Sstring_make_unibyte
);
5203 defsubr (&Sstring_as_multibyte
);
5204 defsubr (&Sstring_as_unibyte
);
5205 defsubr (&Sstring_to_multibyte
);
5206 defsubr (&Sstring_to_unibyte
);
5207 defsubr (&Scopy_alist
);
5208 defsubr (&Ssubstring
);
5209 defsubr (&Ssubstring_no_properties
);
5222 defsubr (&Snreverse
);
5223 defsubr (&Sreverse
);
5225 defsubr (&Splist_get
);
5227 defsubr (&Splist_put
);
5229 defsubr (&Slax_plist_get
);
5230 defsubr (&Slax_plist_put
);
5233 defsubr (&Sequal_including_properties
);
5234 defsubr (&Sfillarray
);
5235 defsubr (&Sclear_string
);
5239 defsubr (&Smapconcat
);
5240 defsubr (&Syes_or_no_p
);
5241 defsubr (&Sload_average
);
5242 defsubr (&Sfeaturep
);
5243 defsubr (&Srequire
);
5244 defsubr (&Sprovide
);
5245 defsubr (&Splist_member
);
5246 defsubr (&Swidget_put
);
5247 defsubr (&Swidget_get
);
5248 defsubr (&Swidget_apply
);
5249 defsubr (&Sbase64_encode_region
);
5250 defsubr (&Sbase64_decode_region
);
5251 defsubr (&Sbase64_encode_string
);
5252 defsubr (&Sbase64_decode_string
);
5254 defsubr (&Ssecure_hash
);
5255 defsubr (&Slocale_info
);
5257 hashtest_eq
.name
= Qeq
;
5258 hashtest_eq
.user_hash_function
= Qnil
;
5259 hashtest_eq
.user_cmp_function
= Qnil
;
5260 hashtest_eq
.cmpfn
= 0;
5261 hashtest_eq
.hashfn
= hashfn_eq
;
5263 hashtest_eql
.name
= Qeql
;
5264 hashtest_eql
.user_hash_function
= Qnil
;
5265 hashtest_eql
.user_cmp_function
= Qnil
;
5266 hashtest_eql
.cmpfn
= cmpfn_eql
;
5267 hashtest_eql
.hashfn
= hashfn_eql
;
5269 hashtest_equal
.name
= Qequal
;
5270 hashtest_equal
.user_hash_function
= Qnil
;
5271 hashtest_equal
.user_cmp_function
= Qnil
;
5272 hashtest_equal
.cmpfn
= cmpfn_equal
;
5273 hashtest_equal
.hashfn
= hashfn_equal
;