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/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
43 Lisp_Object Qstring_lessp
;
44 static Lisp_Object Qprovide
, Qrequire
;
45 static Lisp_Object Qyes_or_no_p_history
;
46 Lisp_Object Qcursor_in_echo_area
;
47 static Lisp_Object Qwidget_type
;
48 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
50 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
52 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
53 doc
: /* Return the argument unchanged. */)
59 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
60 doc
: /* Return a pseudo-random number.
61 All integers representable in Lisp, i.e. between `most-negative-fixnum'
62 and `most-positive-fixnum', inclusive, are equally likely.
64 With positive integer LIMIT, return random number in interval [0,LIMIT).
65 With argument t, set the random number seed from the current time and pid.
66 With a string argument, set the seed based on the string's contents.
67 Other values of LIMIT are ignored.
69 See Info node `(elisp)Random Numbers' for more details. */)
76 else if (STRINGP (limit
))
77 seed_random (SSDATA (limit
), SBYTES (limit
));
80 if (INTEGERP (limit
) && 0 < XINT (limit
))
83 /* Return the remainder, except reject the rare case where
84 get_random returns a number so close to INTMASK that the
85 remainder isn't random. */
86 EMACS_INT remainder
= val
% XINT (limit
);
87 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
88 return make_number (remainder
);
91 return make_number (val
);
94 /* Heuristic on how many iterations of a tight loop can be safely done
95 before it's time to do a QUIT. This must be a power of 2. */
96 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
98 /* Random data-structure functions. */
101 CHECK_LIST_END (Lisp_Object x
, Lisp_Object y
)
103 CHECK_TYPE (NILP (x
), Qlistp
, y
);
106 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
107 doc
: /* Return the length of vector, list or string SEQUENCE.
108 A byte-code function object is also allowed.
109 If the string contains multibyte characters, this is not necessarily
110 the number of bytes in the string; it is the number of characters.
111 To get the number of bytes, use `string-bytes'. */)
112 (register Lisp_Object sequence
)
114 register Lisp_Object val
;
116 if (STRINGP (sequence
))
117 XSETFASTINT (val
, SCHARS (sequence
));
118 else if (VECTORP (sequence
))
119 XSETFASTINT (val
, ASIZE (sequence
));
120 else if (CHAR_TABLE_P (sequence
))
121 XSETFASTINT (val
, MAX_CHAR
);
122 else if (BOOL_VECTOR_P (sequence
))
123 XSETFASTINT (val
, bool_vector_size (sequence
));
124 else if (COMPILEDP (sequence
))
125 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
126 else if (CONSP (sequence
))
133 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
135 if (MOST_POSITIVE_FIXNUM
< i
)
136 error ("List too long");
139 sequence
= XCDR (sequence
);
141 while (CONSP (sequence
));
143 CHECK_LIST_END (sequence
, sequence
);
145 val
= make_number (i
);
147 else if (NILP (sequence
))
148 XSETFASTINT (val
, 0);
150 wrong_type_argument (Qsequencep
, sequence
);
155 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
156 doc
: /* Return the length of a list, but avoid error or infinite loop.
157 This function never gets an error. If LIST is not really a list,
158 it returns 0. If LIST is circular, it returns a finite value
159 which is at least the number of distinct elements. */)
162 Lisp_Object tail
, halftail
;
167 return make_number (0);
169 /* halftail is used to detect circular lists. */
170 for (tail
= halftail
= list
; ; )
175 if (EQ (tail
, halftail
))
178 if ((lolen
& 1) == 0)
180 halftail
= XCDR (halftail
);
181 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
185 hilen
+= UINTMAX_MAX
+ 1.0;
190 /* If the length does not fit into a fixnum, return a float.
191 On all known practical machines this returns an upper bound on
193 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
196 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
197 doc
: /* Return the number of bytes in STRING.
198 If STRING is multibyte, this may be greater than the length of STRING. */)
201 CHECK_STRING (string
);
202 return make_number (SBYTES (string
));
205 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
206 doc
: /* Return t if two strings have identical contents.
207 Case is significant, but text properties are ignored.
208 Symbols are also allowed; their print names are used instead. */)
209 (register Lisp_Object s1
, Lisp_Object s2
)
212 s1
= SYMBOL_NAME (s1
);
214 s2
= SYMBOL_NAME (s2
);
218 if (SCHARS (s1
) != SCHARS (s2
)
219 || SBYTES (s1
) != SBYTES (s2
)
220 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
225 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
226 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
227 The arguments START1, END1, START2, and END2, if non-nil, are
228 positions specifying which parts of STR1 or STR2 to compare. In
229 string STR1, compare the part between START1 (inclusive) and END1
230 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
231 the string; if END1 is nil, it defaults to the length of the string.
232 Likewise, in string STR2, compare the part between START2 and END2.
233 Like in `substring', negative values are counted from the end.
235 The strings are compared by the numeric values of their characters.
236 For instance, STR1 is "less than" STR2 if its first differing
237 character has a smaller numeric value. If IGNORE-CASE is non-nil,
238 characters are converted to lower-case before comparing them. Unibyte
239 strings are converted to multibyte for comparison.
241 The value is t if the strings (or specified portions) match.
242 If string STR1 is less, the value is a negative number N;
243 - 1 - N is the number of characters that match at the beginning.
244 If string STR1 is greater, the value is a positive number N;
245 N - 1 is the number of characters that match at the beginning. */)
246 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
247 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
249 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
254 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
255 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
260 i1_byte
= string_char_to_byte (str1
, i1
);
261 i2_byte
= string_char_to_byte (str2
, i2
);
263 while (i1
< to1
&& i2
< to2
)
265 /* When we find a mismatch, we must compare the
266 characters, not just the bytes. */
269 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
270 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
275 if (! NILP (ignore_case
))
277 c1
= XINT (Fupcase (make_number (c1
)));
278 c2
= XINT (Fupcase (make_number (c2
)));
284 /* Note that I1 has already been incremented
285 past the character that we are comparing;
286 hence we don't add or subtract 1 here. */
288 return make_number (- i1
+ from1
);
290 return make_number (i1
- from1
);
294 return make_number (i1
- from1
+ 1);
296 return make_number (- i1
+ from1
- 1);
301 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
302 doc
: /* Return t if first arg string is less than second in lexicographic order.
304 Symbols are also allowed; their print names are used instead. */)
305 (register Lisp_Object s1
, Lisp_Object s2
)
307 register ptrdiff_t end
;
308 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
311 s1
= SYMBOL_NAME (s1
);
313 s2
= SYMBOL_NAME (s2
);
317 i1
= i1_byte
= i2
= i2_byte
= 0;
320 if (end
> SCHARS (s2
))
325 /* When we find a mismatch, we must compare the
326 characters, not just the bytes. */
329 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
330 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
333 return c1
< c2
? Qt
: Qnil
;
335 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
338 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
339 enum Lisp_Type target_type
, bool last_special
);
343 concat2 (Lisp_Object s1
, Lisp_Object s2
)
348 return concat (2, args
, Lisp_String
, 0);
353 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
359 return concat (3, args
, Lisp_String
, 0);
362 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
363 doc
: /* Concatenate all the arguments and make the result a list.
364 The result is a list whose elements are the elements of all the arguments.
365 Each argument may be a list, vector or string.
366 The last argument is not copied, just used as the tail of the new list.
367 usage: (append &rest SEQUENCES) */)
368 (ptrdiff_t nargs
, Lisp_Object
*args
)
370 return concat (nargs
, args
, Lisp_Cons
, 1);
373 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
374 doc
: /* Concatenate all the arguments and make the result a string.
375 The result is a string whose elements are the elements of all the arguments.
376 Each argument may be a string or a list or vector of characters (integers).
377 usage: (concat &rest SEQUENCES) */)
378 (ptrdiff_t nargs
, Lisp_Object
*args
)
380 return concat (nargs
, args
, Lisp_String
, 0);
383 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
384 doc
: /* Concatenate all the arguments and make the result a vector.
385 The result is a vector whose elements are the elements of all the arguments.
386 Each argument may be a list, vector or string.
387 usage: (vconcat &rest SEQUENCES) */)
388 (ptrdiff_t nargs
, Lisp_Object
*args
)
390 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
394 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
395 doc
: /* Return a copy of a list, vector, string or char-table.
396 The elements of a list or vector are not copied; they are shared
397 with the original. */)
400 if (NILP (arg
)) return arg
;
402 if (CHAR_TABLE_P (arg
))
404 return copy_char_table (arg
);
407 if (BOOL_VECTOR_P (arg
))
409 EMACS_INT nbits
= bool_vector_size (arg
);
410 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
411 Lisp_Object val
= make_uninit_bool_vector (nbits
);
412 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
416 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
417 wrong_type_argument (Qsequencep
, arg
);
419 return concat (1, &arg
, XTYPE (arg
), 0);
422 /* This structure holds information of an argument of `concat' that is
423 a string and has text properties to be copied. */
426 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
427 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
428 ptrdiff_t to
; /* refer to VAL (the target string) */
432 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
433 enum Lisp_Type target_type
, bool last_special
)
439 ptrdiff_t toindex_byte
= 0;
440 EMACS_INT result_len
;
441 EMACS_INT result_len_byte
;
443 Lisp_Object last_tail
;
446 /* When we make a multibyte string, we can't copy text properties
447 while concatenating each string because the length of resulting
448 string can't be decided until we finish the whole concatenation.
449 So, we record strings that have text properties to be copied
450 here, and copy the text properties after the concatenation. */
451 struct textprop_rec
*textprops
= NULL
;
452 /* Number of elements in textprops. */
453 ptrdiff_t num_textprops
= 0;
458 /* In append, the last arg isn't treated like the others */
459 if (last_special
&& nargs
> 0)
462 last_tail
= args
[nargs
];
467 /* Check each argument. */
468 for (argnum
= 0; argnum
< nargs
; argnum
++)
471 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
472 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
473 wrong_type_argument (Qsequencep
, this);
476 /* Compute total length in chars of arguments in RESULT_LEN.
477 If desired output is a string, also compute length in bytes
478 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
479 whether the result should be a multibyte string. */
483 for (argnum
= 0; argnum
< nargs
; argnum
++)
487 len
= XFASTINT (Flength (this));
488 if (target_type
== Lisp_String
)
490 /* We must count the number of bytes needed in the string
491 as well as the number of characters. */
495 ptrdiff_t this_len_byte
;
497 if (VECTORP (this) || COMPILEDP (this))
498 for (i
= 0; i
< len
; i
++)
501 CHECK_CHARACTER (ch
);
503 this_len_byte
= CHAR_BYTES (c
);
504 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
506 result_len_byte
+= this_len_byte
;
507 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
510 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
511 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
512 else if (CONSP (this))
513 for (; CONSP (this); this = XCDR (this))
516 CHECK_CHARACTER (ch
);
518 this_len_byte
= CHAR_BYTES (c
);
519 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
521 result_len_byte
+= this_len_byte
;
522 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
525 else if (STRINGP (this))
527 if (STRING_MULTIBYTE (this))
530 this_len_byte
= SBYTES (this);
533 this_len_byte
= count_size_as_multibyte (SDATA (this),
535 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
537 result_len_byte
+= this_len_byte
;
542 if (MOST_POSITIVE_FIXNUM
< result_len
)
543 memory_full (SIZE_MAX
);
546 if (! some_multibyte
)
547 result_len_byte
= result_len
;
549 /* Create the output object. */
550 if (target_type
== Lisp_Cons
)
551 val
= Fmake_list (make_number (result_len
), Qnil
);
552 else if (target_type
== Lisp_Vectorlike
)
553 val
= Fmake_vector (make_number (result_len
), Qnil
);
554 else if (some_multibyte
)
555 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
557 val
= make_uninit_string (result_len
);
559 /* In `append', if all but last arg are nil, return last arg. */
560 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
563 /* Copy the contents of the args into the result. */
565 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
567 toindex
= 0, toindex_byte
= 0;
571 SAFE_NALLOCA (textprops
, 1, nargs
);
573 for (argnum
= 0; argnum
< nargs
; argnum
++)
576 ptrdiff_t thisleni
= 0;
577 register ptrdiff_t thisindex
= 0;
578 register ptrdiff_t thisindex_byte
= 0;
582 thislen
= Flength (this), thisleni
= XINT (thislen
);
584 /* Between strings of the same kind, copy fast. */
585 if (STRINGP (this) && STRINGP (val
)
586 && STRING_MULTIBYTE (this) == some_multibyte
)
588 ptrdiff_t thislen_byte
= SBYTES (this);
590 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
591 if (string_intervals (this))
593 textprops
[num_textprops
].argnum
= argnum
;
594 textprops
[num_textprops
].from
= 0;
595 textprops
[num_textprops
++].to
= toindex
;
597 toindex_byte
+= thislen_byte
;
600 /* Copy a single-byte string to a multibyte string. */
601 else if (STRINGP (this) && STRINGP (val
))
603 if (string_intervals (this))
605 textprops
[num_textprops
].argnum
= argnum
;
606 textprops
[num_textprops
].from
= 0;
607 textprops
[num_textprops
++].to
= toindex
;
609 toindex_byte
+= copy_text (SDATA (this),
610 SDATA (val
) + toindex_byte
,
611 SCHARS (this), 0, 1);
615 /* Copy element by element. */
618 register Lisp_Object elt
;
620 /* Fetch next element of `this' arg into `elt', or break if
621 `this' is exhausted. */
622 if (NILP (this)) break;
624 elt
= XCAR (this), this = XCDR (this);
625 else if (thisindex
>= thisleni
)
627 else if (STRINGP (this))
630 if (STRING_MULTIBYTE (this))
631 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
636 c
= SREF (this, thisindex
); thisindex
++;
637 if (some_multibyte
&& !ASCII_CHAR_P (c
))
638 c
= BYTE8_TO_CHAR (c
);
640 XSETFASTINT (elt
, c
);
642 else if (BOOL_VECTOR_P (this))
644 elt
= bool_vector_ref (this, thisindex
);
649 elt
= AREF (this, thisindex
);
653 /* Store this element into the result. */
660 else if (VECTORP (val
))
662 ASET (val
, toindex
, elt
);
668 CHECK_CHARACTER (elt
);
671 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
673 SSET (val
, toindex_byte
++, c
);
679 XSETCDR (prev
, last_tail
);
681 if (num_textprops
> 0)
684 ptrdiff_t last_to_end
= -1;
686 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
688 this = args
[textprops
[argnum
].argnum
];
689 props
= text_property_list (this,
691 make_number (SCHARS (this)),
693 /* If successive arguments have properties, be sure that the
694 value of `composition' property be the copy. */
695 if (last_to_end
== textprops
[argnum
].to
)
696 make_composition_value_copy (props
);
697 add_text_properties_from_list (val
, props
,
698 make_number (textprops
[argnum
].to
));
699 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
707 static Lisp_Object string_char_byte_cache_string
;
708 static ptrdiff_t string_char_byte_cache_charpos
;
709 static ptrdiff_t string_char_byte_cache_bytepos
;
712 clear_string_char_byte_cache (void)
714 string_char_byte_cache_string
= Qnil
;
717 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
720 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
723 ptrdiff_t best_below
, best_below_byte
;
724 ptrdiff_t best_above
, best_above_byte
;
726 best_below
= best_below_byte
= 0;
727 best_above
= SCHARS (string
);
728 best_above_byte
= SBYTES (string
);
729 if (best_above
== best_above_byte
)
732 if (EQ (string
, string_char_byte_cache_string
))
734 if (string_char_byte_cache_charpos
< char_index
)
736 best_below
= string_char_byte_cache_charpos
;
737 best_below_byte
= string_char_byte_cache_bytepos
;
741 best_above
= string_char_byte_cache_charpos
;
742 best_above_byte
= string_char_byte_cache_bytepos
;
746 if (char_index
- best_below
< best_above
- char_index
)
748 unsigned char *p
= SDATA (string
) + best_below_byte
;
750 while (best_below
< char_index
)
752 p
+= BYTES_BY_CHAR_HEAD (*p
);
755 i_byte
= p
- SDATA (string
);
759 unsigned char *p
= SDATA (string
) + best_above_byte
;
761 while (best_above
> char_index
)
764 while (!CHAR_HEAD_P (*p
)) p
--;
767 i_byte
= p
- SDATA (string
);
770 string_char_byte_cache_bytepos
= i_byte
;
771 string_char_byte_cache_charpos
= char_index
;
772 string_char_byte_cache_string
= string
;
777 /* Return the character index corresponding to BYTE_INDEX in STRING. */
780 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
783 ptrdiff_t best_below
, best_below_byte
;
784 ptrdiff_t best_above
, best_above_byte
;
786 best_below
= best_below_byte
= 0;
787 best_above
= SCHARS (string
);
788 best_above_byte
= SBYTES (string
);
789 if (best_above
== best_above_byte
)
792 if (EQ (string
, string_char_byte_cache_string
))
794 if (string_char_byte_cache_bytepos
< byte_index
)
796 best_below
= string_char_byte_cache_charpos
;
797 best_below_byte
= string_char_byte_cache_bytepos
;
801 best_above
= string_char_byte_cache_charpos
;
802 best_above_byte
= string_char_byte_cache_bytepos
;
806 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
808 unsigned char *p
= SDATA (string
) + best_below_byte
;
809 unsigned char *pend
= SDATA (string
) + byte_index
;
813 p
+= BYTES_BY_CHAR_HEAD (*p
);
817 i_byte
= p
- SDATA (string
);
821 unsigned char *p
= SDATA (string
) + best_above_byte
;
822 unsigned char *pbeg
= SDATA (string
) + byte_index
;
827 while (!CHAR_HEAD_P (*p
)) p
--;
831 i_byte
= p
- SDATA (string
);
834 string_char_byte_cache_bytepos
= i_byte
;
835 string_char_byte_cache_charpos
= i
;
836 string_char_byte_cache_string
= string
;
841 /* Convert STRING to a multibyte string. */
844 string_make_multibyte (Lisp_Object string
)
851 if (STRING_MULTIBYTE (string
))
854 nbytes
= count_size_as_multibyte (SDATA (string
),
856 /* If all the chars are ASCII, they won't need any more bytes
857 once converted. In that case, we can return STRING itself. */
858 if (nbytes
== SBYTES (string
))
861 buf
= SAFE_ALLOCA (nbytes
);
862 copy_text (SDATA (string
), buf
, SBYTES (string
),
865 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
872 /* Convert STRING (if unibyte) to a multibyte string without changing
873 the number of characters. Characters 0200 trough 0237 are
874 converted to eight-bit characters. */
877 string_to_multibyte (Lisp_Object string
)
884 if (STRING_MULTIBYTE (string
))
887 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
888 /* If all the chars are ASCII, they won't need any more bytes once
890 if (nbytes
== SBYTES (string
))
891 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
893 buf
= SAFE_ALLOCA (nbytes
);
894 memcpy (buf
, SDATA (string
), SBYTES (string
));
895 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
897 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
904 /* Convert STRING to a single-byte string. */
907 string_make_unibyte (Lisp_Object string
)
914 if (! STRING_MULTIBYTE (string
))
917 nchars
= SCHARS (string
);
919 buf
= SAFE_ALLOCA (nchars
);
920 copy_text (SDATA (string
), buf
, SBYTES (string
),
923 ret
= make_unibyte_string ((char *) buf
, nchars
);
929 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
931 doc
: /* Return the multibyte equivalent of STRING.
932 If STRING is unibyte and contains non-ASCII characters, the function
933 `unibyte-char-to-multibyte' is used to convert each unibyte character
934 to a multibyte character. In this case, the returned string is a
935 newly created string with no text properties. If STRING is multibyte
936 or entirely ASCII, it is returned unchanged. In particular, when
937 STRING is unibyte and entirely ASCII, the returned string is unibyte.
938 \(When the characters are all ASCII, Emacs primitives will treat the
939 string the same way whether it is unibyte or multibyte.) */)
942 CHECK_STRING (string
);
944 return string_make_multibyte (string
);
947 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
949 doc
: /* Return the unibyte equivalent of STRING.
950 Multibyte character codes are converted to unibyte according to
951 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
952 If the lookup in the translation table fails, this function takes just
953 the low 8 bits of each character. */)
956 CHECK_STRING (string
);
958 return string_make_unibyte (string
);
961 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
963 doc
: /* Return a unibyte string with the same individual bytes as STRING.
964 If STRING is unibyte, the result is STRING itself.
965 Otherwise it is a newly created string, with no text properties.
966 If STRING is multibyte and contains a character of charset
967 `eight-bit', it is converted to the corresponding single byte. */)
970 CHECK_STRING (string
);
972 if (STRING_MULTIBYTE (string
))
974 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
975 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
977 string
= make_unibyte_string ((char *) str
, bytes
);
983 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
985 doc
: /* Return a multibyte string with the same individual bytes as STRING.
986 If STRING is multibyte, the result is STRING itself.
987 Otherwise it is a newly created string, with no text properties.
989 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
990 part of a correct utf-8 sequence), it is converted to the corresponding
991 multibyte character of charset `eight-bit'.
992 See also `string-to-multibyte'.
994 Beware, this often doesn't really do what you think it does.
995 It is similar to (decode-coding-string STRING 'utf-8-emacs).
996 If you're not sure, whether to use `string-as-multibyte' or
997 `string-to-multibyte', use `string-to-multibyte'. */)
1000 CHECK_STRING (string
);
1002 if (! STRING_MULTIBYTE (string
))
1004 Lisp_Object new_string
;
1005 ptrdiff_t nchars
, nbytes
;
1007 parse_str_as_multibyte (SDATA (string
),
1010 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1011 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1012 if (nbytes
!= SBYTES (string
))
1013 str_as_multibyte (SDATA (new_string
), nbytes
,
1014 SBYTES (string
), NULL
);
1015 string
= new_string
;
1016 set_string_intervals (string
, NULL
);
1021 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1023 doc
: /* Return a multibyte string with the same individual chars as STRING.
1024 If STRING is multibyte, the result is STRING itself.
1025 Otherwise it is a newly created string, with no text properties.
1027 If STRING is unibyte and contains an 8-bit byte, it is converted to
1028 the corresponding multibyte character of charset `eight-bit'.
1030 This differs from `string-as-multibyte' by converting each byte of a correct
1031 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1032 correct sequence. */)
1033 (Lisp_Object string
)
1035 CHECK_STRING (string
);
1037 return string_to_multibyte (string
);
1040 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1042 doc
: /* Return a unibyte string with the same individual chars as STRING.
1043 If STRING is unibyte, the result is STRING itself.
1044 Otherwise it is a newly created string, with no text properties,
1045 where each `eight-bit' character is converted to the corresponding byte.
1046 If STRING contains a non-ASCII, non-`eight-bit' character,
1047 an error is signaled. */)
1048 (Lisp_Object string
)
1050 CHECK_STRING (string
);
1052 if (STRING_MULTIBYTE (string
))
1054 ptrdiff_t chars
= SCHARS (string
);
1055 unsigned char *str
= xmalloc_atomic (chars
);
1056 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1058 if (converted
< chars
)
1059 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1060 string
= make_unibyte_string ((char *) str
, chars
);
1067 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1068 doc
: /* Return a copy of ALIST.
1069 This is an alist which represents the same mapping from objects to objects,
1070 but does not share the alist structure with ALIST.
1071 The objects mapped (cars and cdrs of elements of the alist)
1072 are shared, however.
1073 Elements of ALIST that are not conses are also shared. */)
1076 register Lisp_Object tem
;
1081 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1082 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1084 register Lisp_Object car
;
1088 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1093 /* Check that ARRAY can have a valid subarray [FROM..TO),
1094 given that its size is SIZE.
1095 If FROM is nil, use 0; if TO is nil, use SIZE.
1096 Count negative values backwards from the end.
1097 Set *IFROM and *ITO to the two indexes used. */
1100 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1101 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1105 if (INTEGERP (from
))
1111 else if (NILP (from
))
1114 wrong_type_argument (Qintegerp
, from
);
1125 wrong_type_argument (Qintegerp
, to
);
1127 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1128 args_out_of_range_3 (array
, from
, to
);
1134 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1135 doc
: /* Return a new string whose contents are a substring of STRING.
1136 The returned string consists of the characters between index FROM
1137 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1138 zero-indexed: 0 means the first character of STRING. Negative values
1139 are counted from the end of STRING. If TO is nil, the substring runs
1140 to the end of STRING.
1142 The STRING argument may also be a vector. In that case, the return
1143 value is a new vector that contains the elements between index FROM
1144 \(inclusive) and index TO (exclusive) of that vector argument.
1146 With one argument, just copy STRING (with properties, if any). */)
1147 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1150 ptrdiff_t size
, ifrom
, ito
;
1152 if (STRINGP (string
))
1153 size
= SCHARS (string
);
1154 else if (VECTORP (string
))
1155 size
= ASIZE (string
);
1157 wrong_type_argument (Qarrayp
, string
);
1159 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1161 if (STRINGP (string
))
1164 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1166 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1167 res
= make_specified_string (SSDATA (string
) + from_byte
,
1168 ito
- ifrom
, to_byte
- from_byte
,
1169 STRING_MULTIBYTE (string
));
1170 copy_text_properties (make_number (ifrom
), make_number (ito
),
1171 string
, make_number (0), res
, Qnil
);
1174 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1180 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1181 doc
: /* Return a substring of STRING, without text properties.
1182 It starts at index FROM and ends before TO.
1183 TO may be nil or omitted; then the substring runs to the end of STRING.
1184 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1185 If FROM or TO is negative, it counts from the end.
1187 With one argument, just copy STRING without its properties. */)
1188 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1190 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1192 CHECK_STRING (string
);
1194 size
= SCHARS (string
);
1195 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1197 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1199 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1200 return make_specified_string (SSDATA (string
) + from_byte
,
1201 to_char
- from_char
, to_byte
- from_byte
,
1202 STRING_MULTIBYTE (string
));
1205 /* Extract a substring of STRING, giving start and end positions
1206 both in characters and in bytes. */
1209 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1210 ptrdiff_t to
, ptrdiff_t to_byte
)
1215 CHECK_VECTOR_OR_STRING (string
);
1217 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1219 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1220 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1222 if (STRINGP (string
))
1224 res
= make_specified_string (SSDATA (string
) + from_byte
,
1225 to
- from
, to_byte
- from_byte
,
1226 STRING_MULTIBYTE (string
));
1227 copy_text_properties (make_number (from
), make_number (to
),
1228 string
, make_number (0), res
, Qnil
);
1231 res
= Fvector (to
- from
, aref_addr (string
, from
));
1236 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1237 doc
: /* Take cdr N times on LIST, return the result. */)
1238 (Lisp_Object n
, Lisp_Object list
)
1243 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1246 CHECK_LIST_CONS (list
, list
);
1252 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1253 doc
: /* Return the Nth element of LIST.
1254 N counts from zero. If LIST is not that long, nil is returned. */)
1255 (Lisp_Object n
, Lisp_Object list
)
1257 return Fcar (Fnthcdr (n
, list
));
1260 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1261 doc
: /* Return element of SEQUENCE at index N. */)
1262 (register Lisp_Object sequence
, Lisp_Object n
)
1265 if (CONSP (sequence
) || NILP (sequence
))
1266 return Fcar (Fnthcdr (n
, sequence
));
1268 /* Faref signals a "not array" error, so check here. */
1269 CHECK_ARRAY (sequence
, Qsequencep
);
1270 return Faref (sequence
, n
);
1273 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1274 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1275 The value is actually the tail of LIST whose car is ELT. */)
1276 (register Lisp_Object elt
, Lisp_Object list
)
1278 register Lisp_Object tail
;
1279 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1281 register Lisp_Object tem
;
1282 CHECK_LIST_CONS (tail
, list
);
1284 if (! NILP (Fequal (elt
, tem
)))
1291 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1292 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1293 The value is actually the tail of LIST whose car is ELT. */)
1294 (register Lisp_Object elt
, Lisp_Object list
)
1298 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1302 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1306 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1317 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1318 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1319 The value is actually the tail of LIST whose car is ELT. */)
1320 (register Lisp_Object elt
, Lisp_Object list
)
1322 register Lisp_Object tail
;
1324 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1326 register Lisp_Object tem
;
1327 CHECK_LIST_CONS (tail
, list
);
1329 if (!NILP (Feql (elt
, tem
)))
1336 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1337 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1338 The value is actually the first element of LIST whose car is KEY.
1339 Elements of LIST that are not conses are ignored. */)
1340 (Lisp_Object key
, Lisp_Object list
)
1345 || (CONSP (XCAR (list
))
1346 && EQ (XCAR (XCAR (list
)), key
)))
1351 || (CONSP (XCAR (list
))
1352 && EQ (XCAR (XCAR (list
)), key
)))
1357 || (CONSP (XCAR (list
))
1358 && EQ (XCAR (XCAR (list
)), key
)))
1368 /* Like Fassq but never report an error and do not allow quits.
1369 Use only on lists known never to be circular. */
1372 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1375 && (!CONSP (XCAR (list
))
1376 || !EQ (XCAR (XCAR (list
)), key
)))
1379 return CAR_SAFE (list
);
1382 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1383 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1384 The value is actually the first element of LIST whose car equals KEY. */)
1385 (Lisp_Object key
, Lisp_Object list
)
1392 || (CONSP (XCAR (list
))
1393 && (car
= XCAR (XCAR (list
)),
1394 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1399 || (CONSP (XCAR (list
))
1400 && (car
= XCAR (XCAR (list
)),
1401 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1406 || (CONSP (XCAR (list
))
1407 && (car
= XCAR (XCAR (list
)),
1408 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1418 /* Like Fassoc but never report an error and do not allow quits.
1419 Use only on lists known never to be circular. */
1422 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1425 && (!CONSP (XCAR (list
))
1426 || (!EQ (XCAR (XCAR (list
)), key
)
1427 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1430 return CONSP (list
) ? XCAR (list
) : Qnil
;
1433 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1434 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1435 The value is actually the first element of LIST whose cdr is KEY. */)
1436 (register Lisp_Object key
, Lisp_Object list
)
1441 || (CONSP (XCAR (list
))
1442 && EQ (XCDR (XCAR (list
)), key
)))
1447 || (CONSP (XCAR (list
))
1448 && EQ (XCDR (XCAR (list
)), key
)))
1453 || (CONSP (XCAR (list
))
1454 && EQ (XCDR (XCAR (list
)), key
)))
1464 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1465 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1466 The value is actually the first element of LIST whose cdr equals KEY. */)
1467 (Lisp_Object key
, Lisp_Object list
)
1474 || (CONSP (XCAR (list
))
1475 && (cdr
= XCDR (XCAR (list
)),
1476 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1481 || (CONSP (XCAR (list
))
1482 && (cdr
= XCDR (XCAR (list
)),
1483 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1488 || (CONSP (XCAR (list
))
1489 && (cdr
= XCDR (XCAR (list
)),
1490 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1500 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1501 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1502 More precisely, this function skips any members `eq' to ELT at the
1503 front of LIST, then removes members `eq' to ELT from the remaining
1504 sublist by modifying its list structure, then returns the resulting
1507 Write `(setq foo (delq element foo))' to be sure of correctly changing
1508 the value of a list `foo'. */)
1509 (register Lisp_Object elt
, Lisp_Object list
)
1511 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1514 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1516 Lisp_Object tem
= XCAR (tail
);
1522 Fsetcdr (prev
, XCDR (tail
));
1530 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1531 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1532 SEQ must be a sequence (i.e. a list, a vector, or a string).
1533 The return value is a sequence of the same type.
1535 If SEQ is a list, this behaves like `delq', except that it compares
1536 with `equal' instead of `eq'. In particular, it may remove elements
1537 by altering the list structure.
1539 If SEQ is not a list, deletion is never performed destructively;
1540 instead this function creates and returns a new vector or string.
1542 Write `(setq foo (delete element foo))' to be sure of correctly
1543 changing the value of a sequence `foo'. */)
1544 (Lisp_Object elt
, Lisp_Object seq
)
1550 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1551 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1554 if (n
!= ASIZE (seq
))
1556 struct Lisp_Vector
*p
= allocate_vector (n
);
1558 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1559 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1560 p
->contents
[n
++] = AREF (seq
, i
);
1562 XSETVECTOR (seq
, p
);
1565 else if (STRINGP (seq
))
1567 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1570 for (i
= nchars
= nbytes
= ibyte
= 0;
1572 ++i
, ibyte
+= cbytes
)
1574 if (STRING_MULTIBYTE (seq
))
1576 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1577 cbytes
= CHAR_BYTES (c
);
1585 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1592 if (nchars
!= SCHARS (seq
))
1596 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1597 if (!STRING_MULTIBYTE (seq
))
1598 STRING_SET_UNIBYTE (tem
);
1600 for (i
= nchars
= nbytes
= ibyte
= 0;
1602 ++i
, ibyte
+= cbytes
)
1604 if (STRING_MULTIBYTE (seq
))
1606 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1607 cbytes
= CHAR_BYTES (c
);
1615 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1617 unsigned char *from
= SDATA (seq
) + ibyte
;
1618 unsigned char *to
= SDATA (tem
) + nbytes
;
1624 for (n
= cbytes
; n
--; )
1634 Lisp_Object tail
, prev
;
1636 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1638 CHECK_LIST_CONS (tail
, seq
);
1640 if (!NILP (Fequal (elt
, XCAR (tail
))))
1645 Fsetcdr (prev
, XCDR (tail
));
1656 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1657 doc
: /* Reverse order of items in a list, vector or string SEQ.
1658 If SEQ is a list, it should be nil-terminated.
1659 This function may destructively modify SEQ to produce the value. */)
1664 else if (STRINGP (seq
))
1665 return Freverse (seq
);
1666 else if (CONSP (seq
))
1668 Lisp_Object prev
, tail
, next
;
1670 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1673 CHECK_LIST_CONS (tail
, tail
);
1675 Fsetcdr (tail
, prev
);
1680 else if (VECTORP (seq
))
1682 ptrdiff_t i
, size
= ASIZE (seq
);
1684 for (i
= 0; i
< size
/ 2; i
++)
1686 Lisp_Object tem
= AREF (seq
, i
);
1687 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1688 ASET (seq
, size
- i
- 1, tem
);
1691 else if (BOOL_VECTOR_P (seq
))
1693 ptrdiff_t i
, size
= bool_vector_size (seq
);
1695 for (i
= 0; i
< size
/ 2; i
++)
1697 bool tem
= bool_vector_bitref (seq
, i
);
1698 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1699 bool_vector_set (seq
, size
- i
- 1, tem
);
1703 wrong_type_argument (Qarrayp
, seq
);
1707 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1708 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1709 See also the function `nreverse', which is used more often. */)
1716 else if (CONSP (seq
))
1718 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1721 new = Fcons (XCAR (seq
), new);
1723 CHECK_LIST_END (seq
, seq
);
1725 else if (VECTORP (seq
))
1727 ptrdiff_t i
, size
= ASIZE (seq
);
1729 new = make_uninit_vector (size
);
1730 for (i
= 0; i
< size
; i
++)
1731 ASET (new, i
, AREF (seq
, size
- i
- 1));
1733 else if (BOOL_VECTOR_P (seq
))
1736 EMACS_INT nbits
= bool_vector_size (seq
);
1738 new = make_uninit_bool_vector (nbits
);
1739 for (i
= 0; i
< nbits
; i
++)
1740 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1742 else if (STRINGP (seq
))
1744 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1750 new = make_uninit_string (size
);
1751 for (i
= 0; i
< size
; i
++)
1752 SSET (new, i
, SREF (seq
, size
- i
- 1));
1756 unsigned char *p
, *q
;
1758 new = make_uninit_multibyte_string (size
, bytes
);
1759 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1760 while (q
> SDATA (new))
1764 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1766 CHAR_STRING (ch
, q
);
1771 wrong_type_argument (Qsequencep
, seq
);
1775 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1776 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1777 Returns the sorted list. LIST is modified by side effects.
1778 PREDICATE is called with two elements of LIST, and should return non-nil
1779 if the first element should sort before the second. */)
1780 (Lisp_Object list
, Lisp_Object predicate
)
1782 Lisp_Object front
, back
;
1783 register Lisp_Object len
, tem
;
1784 struct gcpro gcpro1
, gcpro2
;
1788 len
= Flength (list
);
1789 length
= XINT (len
);
1793 XSETINT (len
, (length
/ 2) - 1);
1794 tem
= Fnthcdr (len
, list
);
1796 Fsetcdr (tem
, Qnil
);
1798 GCPRO2 (front
, back
);
1799 front
= Fsort (front
, predicate
);
1800 back
= Fsort (back
, predicate
);
1802 return merge (front
, back
, predicate
);
1806 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1809 register Lisp_Object tail
;
1811 register Lisp_Object l1
, l2
;
1812 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1819 /* It is sufficient to protect org_l1 and org_l2.
1820 When l1 and l2 are updated, we copy the new values
1821 back into the org_ vars. */
1822 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1842 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1858 Fsetcdr (tail
, tem
);
1864 /* This does not check for quits. That is safe since it must terminate. */
1866 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1867 doc
: /* Extract a value from a property list.
1868 PLIST is a property list, which is a list of the form
1869 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1870 corresponding to the given PROP, or nil if PROP is not one of the
1871 properties on the list. This function never signals an error. */)
1872 (Lisp_Object plist
, Lisp_Object prop
)
1874 Lisp_Object tail
, halftail
;
1876 /* halftail is used to detect circular lists. */
1877 tail
= halftail
= plist
;
1878 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1880 if (EQ (prop
, XCAR (tail
)))
1881 return XCAR (XCDR (tail
));
1883 tail
= XCDR (XCDR (tail
));
1884 halftail
= XCDR (halftail
);
1885 if (EQ (tail
, halftail
))
1892 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1893 doc
: /* Return the value of SYMBOL's PROPNAME property.
1894 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1895 (Lisp_Object symbol
, Lisp_Object propname
)
1897 CHECK_SYMBOL (symbol
);
1898 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1901 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1902 doc
: /* Change value in PLIST of PROP to VAL.
1903 PLIST is a property list, which is a list of the form
1904 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1905 If PROP is already a property on the list, its value is set to VAL,
1906 otherwise the new PROP VAL pair is added. The new plist is returned;
1907 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1908 The PLIST is modified by side effects. */)
1909 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1911 register Lisp_Object tail
, prev
;
1912 Lisp_Object newcell
;
1914 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1915 tail
= XCDR (XCDR (tail
)))
1917 if (EQ (prop
, XCAR (tail
)))
1919 Fsetcar (XCDR (tail
), val
);
1926 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1930 Fsetcdr (XCDR (prev
), newcell
);
1934 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1935 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1936 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1937 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1939 CHECK_SYMBOL (symbol
);
1941 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1945 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1946 doc
: /* Extract a value from a property list, comparing with `equal'.
1947 PLIST is a property list, which is a list of the form
1948 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1949 corresponding to the given PROP, or nil if PROP is not
1950 one of the properties on the list. */)
1951 (Lisp_Object plist
, Lisp_Object prop
)
1956 CONSP (tail
) && CONSP (XCDR (tail
));
1957 tail
= XCDR (XCDR (tail
)))
1959 if (! NILP (Fequal (prop
, XCAR (tail
))))
1960 return XCAR (XCDR (tail
));
1965 CHECK_LIST_END (tail
, prop
);
1970 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1971 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1972 PLIST is a property list, which is a list of the form
1973 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1974 If PROP is already a property on the list, its value is set to VAL,
1975 otherwise the new PROP VAL pair is added. The new plist is returned;
1976 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1977 The PLIST is modified by side effects. */)
1978 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1980 register Lisp_Object tail
, prev
;
1981 Lisp_Object newcell
;
1983 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1984 tail
= XCDR (XCDR (tail
)))
1986 if (! NILP (Fequal (prop
, XCAR (tail
))))
1988 Fsetcar (XCDR (tail
), val
);
1995 newcell
= list2 (prop
, val
);
1999 Fsetcdr (XCDR (prev
), newcell
);
2003 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2004 doc
: /* Return t if the two args are the same Lisp object.
2005 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2006 (Lisp_Object obj1
, Lisp_Object obj2
)
2008 return scm_is_true (scm_eqv_p (obj1
, obj2
)) ? Qt
: Qnil
;
2011 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2012 doc
: /* Return t if two Lisp objects have similar structure and contents.
2013 They must have the same data type.
2014 Conses are compared by comparing the cars and the cdrs.
2015 Vectors and strings are compared element by element.
2016 Numbers are compared by value, but integers cannot equal floats.
2017 (Use `=' if you want integers and floats to be able to be equal.)
2018 Symbols must match exactly. */)
2019 (register Lisp_Object o1
, Lisp_Object o2
)
2021 return scm_is_true (scm_equal_p (o1
, o2
)) ? Qt
: Qnil
;
2024 SCM compare_text_properties
= SCM_BOOL_F
;
2026 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2027 doc
: /* Return t if two Lisp objects have similar structure and contents.
2028 This is like `equal' except that it compares the text properties
2029 of strings. (`equal' ignores text properties.) */)
2030 (register Lisp_Object o1
, Lisp_Object o2
)
2034 scm_dynwind_begin (0);
2035 scm_dynwind_fluid (compare_text_properties
, SCM_BOOL_T
);
2036 tem
= Fequal (o1
, o2
);
2042 misc_equal_p (SCM o1
, SCM o2
)
2044 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2048 if (NILP (Fequal (OVERLAY_START (o1
), OVERLAY_START (o2
)))
2049 || NILP (Fequal (OVERLAY_END (o1
), OVERLAY_END (o2
))))
2051 return scm_equal_p (XOVERLAY (o1
)->plist
, XOVERLAY (o2
)->plist
);
2055 struct Lisp_Marker
*m1
= XMARKER (o1
), *m2
= XMARKER (o2
);
2056 return scm_from_bool (m1
->buffer
== m2
->buffer
2058 || m1
->bytepos
== m2
->bytepos
));
2064 vectorlike_equal_p (SCM o1
, SCM o2
)
2067 ptrdiff_t size
= ASIZE (o1
);
2068 /* Pseudovectors have the type encoded in the size field, so this
2069 test actually checks that the objects have the same type as well
2070 as the same size. */
2071 if (ASIZE (o2
) != size
)
2073 /* Boolvectors are compared much like strings. */
2074 if (BOOL_VECTOR_P (o1
))
2076 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2078 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2079 ((XBOOL_VECTOR (o1
)->size
2080 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2081 / BOOL_VECTOR_BITS_PER_CHAR
)))
2085 if (WINDOW_CONFIGURATIONP (o1
))
2086 return scm_from_bool (compare_window_configurations (o1
, o2
, 0));
2088 /* Aside from them, only true vectors, char-tables, compiled
2089 functions, and fonts (font-spec, font-entity, font-object) are
2090 sensible to compare, so eliminate the others now. */
2091 if (size
& PSEUDOVECTOR_FLAG
)
2093 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2096 size
&= PSEUDOVECTOR_SIZE_MASK
;
2098 for (i
= 0; i
< size
; i
++)
2103 if (scm_is_false (scm_equal_p (v1
, v2
)))
2110 string_equal_p (SCM o1
, SCM o2
)
2112 if (SCHARS (o1
) != SCHARS (o2
))
2114 if (SBYTES (o1
) != SBYTES (o2
))
2116 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2118 if (scm_is_true (scm_fluid_ref (compare_text_properties
))
2119 && !compare_string_intervals (o1
, o2
))
2125 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2126 doc
: /* Store each element of ARRAY with ITEM.
2127 ARRAY is a vector, string, char-table, or bool-vector. */)
2128 (Lisp_Object array
, Lisp_Object item
)
2130 register ptrdiff_t size
, idx
;
2132 if (VECTORP (array
))
2133 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2134 ASET (array
, idx
, item
);
2135 else if (CHAR_TABLE_P (array
))
2139 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2140 set_char_table_contents (array
, i
, item
);
2141 set_char_table_defalt (array
, item
);
2143 else if (STRINGP (array
))
2145 register unsigned char *p
= SDATA (array
);
2147 CHECK_CHARACTER (item
);
2148 charval
= XFASTINT (item
);
2149 size
= SCHARS (array
);
2150 if (STRING_MULTIBYTE (array
))
2152 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2153 int len
= CHAR_STRING (charval
, str
);
2154 ptrdiff_t size_byte
= SBYTES (array
);
2156 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2157 || SCHARS (array
) * len
!= size_byte
)
2158 error ("Attempt to change byte length of a string");
2159 for (idx
= 0; idx
< size_byte
; idx
++)
2160 *p
++ = str
[idx
% len
];
2163 for (idx
= 0; idx
< size
; idx
++)
2166 else if (BOOL_VECTOR_P (array
))
2167 return bool_vector_fill (array
, item
);
2169 wrong_type_argument (Qarrayp
, array
);
2173 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2175 doc
: /* Clear the contents of STRING.
2176 This makes STRING unibyte and may change its length. */)
2177 (Lisp_Object string
)
2180 CHECK_STRING (string
);
2181 len
= SBYTES (string
);
2182 memset (SDATA (string
), 0, len
);
2183 STRING_SET_CHARS (string
, len
);
2184 STRING_SET_UNIBYTE (string
);
2190 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2192 Lisp_Object args
[2];
2195 return Fnconc (2, args
);
2198 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2199 doc
: /* Concatenate any number of lists by altering them.
2200 Only the last argument is not altered, and need not be a list.
2201 usage: (nconc &rest LISTS) */)
2202 (ptrdiff_t nargs
, Lisp_Object
*args
)
2205 register Lisp_Object tail
, tem
, val
;
2209 for (argnum
= 0; argnum
< nargs
; argnum
++)
2212 if (NILP (tem
)) continue;
2217 if (argnum
+ 1 == nargs
) break;
2219 CHECK_LIST_CONS (tem
, tem
);
2228 tem
= args
[argnum
+ 1];
2229 Fsetcdr (tail
, tem
);
2231 args
[argnum
+ 1] = tail
;
2237 /* This is the guts of all mapping functions.
2238 Apply FN to each element of SEQ, one by one,
2239 storing the results into elements of VALS, a C vector of Lisp_Objects.
2240 LENI is the length of VALS, which should also be the length of SEQ. */
2243 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2245 register Lisp_Object tail
;
2247 register EMACS_INT i
;
2248 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2252 /* Don't let vals contain any garbage when GC happens. */
2253 for (i
= 0; i
< leni
; i
++)
2256 GCPRO3 (dummy
, fn
, seq
);
2258 gcpro1
.nvars
= leni
;
2262 /* We need not explicitly protect `tail' because it is used only on lists, and
2263 1) lists are not relocated and 2) the list is marked via `seq' so will not
2266 if (VECTORP (seq
) || COMPILEDP (seq
))
2268 for (i
= 0; i
< leni
; i
++)
2270 dummy
= call1 (fn
, AREF (seq
, i
));
2275 else if (BOOL_VECTOR_P (seq
))
2277 for (i
= 0; i
< leni
; i
++)
2279 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2284 else if (STRINGP (seq
))
2288 for (i
= 0, i_byte
= 0; i
< leni
;)
2291 ptrdiff_t i_before
= i
;
2293 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2294 XSETFASTINT (dummy
, c
);
2295 dummy
= call1 (fn
, dummy
);
2297 vals
[i_before
] = dummy
;
2300 else /* Must be a list, since Flength did not get an error */
2303 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2305 dummy
= call1 (fn
, XCAR (tail
));
2315 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2316 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2317 In between each pair of results, stick in SEPARATOR. Thus, " " as
2318 SEPARATOR results in spaces between the values returned by FUNCTION.
2319 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2320 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2323 register EMACS_INT leni
;
2326 register Lisp_Object
*args
;
2327 struct gcpro gcpro1
;
2331 len
= Flength (sequence
);
2332 if (CHAR_TABLE_P (sequence
))
2333 wrong_type_argument (Qlistp
, sequence
);
2335 nargs
= leni
+ leni
- 1;
2336 if (nargs
< 0) return empty_unibyte_string
;
2338 SAFE_ALLOCA_LISP (args
, nargs
);
2341 mapcar1 (leni
, args
, function
, sequence
);
2344 for (i
= leni
- 1; i
> 0; i
--)
2345 args
[i
+ i
] = args
[i
];
2347 for (i
= 1; i
< nargs
; i
+= 2)
2348 args
[i
] = separator
;
2350 ret
= Fconcat (nargs
, args
);
2356 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2357 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2358 The result is a list just as long as SEQUENCE.
2359 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2360 (Lisp_Object function
, Lisp_Object sequence
)
2362 register Lisp_Object len
;
2363 register EMACS_INT leni
;
2364 register Lisp_Object
*args
;
2368 len
= Flength (sequence
);
2369 if (CHAR_TABLE_P (sequence
))
2370 wrong_type_argument (Qlistp
, sequence
);
2371 leni
= XFASTINT (len
);
2373 SAFE_ALLOCA_LISP (args
, leni
);
2375 mapcar1 (leni
, args
, function
, sequence
);
2377 ret
= Flist (leni
, args
);
2383 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2384 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2385 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2386 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2387 (Lisp_Object function
, Lisp_Object sequence
)
2389 register EMACS_INT leni
;
2391 leni
= XFASTINT (Flength (sequence
));
2392 if (CHAR_TABLE_P (sequence
))
2393 wrong_type_argument (Qlistp
, sequence
);
2394 mapcar1 (leni
, 0, function
, sequence
);
2399 /* This is how C code calls `yes-or-no-p' and allows the user
2402 Anything that calls this function must protect from GC! */
2405 do_yes_or_no_p (Lisp_Object prompt
)
2407 return call1 (intern ("yes-or-no-p"), prompt
);
2410 /* Anything that calls this function must protect from GC! */
2412 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2413 doc
: /* Ask user a yes-or-no question.
2414 Return t if answer is yes, and nil if the answer is no.
2415 PROMPT is the string to display to ask the question. It should end in
2416 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2418 The user must confirm the answer with RET, and can edit it until it
2421 If dialog boxes are supported, a dialog box will be used
2422 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2423 (Lisp_Object prompt
)
2425 register Lisp_Object ans
;
2426 Lisp_Object args
[2];
2427 struct gcpro gcpro1
;
2429 CHECK_STRING (prompt
);
2431 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2434 Lisp_Object pane
, menu
, obj
;
2435 redisplay_preserve_echo_area (4);
2436 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2437 Fcons (build_string ("No"), Qnil
));
2439 menu
= Fcons (prompt
, pane
);
2440 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2446 args
[1] = build_string ("(yes or no) ");
2447 prompt
= Fconcat (2, args
);
2453 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2454 Qyes_or_no_p_history
, Qnil
,
2456 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2461 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2469 message1 ("Please answer yes or no.");
2470 Fsleep_for (make_number (2), Qnil
);
2474 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2475 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2477 Each of the three load averages is multiplied by 100, then converted
2480 When USE-FLOATS is non-nil, floats will be used instead of integers.
2481 These floats are not multiplied by 100.
2483 If the 5-minute or 15-minute load averages are not available, return a
2484 shortened list, containing only those averages which are available.
2486 An error is thrown if the load average can't be obtained. In some
2487 cases making it work would require Emacs being installed setuid or
2488 setgid so that it can read kernel information, and that usually isn't
2490 (Lisp_Object use_floats
)
2493 int loads
= getloadavg (load_ave
, 3);
2494 Lisp_Object ret
= Qnil
;
2497 error ("load-average not implemented for this operating system");
2501 Lisp_Object load
= (NILP (use_floats
)
2502 ? make_number (100.0 * load_ave
[loads
])
2503 : make_float (load_ave
[loads
]));
2504 ret
= Fcons (load
, ret
);
2510 static Lisp_Object Qsubfeatures
;
2512 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2513 doc
: /* Return t if FEATURE is present in this Emacs.
2515 Use this to conditionalize execution of lisp code based on the
2516 presence or absence of Emacs or environment extensions.
2517 Use `provide' to declare that a feature is available. This function
2518 looks at the value of the variable `features'. The optional argument
2519 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2520 (Lisp_Object feature
, Lisp_Object subfeature
)
2522 register Lisp_Object tem
;
2523 CHECK_SYMBOL (feature
);
2524 tem
= Fmemq (feature
, Vfeatures
);
2525 if (!NILP (tem
) && !NILP (subfeature
))
2526 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2527 return (NILP (tem
)) ? Qnil
: Qt
;
2530 static Lisp_Object Qfuncall
;
2532 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2533 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2534 The optional argument SUBFEATURES should be a list of symbols listing
2535 particular subfeatures supported in this version of FEATURE. */)
2536 (Lisp_Object feature
, Lisp_Object subfeatures
)
2538 register Lisp_Object tem
;
2539 CHECK_SYMBOL (feature
);
2540 CHECK_LIST (subfeatures
);
2541 if (!NILP (Vautoload_queue
))
2542 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2544 tem
= Fmemq (feature
, Vfeatures
);
2546 Vfeatures
= Fcons (feature
, Vfeatures
);
2547 if (!NILP (subfeatures
))
2548 Fput (feature
, Qsubfeatures
, subfeatures
);
2549 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2551 /* Run any load-hooks for this file. */
2552 tem
= Fassq (feature
, Vafter_load_alist
);
2554 Fmapc (Qfuncall
, XCDR (tem
));
2559 /* `require' and its subroutines. */
2561 /* List of features currently being require'd, innermost first. */
2563 static Lisp_Object require_nesting_list
;
2566 require_unwind (Lisp_Object old_value
)
2568 require_nesting_list
= old_value
;
2571 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2572 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2573 If FEATURE is not a member of the list `features', then the feature
2574 is not loaded; so load the file FILENAME.
2575 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2576 and `load' will try to load this name appended with the suffix `.elc' or
2577 `.el', in that order. The name without appended suffix will not be used.
2578 See `get-load-suffixes' for the complete list of suffixes.
2579 If the optional third argument NOERROR is non-nil,
2580 then return nil if the file is not found instead of signaling an error.
2581 Normally the return value is FEATURE.
2582 The normal messages at start and end of loading FILENAME are suppressed. */)
2583 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2586 struct gcpro gcpro1
, gcpro2
;
2587 bool from_file
= load_in_progress
;
2589 CHECK_SYMBOL (feature
);
2591 /* Record the presence of `require' in this file
2592 even if the feature specified is already loaded.
2593 But not more than once in any file,
2594 and not when we aren't loading or reading from a file. */
2596 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2597 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2602 tem
= Fcons (Qrequire
, feature
);
2603 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2604 LOADHIST_ATTACH (tem
);
2606 tem
= Fmemq (feature
, Vfeatures
);
2610 ptrdiff_t count
= SPECPDL_INDEX ();
2613 /* This is to make sure that loadup.el gives a clear picture
2614 of what files are preloaded and when. */
2615 if (! NILP (Vpurify_flag
))
2616 error ("(require %s) while preparing to dump",
2617 SDATA (SYMBOL_NAME (feature
)));
2619 /* A certain amount of recursive `require' is legitimate,
2620 but if we require the same feature recursively 3 times,
2622 tem
= require_nesting_list
;
2623 while (! NILP (tem
))
2625 if (! NILP (Fequal (feature
, XCAR (tem
))))
2630 error ("Recursive `require' for feature `%s'",
2631 SDATA (SYMBOL_NAME (feature
)));
2633 /* Update the list for any nested `require's that occur. */
2634 record_unwind_protect (require_unwind
, require_nesting_list
);
2635 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2637 /* Value saved here is to be restored into Vautoload_queue */
2638 record_unwind_protect (un_autoload
, Vautoload_queue
);
2639 Vautoload_queue
= Qt
;
2641 /* Load the file. */
2642 GCPRO2 (feature
, filename
);
2643 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2644 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2647 /* If load failed entirely, return nil. */
2649 return unbind_to (count
, Qnil
);
2651 tem
= Fmemq (feature
, Vfeatures
);
2653 error ("Required feature `%s' was not provided",
2654 SDATA (SYMBOL_NAME (feature
)));
2656 /* Once loading finishes, don't undo it. */
2657 Vautoload_queue
= Qt
;
2658 feature
= unbind_to (count
, feature
);
2664 /* Primitives for work of the "widget" library.
2665 In an ideal world, this section would not have been necessary.
2666 However, lisp function calls being as slow as they are, it turns
2667 out that some functions in the widget library (wid-edit.el) are the
2668 bottleneck of Widget operation. Here is their translation to C,
2669 for the sole reason of efficiency. */
2671 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2672 doc
: /* Return non-nil if PLIST has the property PROP.
2673 PLIST is a property list, which is a list of the form
2674 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2675 Unlike `plist-get', this allows you to distinguish between a missing
2676 property and a property with the value nil.
2677 The value is actually the tail of PLIST whose car is PROP. */)
2678 (Lisp_Object plist
, Lisp_Object prop
)
2680 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2683 plist
= XCDR (plist
);
2684 plist
= CDR (plist
);
2689 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2690 doc
: /* In WIDGET, set PROPERTY to VALUE.
2691 The value can later be retrieved with `widget-get'. */)
2692 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2694 CHECK_CONS (widget
);
2695 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2699 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2700 doc
: /* In WIDGET, get the value of PROPERTY.
2701 The value could either be specified when the widget was created, or
2702 later with `widget-put'. */)
2703 (Lisp_Object widget
, Lisp_Object property
)
2711 CHECK_CONS (widget
);
2712 tmp
= Fplist_member (XCDR (widget
), property
);
2718 tmp
= XCAR (widget
);
2721 widget
= Fget (tmp
, Qwidget_type
);
2725 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2726 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2727 ARGS are passed as extra arguments to the function.
2728 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2729 (ptrdiff_t nargs
, Lisp_Object
*args
)
2731 /* This function can GC. */
2732 Lisp_Object newargs
[3];
2733 struct gcpro gcpro1
, gcpro2
;
2736 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2737 newargs
[1] = args
[0];
2738 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2739 GCPRO2 (newargs
[0], newargs
[2]);
2740 result
= Fapply (3, newargs
);
2745 #ifdef HAVE_LANGINFO_CODESET
2746 #include <langinfo.h>
2749 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2750 doc
: /* Access locale data ITEM for the current C locale, if available.
2751 ITEM should be one of the following:
2753 `codeset', returning the character set as a string (locale item CODESET);
2755 `days', returning a 7-element vector of day names (locale items DAY_n);
2757 `months', returning a 12-element vector of month names (locale items MON_n);
2759 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2760 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2762 If the system can't provide such information through a call to
2763 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2765 See also Info node `(libc)Locales'.
2767 The data read from the system are decoded using `locale-coding-system'. */)
2771 #ifdef HAVE_LANGINFO_CODESET
2773 if (EQ (item
, Qcodeset
))
2775 str
= nl_langinfo (CODESET
);
2776 return build_string (str
);
2779 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2781 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2782 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2784 struct gcpro gcpro1
;
2786 synchronize_system_time_locale ();
2787 for (i
= 0; i
< 7; i
++)
2789 str
= nl_langinfo (days
[i
]);
2790 val
= build_unibyte_string (str
);
2791 /* Fixme: Is this coding system necessarily right, even if
2792 it is consistent with CODESET? If not, what to do? */
2793 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2801 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2803 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2804 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2805 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2807 struct gcpro gcpro1
;
2809 synchronize_system_time_locale ();
2810 for (i
= 0; i
< 12; i
++)
2812 str
= nl_langinfo (months
[i
]);
2813 val
= build_unibyte_string (str
);
2814 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2821 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2822 but is in the locale files. This could be used by ps-print. */
2824 else if (EQ (item
, Qpaper
))
2825 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2826 #endif /* PAPER_WIDTH */
2827 #endif /* HAVE_LANGINFO_CODESET*/
2831 /* base64 encode/decode functions (RFC 2045).
2832 Based on code from GNU recode. */
2834 #define MIME_LINE_LENGTH 76
2836 #define IS_ASCII(Character) \
2838 #define IS_BASE64(Character) \
2839 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2840 #define IS_BASE64_IGNORABLE(Character) \
2841 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2842 || (Character) == '\f' || (Character) == '\r')
2844 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2845 character or return retval if there are no characters left to
2847 #define READ_QUADRUPLET_BYTE(retval) \
2852 if (nchars_return) \
2853 *nchars_return = nchars; \
2858 while (IS_BASE64_IGNORABLE (c))
2860 /* Table of characters coding the 64 values. */
2861 static const char base64_value_to_char
[64] =
2863 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2864 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2865 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2866 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2867 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2868 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2869 '8', '9', '+', '/' /* 60-63 */
2872 /* Table of base64 values for first 128 characters. */
2873 static const short base64_char_to_value
[128] =
2875 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2876 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2877 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2878 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2879 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2880 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2881 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2882 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2883 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2884 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2885 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2886 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2887 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2890 /* The following diagram shows the logical steps by which three octets
2891 get transformed into four base64 characters.
2893 .--------. .--------. .--------.
2894 |aaaaaabb| |bbbbcccc| |ccdddddd|
2895 `--------' `--------' `--------'
2897 .--------+--------+--------+--------.
2898 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2899 `--------+--------+--------+--------'
2901 .--------+--------+--------+--------.
2902 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2903 `--------+--------+--------+--------'
2905 The octets are divided into 6 bit chunks, which are then encoded into
2906 base64 characters. */
2909 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2910 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2913 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2915 doc
: /* Base64-encode the region between BEG and END.
2916 Return the length of the encoded text.
2917 Optional third argument NO-LINE-BREAK means do not break long lines
2918 into shorter lines. */)
2919 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2922 ptrdiff_t allength
, length
;
2923 ptrdiff_t ibeg
, iend
, encoded_length
;
2924 ptrdiff_t old_pos
= PT
;
2927 validate_region (&beg
, &end
);
2929 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2930 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2931 move_gap_both (XFASTINT (beg
), ibeg
);
2933 /* We need to allocate enough room for encoding the text.
2934 We need 33 1/3% more space, plus a newline every 76
2935 characters, and then we round up. */
2936 length
= iend
- ibeg
;
2937 allength
= length
+ length
/3 + 1;
2938 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2940 encoded
= SAFE_ALLOCA (allength
);
2941 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2942 encoded
, length
, NILP (no_line_break
),
2943 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2944 if (encoded_length
> allength
)
2947 if (encoded_length
< 0)
2949 /* The encoding wasn't possible. */
2951 error ("Multibyte character in data for base64 encoding");
2954 /* Now we have encoded the region, so we insert the new contents
2955 and delete the old. (Insert first in order to preserve markers.) */
2956 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2957 insert (encoded
, encoded_length
);
2959 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2961 /* If point was outside of the region, restore it exactly; else just
2962 move to the beginning of the region. */
2963 if (old_pos
>= XFASTINT (end
))
2964 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2965 else if (old_pos
> XFASTINT (beg
))
2966 old_pos
= XFASTINT (beg
);
2969 /* We return the length of the encoded text. */
2970 return make_number (encoded_length
);
2973 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2975 doc
: /* Base64-encode STRING and return the result.
2976 Optional second argument NO-LINE-BREAK means do not break long lines
2977 into shorter lines. */)
2978 (Lisp_Object string
, Lisp_Object no_line_break
)
2980 ptrdiff_t allength
, length
, encoded_length
;
2982 Lisp_Object encoded_string
;
2985 CHECK_STRING (string
);
2987 /* We need to allocate enough room for encoding the text.
2988 We need 33 1/3% more space, plus a newline every 76
2989 characters, and then we round up. */
2990 length
= SBYTES (string
);
2991 allength
= length
+ length
/3 + 1;
2992 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2994 /* We need to allocate enough room for decoding the text. */
2995 encoded
= SAFE_ALLOCA (allength
);
2997 encoded_length
= base64_encode_1 (SSDATA (string
),
2998 encoded
, length
, NILP (no_line_break
),
2999 STRING_MULTIBYTE (string
));
3000 if (encoded_length
> allength
)
3003 if (encoded_length
< 0)
3005 /* The encoding wasn't possible. */
3007 error ("Multibyte character in data for base64 encoding");
3010 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3013 return encoded_string
;
3017 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3018 bool line_break
, bool multibyte
)
3031 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3032 if (CHAR_BYTE8_P (c
))
3033 c
= CHAR_TO_BYTE8 (c
);
3041 /* Wrap line every 76 characters. */
3045 if (counter
< MIME_LINE_LENGTH
/ 4)
3054 /* Process first byte of a triplet. */
3056 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3057 value
= (0x03 & c
) << 4;
3059 /* Process second byte of a triplet. */
3063 *e
++ = base64_value_to_char
[value
];
3071 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3072 if (CHAR_BYTE8_P (c
))
3073 c
= CHAR_TO_BYTE8 (c
);
3081 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3082 value
= (0x0f & c
) << 2;
3084 /* Process third byte of a triplet. */
3088 *e
++ = base64_value_to_char
[value
];
3095 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3096 if (CHAR_BYTE8_P (c
))
3097 c
= CHAR_TO_BYTE8 (c
);
3105 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3106 *e
++ = base64_value_to_char
[0x3f & c
];
3113 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3115 doc
: /* Base64-decode the region between BEG and END.
3116 Return the length of the decoded text.
3117 If the region can't be decoded, signal an error and don't modify the buffer. */)
3118 (Lisp_Object beg
, Lisp_Object end
)
3120 ptrdiff_t ibeg
, iend
, length
, allength
;
3122 ptrdiff_t old_pos
= PT
;
3123 ptrdiff_t decoded_length
;
3124 ptrdiff_t inserted_chars
;
3125 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3128 validate_region (&beg
, &end
);
3130 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3131 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3133 length
= iend
- ibeg
;
3135 /* We need to allocate enough room for decoding the text. If we are
3136 working on a multibyte buffer, each decoded code may occupy at
3138 allength
= multibyte
? length
* 2 : length
;
3139 decoded
= SAFE_ALLOCA (allength
);
3141 move_gap_both (XFASTINT (beg
), ibeg
);
3142 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3144 multibyte
, &inserted_chars
);
3145 if (decoded_length
> allength
)
3148 if (decoded_length
< 0)
3150 /* The decoding wasn't possible. */
3152 error ("Invalid base64 data");
3155 /* Now we have decoded the region, so we insert the new contents
3156 and delete the old. (Insert first in order to preserve markers.) */
3157 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3158 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3161 /* Delete the original text. */
3162 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3163 iend
+ decoded_length
, 1);
3165 /* If point was outside of the region, restore it exactly; else just
3166 move to the beginning of the region. */
3167 if (old_pos
>= XFASTINT (end
))
3168 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3169 else if (old_pos
> XFASTINT (beg
))
3170 old_pos
= XFASTINT (beg
);
3171 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3173 return make_number (inserted_chars
);
3176 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3178 doc
: /* Base64-decode STRING and return the result. */)
3179 (Lisp_Object string
)
3182 ptrdiff_t length
, decoded_length
;
3183 Lisp_Object decoded_string
;
3186 CHECK_STRING (string
);
3188 length
= SBYTES (string
);
3189 /* We need to allocate enough room for decoding the text. */
3190 decoded
= SAFE_ALLOCA (length
);
3192 /* The decoded result should be unibyte. */
3193 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3195 if (decoded_length
> length
)
3197 else if (decoded_length
>= 0)
3198 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3200 decoded_string
= Qnil
;
3203 if (!STRINGP (decoded_string
))
3204 error ("Invalid base64 data");
3206 return decoded_string
;
3209 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3210 MULTIBYTE, the decoded result should be in multibyte
3211 form. If NCHARS_RETURN is not NULL, store the number of produced
3212 characters in *NCHARS_RETURN. */
3215 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3216 bool multibyte
, ptrdiff_t *nchars_return
)
3218 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3221 unsigned long value
;
3222 ptrdiff_t nchars
= 0;
3226 /* Process first byte of a quadruplet. */
3228 READ_QUADRUPLET_BYTE (e
-to
);
3232 value
= base64_char_to_value
[c
] << 18;
3234 /* Process second byte of a quadruplet. */
3236 READ_QUADRUPLET_BYTE (-1);
3240 value
|= base64_char_to_value
[c
] << 12;
3242 c
= (unsigned char) (value
>> 16);
3243 if (multibyte
&& c
>= 128)
3244 e
+= BYTE8_STRING (c
, e
);
3249 /* Process third byte of a quadruplet. */
3251 READ_QUADRUPLET_BYTE (-1);
3255 READ_QUADRUPLET_BYTE (-1);
3264 value
|= base64_char_to_value
[c
] << 6;
3266 c
= (unsigned char) (0xff & value
>> 8);
3267 if (multibyte
&& c
>= 128)
3268 e
+= BYTE8_STRING (c
, e
);
3273 /* Process fourth byte of a quadruplet. */
3275 READ_QUADRUPLET_BYTE (-1);
3282 value
|= base64_char_to_value
[c
];
3284 c
= (unsigned char) (0xff & value
);
3285 if (multibyte
&& c
>= 128)
3286 e
+= BYTE8_STRING (c
, e
);
3295 /***********************************************************************
3297 ***** Hash Tables *****
3299 ***********************************************************************/
3301 /* Implemented by gerd@gnu.org. This hash table implementation was
3302 inspired by CMUCL hash tables. */
3306 1. For small tables, association lists are probably faster than
3307 hash tables because they have lower overhead.
3309 For uses of hash tables where the O(1) behavior of table
3310 operations is not a requirement, it might therefore be a good idea
3311 not to hash. Instead, we could just do a linear search in the
3312 key_and_value vector of the hash table. This could be done
3313 if a `:linear-search t' argument is given to make-hash-table. */
3315 /* Various symbols. */
3317 static Lisp_Object Qhash_table_p
;
3318 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3319 Lisp_Object Qeq
, Qequal
;
3320 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3321 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3324 /***********************************************************************
3326 ***********************************************************************/
3329 CHECK_HASH_TABLE (Lisp_Object x
)
3331 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3335 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3337 h
->key_and_value
= key_and_value
;
3340 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3345 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3347 gc_aset (h
->next
, idx
, val
);
3350 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3355 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3357 gc_aset (h
->hash
, idx
, val
);
3360 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3365 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3367 gc_aset (h
->index
, idx
, val
);
3370 /* If OBJ is a Lisp hash table, return a pointer to its struct
3371 Lisp_Hash_Table. Otherwise, signal an error. */
3373 static struct Lisp_Hash_Table
*
3374 check_hash_table (Lisp_Object obj
)
3376 CHECK_HASH_TABLE (obj
);
3377 return XHASH_TABLE (obj
);
3381 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3382 number. A number is "almost" a prime number if it is not divisible
3383 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3386 next_almost_prime (EMACS_INT n
)
3388 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3389 for (n
|= 1; ; n
+= 2)
3390 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3395 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3396 which USED[I] is non-zero. If found at index I in ARGS, set
3397 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3398 0. This function is used to extract a keyword/argument pair from
3399 a DEFUN parameter list. */
3402 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3406 for (i
= 1; i
< nargs
; i
++)
3407 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3418 /* Return a Lisp vector which has the same contents as VEC but has
3419 at least INCR_MIN more entries, where INCR_MIN is positive.
3420 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3421 than NITEMS_MAX. Entries in the resulting
3422 vector that are not copied from VEC are set to nil. */
3425 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3427 struct Lisp_Vector
*v
;
3428 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3429 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3430 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3431 ? nitems_max
: C_language_max
);
3432 eassert (VECTORP (vec
));
3433 eassert (0 < incr_min
&& -1 <= nitems_max
);
3434 old_size
= ASIZE (vec
);
3435 incr_max
= n_max
- old_size
;
3436 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3437 if (incr_max
< incr
)
3438 memory_full (SIZE_MAX
);
3439 new_size
= old_size
+ incr
;
3440 v
= allocate_vector (new_size
);
3441 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3442 for (i
= old_size
; i
< new_size
; ++i
)
3443 v
->contents
[i
] = Qnil
;
3444 XSETVECTOR (vec
, v
);
3449 /***********************************************************************
3451 ***********************************************************************/
3453 static struct hash_table_test hashtest_eq
;
3454 struct hash_table_test hashtest_eql
, hashtest_equal
;
3456 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3457 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3458 KEY2 are the same. */
3461 cmpfn_eql (struct hash_table_test
*ht
,
3465 return (FLOATP (key1
)
3467 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3471 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3472 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3473 KEY2 are the same. */
3476 cmpfn_equal (struct hash_table_test
*ht
,
3480 return !NILP (Fequal (key1
, key2
));
3484 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3485 HASH2 in hash table H using H->user_cmp_function. Value is true
3486 if KEY1 and KEY2 are the same. */
3489 cmpfn_user_defined (struct hash_table_test
*ht
,
3493 Lisp_Object args
[3];
3495 args
[0] = ht
->user_cmp_function
;
3498 return !NILP (Ffuncall (3, args
));
3502 /* Value is a hash code for KEY for use in hash table H which uses
3503 `eq' to compare keys. The hash code returned is guaranteed to fit
3504 in a Lisp integer. */
3507 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3509 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3513 /* Value is a hash code for KEY for use in hash table H which uses
3514 `eql' to compare keys. The hash code returned is guaranteed to fit
3515 in a Lisp integer. */
3518 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3522 hash
= sxhash (key
, 0);
3524 hash
= XHASH (key
) ^ XTYPE (key
);
3528 /* Value is a hash code for KEY for use in hash table H which uses
3529 `equal' to compare keys. The hash code returned is guaranteed to fit
3530 in a Lisp integer. */
3533 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3535 EMACS_UINT hash
= sxhash (key
, 0);
3539 /* Value is a hash code for KEY for use in hash table H which uses as
3540 user-defined function to compare keys. The hash code returned is
3541 guaranteed to fit in a Lisp integer. */
3544 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3546 Lisp_Object args
[2], hash
;
3548 args
[0] = ht
->user_hash_function
;
3550 hash
= Ffuncall (2, args
);
3551 return hashfn_eq (ht
, hash
);
3554 /* An upper bound on the size of a hash table index. It must fit in
3555 ptrdiff_t and be a valid Emacs fixnum. */
3556 #define INDEX_SIZE_BOUND \
3557 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3559 /* Create and initialize a new hash table.
3561 TEST specifies the test the hash table will use to compare keys.
3562 It must be either one of the predefined tests `eq', `eql' or
3563 `equal' or a symbol denoting a user-defined test named TEST with
3564 test and hash functions USER_TEST and USER_HASH.
3566 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3568 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3569 new size when it becomes full is computed by adding REHASH_SIZE to
3570 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3571 table's new size is computed by multiplying its old size with
3574 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3575 be resized when the ratio of (number of entries in the table) /
3576 (table size) is >= REHASH_THRESHOLD.
3578 WEAK specifies the weakness of the table. If non-nil, it must be
3579 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3582 make_hash_table (struct hash_table_test test
,
3583 Lisp_Object size
, Lisp_Object rehash_size
,
3584 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3586 struct Lisp_Hash_Table
*h
;
3588 EMACS_INT index_size
, sz
;
3592 /* Preconditions. */
3593 eassert (SYMBOLP (test
.name
));
3594 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3595 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3596 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3597 eassert (FLOATP (rehash_threshold
)
3598 && 0 < XFLOAT_DATA (rehash_threshold
)
3599 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3601 if (XFASTINT (size
) == 0)
3602 size
= make_number (1);
3604 sz
= XFASTINT (size
);
3605 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3606 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3607 ? next_almost_prime (index_float
)
3608 : INDEX_SIZE_BOUND
+ 1);
3609 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3610 error ("Hash table too large");
3612 /* Allocate a table and initialize it. */
3613 h
= allocate_hash_table ();
3615 /* Initialize hash table slots. */
3618 h
->rehash_threshold
= rehash_threshold
;
3619 h
->rehash_size
= rehash_size
;
3621 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3622 h
->hash
= Fmake_vector (size
, Qnil
);
3623 h
->next
= Fmake_vector (size
, Qnil
);
3624 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3626 /* Set up the free list. */
3627 for (i
= 0; i
< sz
- 1; ++i
)
3628 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3629 h
->next_free
= make_number (0);
3631 XSET_HASH_TABLE (table
, h
);
3632 eassert (HASH_TABLE_P (table
));
3633 eassert (XHASH_TABLE (table
) == h
);
3639 /* Return a copy of hash table H1. Keys and values are not copied,
3640 only the table itself is. */
3643 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3646 struct Lisp_Hash_Table
*h2
;
3648 h2
= allocate_hash_table ();
3650 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3651 h2
->hash
= Fcopy_sequence (h1
->hash
);
3652 h2
->next
= Fcopy_sequence (h1
->next
);
3653 h2
->index
= Fcopy_sequence (h1
->index
);
3654 XSET_HASH_TABLE (table
, h2
);
3660 /* Resize hash table H if it's too full. If H cannot be resized
3661 because it's already too large, throw an error. */
3664 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3666 if (NILP (h
->next_free
))
3668 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3669 EMACS_INT new_size
, index_size
, nsize
;
3673 if (INTEGERP (h
->rehash_size
))
3674 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3677 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3678 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3680 new_size
= float_new_size
;
3681 if (new_size
<= old_size
)
3682 new_size
= old_size
+ 1;
3685 new_size
= INDEX_SIZE_BOUND
+ 1;
3687 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3688 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3689 ? next_almost_prime (index_float
)
3690 : INDEX_SIZE_BOUND
+ 1);
3691 nsize
= max (index_size
, 2 * new_size
);
3692 if (INDEX_SIZE_BOUND
< nsize
)
3693 error ("Hash table too large to resize");
3695 #ifdef ENABLE_CHECKING
3696 if (HASH_TABLE_P (Vpurify_flag
)
3697 && XHASH_TABLE (Vpurify_flag
) == h
)
3699 Lisp_Object args
[2];
3700 args
[0] = build_string ("Growing hash table to: %d");
3701 args
[1] = make_number (new_size
);
3706 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3707 2 * (new_size
- old_size
), -1));
3708 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3709 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3710 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3712 /* Update the free list. Do it so that new entries are added at
3713 the end of the free list. This makes some operations like
3715 for (i
= old_size
; i
< new_size
- 1; ++i
)
3716 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3718 if (!NILP (h
->next_free
))
3720 Lisp_Object last
, next
;
3722 last
= h
->next_free
;
3723 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3727 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3730 XSETFASTINT (h
->next_free
, old_size
);
3733 for (i
= 0; i
< old_size
; ++i
)
3734 if (!NILP (HASH_HASH (h
, i
)))
3736 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3737 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3738 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3739 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3745 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3746 the hash code of KEY. Value is the index of the entry in H
3747 matching KEY, or -1 if not found. */
3750 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3752 EMACS_UINT hash_code
;
3753 ptrdiff_t start_of_bucket
;
3756 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3757 eassert ((hash_code
& ~INTMASK
) == 0);
3761 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3762 idx
= HASH_INDEX (h
, start_of_bucket
);
3764 /* We need not gcpro idx since it's either an integer or nil. */
3767 ptrdiff_t i
= XFASTINT (idx
);
3768 if (EQ (key
, HASH_KEY (h
, i
))
3770 && hash_code
== XUINT (HASH_HASH (h
, i
))
3771 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3773 idx
= HASH_NEXT (h
, i
);
3776 return NILP (idx
) ? -1 : XFASTINT (idx
);
3780 /* Put an entry into hash table H that associates KEY with VALUE.
3781 HASH is a previously computed hash code of KEY.
3782 Value is the index of the entry in H matching KEY. */
3785 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3788 ptrdiff_t start_of_bucket
, i
;
3790 eassert ((hash
& ~INTMASK
) == 0);
3792 /* Increment count after resizing because resizing may fail. */
3793 maybe_resize_hash_table (h
);
3796 /* Store key/value in the key_and_value vector. */
3797 i
= XFASTINT (h
->next_free
);
3798 h
->next_free
= HASH_NEXT (h
, i
);
3799 set_hash_key_slot (h
, i
, key
);
3800 set_hash_value_slot (h
, i
, value
);
3802 /* Remember its hash code. */
3803 set_hash_hash_slot (h
, i
, make_number (hash
));
3805 /* Add new entry to its collision chain. */
3806 start_of_bucket
= hash
% ASIZE (h
->index
);
3807 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3808 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3813 /* Remove the entry matching KEY from hash table H, if there is one. */
3816 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3818 EMACS_UINT hash_code
;
3819 ptrdiff_t start_of_bucket
;
3820 Lisp_Object idx
, prev
;
3822 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3823 eassert ((hash_code
& ~INTMASK
) == 0);
3824 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3825 idx
= HASH_INDEX (h
, start_of_bucket
);
3828 /* We need not gcpro idx, prev since they're either integers or nil. */
3831 ptrdiff_t i
= XFASTINT (idx
);
3833 if (EQ (key
, HASH_KEY (h
, i
))
3835 && hash_code
== XUINT (HASH_HASH (h
, i
))
3836 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3838 /* Take entry out of collision chain. */
3840 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3842 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3844 /* Clear slots in key_and_value and add the slots to
3846 set_hash_key_slot (h
, i
, Qnil
);
3847 set_hash_value_slot (h
, i
, Qnil
);
3848 set_hash_hash_slot (h
, i
, Qnil
);
3849 set_hash_next_slot (h
, i
, h
->next_free
);
3850 h
->next_free
= make_number (i
);
3852 eassert (h
->count
>= 0);
3858 idx
= HASH_NEXT (h
, i
);
3864 /* Clear hash table H. */
3867 hash_clear (struct Lisp_Hash_Table
*h
)
3871 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3873 for (i
= 0; i
< size
; ++i
)
3875 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3876 set_hash_key_slot (h
, i
, Qnil
);
3877 set_hash_value_slot (h
, i
, Qnil
);
3878 set_hash_hash_slot (h
, i
, Qnil
);
3881 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3882 ASET (h
->index
, i
, Qnil
);
3884 h
->next_free
= make_number (0);
3891 /***********************************************************************
3892 Hash Code Computation
3893 ***********************************************************************/
3895 /* Maximum depth up to which to dive into Lisp structures. */
3897 #define SXHASH_MAX_DEPTH 3
3899 /* Maximum length up to which to take list and vector elements into
3902 #define SXHASH_MAX_LEN 7
3904 /* Return a hash for string PTR which has length LEN. The hash value
3905 can be any EMACS_UINT value. */
3908 hash_string (char const *ptr
, ptrdiff_t len
)
3910 char const *p
= ptr
;
3911 char const *end
= p
+ len
;
3913 EMACS_UINT hash
= 0;
3918 hash
= sxhash_combine (hash
, c
);
3924 /* Return a hash for string PTR which has length LEN. The hash
3925 code returned is guaranteed to fit in a Lisp integer. */
3928 sxhash_string (char const *ptr
, ptrdiff_t len
)
3930 EMACS_UINT hash
= hash_string (ptr
, len
);
3931 return SXHASH_REDUCE (hash
);
3934 /* Return a hash for the floating point value VAL. */
3937 sxhash_float (double val
)
3939 EMACS_UINT hash
= 0;
3941 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
3942 + (sizeof val
% sizeof hash
!= 0))
3946 EMACS_UINT word
[WORDS_PER_DOUBLE
];
3950 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
3951 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
3952 hash
= sxhash_combine (hash
, u
.word
[i
]);
3953 return SXHASH_REDUCE (hash
);
3956 /* Return a hash for list LIST. DEPTH is the current depth in the
3957 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
3960 sxhash_list (Lisp_Object list
, int depth
)
3962 EMACS_UINT hash
= 0;
3965 if (depth
< SXHASH_MAX_DEPTH
)
3967 CONSP (list
) && i
< SXHASH_MAX_LEN
;
3968 list
= XCDR (list
), ++i
)
3970 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
3971 hash
= sxhash_combine (hash
, hash2
);
3976 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
3977 hash
= sxhash_combine (hash
, hash2
);
3980 return SXHASH_REDUCE (hash
);
3984 /* Return a hash for vector VECTOR. DEPTH is the current depth in
3985 the Lisp structure. */
3988 sxhash_vector (Lisp_Object vec
, int depth
)
3990 EMACS_UINT hash
= ASIZE (vec
);
3993 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
3994 for (i
= 0; i
< n
; ++i
)
3996 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
3997 hash
= sxhash_combine (hash
, hash2
);
4000 return SXHASH_REDUCE (hash
);
4003 /* Return a hash for bool-vector VECTOR. */
4006 sxhash_bool_vector (Lisp_Object vec
)
4008 EMACS_INT size
= bool_vector_size (vec
);
4009 EMACS_UINT hash
= size
;
4012 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4013 for (i
= 0; i
< n
; ++i
)
4014 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4016 return SXHASH_REDUCE (hash
);
4020 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4021 structure. Value is an unsigned integer clipped to INTMASK. */
4024 sxhash (Lisp_Object obj
, int depth
)
4028 if (depth
> SXHASH_MAX_DEPTH
)
4031 switch (XTYPE (obj
))
4042 obj
= SYMBOL_NAME (obj
);
4046 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4049 /* This can be everything from a vector to an overlay. */
4050 case Lisp_Vectorlike
:
4052 /* According to the CL HyperSpec, two arrays are equal only if
4053 they are `eq', except for strings and bit-vectors. In
4054 Emacs, this works differently. We have to compare element
4056 hash
= sxhash_vector (obj
, depth
);
4057 else if (BOOL_VECTOR_P (obj
))
4058 hash
= sxhash_bool_vector (obj
);
4060 /* Others are `equal' if they are `eq', so let's take their
4066 hash
= sxhash_list (obj
, depth
);
4070 hash
= sxhash_float (XFLOAT_DATA (obj
));
4082 /***********************************************************************
4084 ***********************************************************************/
4087 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4088 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4091 EMACS_UINT hash
= sxhash (obj
, 0);
4092 return make_number (hash
);
4096 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4097 doc
: /* Create and return a new hash table.
4099 Arguments are specified as keyword/argument pairs. The following
4100 arguments are defined:
4102 :test TEST -- TEST must be a symbol that specifies how to compare
4103 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4104 `equal'. User-supplied test and hash functions can be specified via
4105 `define-hash-table-test'.
4107 :size SIZE -- A hint as to how many elements will be put in the table.
4110 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4111 fills up. If REHASH-SIZE is an integer, increase the size by that
4112 amount. If it is a float, it must be > 1.0, and the new size is the
4113 old size multiplied by that factor. Default is 1.5.
4115 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4116 Resize the hash table when the ratio (number of entries / table size)
4117 is greater than or equal to THRESHOLD. Default is 0.8.
4119 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4120 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4121 returned is a weak table. Key/value pairs are removed from a weak
4122 hash table when there are no non-weak references pointing to their
4123 key, value, one of key or value, or both key and value, depending on
4124 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4127 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4128 (ptrdiff_t nargs
, Lisp_Object
*args
)
4130 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4131 struct hash_table_test testdesc
;
4135 /* The vector `used' is used to keep track of arguments that
4136 have been consumed. */
4137 used
= alloca (nargs
* sizeof *used
);
4138 memset (used
, 0, nargs
* sizeof *used
);
4140 /* See if there's a `:test TEST' among the arguments. */
4141 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4142 test
= i
? args
[i
] : Qeql
;
4144 testdesc
= hashtest_eq
;
4145 else if (EQ (test
, Qeql
))
4146 testdesc
= hashtest_eql
;
4147 else if (EQ (test
, Qequal
))
4148 testdesc
= hashtest_equal
;
4151 /* See if it is a user-defined test. */
4154 prop
= Fget (test
, Qhash_table_test
);
4155 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4156 signal_error ("Invalid hash table test", test
);
4157 testdesc
.name
= test
;
4158 testdesc
.user_cmp_function
= XCAR (prop
);
4159 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4160 testdesc
.hashfn
= hashfn_user_defined
;
4161 testdesc
.cmpfn
= cmpfn_user_defined
;
4164 /* See if there's a `:size SIZE' argument. */
4165 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4166 size
= i
? args
[i
] : Qnil
;
4168 size
= make_number (DEFAULT_HASH_SIZE
);
4169 else if (!INTEGERP (size
) || XINT (size
) < 0)
4170 signal_error ("Invalid hash table size", size
);
4172 /* Look for `:rehash-size SIZE'. */
4173 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4174 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4175 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4176 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4177 signal_error ("Invalid hash table rehash size", rehash_size
);
4179 /* Look for `:rehash-threshold THRESHOLD'. */
4180 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4181 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4182 if (! (FLOATP (rehash_threshold
)
4183 && 0 < XFLOAT_DATA (rehash_threshold
)
4184 && XFLOAT_DATA (rehash_threshold
) <= 1))
4185 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4187 /* Look for `:weakness WEAK'. */
4188 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4189 weak
= i
? args
[i
] : Qnil
;
4191 weak
= Qkey_and_value
;
4194 && !EQ (weak
, Qvalue
)
4195 && !EQ (weak
, Qkey_or_value
)
4196 && !EQ (weak
, Qkey_and_value
))
4197 signal_error ("Invalid hash table weakness", weak
);
4199 /* Now, all args should have been used up, or there's a problem. */
4200 for (i
= 0; i
< nargs
; ++i
)
4202 signal_error ("Invalid argument list", args
[i
]);
4204 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4208 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4209 doc
: /* Return a copy of hash table TABLE. */)
4212 return copy_hash_table (check_hash_table (table
));
4216 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4217 doc
: /* Return the number of elements in TABLE. */)
4220 return make_number (check_hash_table (table
)->count
);
4224 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4225 Shash_table_rehash_size
, 1, 1, 0,
4226 doc
: /* Return the current rehash size of TABLE. */)
4229 return check_hash_table (table
)->rehash_size
;
4233 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4234 Shash_table_rehash_threshold
, 1, 1, 0,
4235 doc
: /* Return the current rehash threshold of TABLE. */)
4238 return check_hash_table (table
)->rehash_threshold
;
4242 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4243 doc
: /* Return the size of TABLE.
4244 The size can be used as an argument to `make-hash-table' to create
4245 a hash table than can hold as many elements as TABLE holds
4246 without need for resizing. */)
4249 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4250 return make_number (HASH_TABLE_SIZE (h
));
4254 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4255 doc
: /* Return the test TABLE uses. */)
4258 return check_hash_table (table
)->test
.name
;
4262 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4264 doc
: /* Return the weakness of TABLE. */)
4267 return check_hash_table (table
)->weak
;
4271 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4272 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4275 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4279 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4280 doc
: /* Clear hash table TABLE and return it. */)
4283 hash_clear (check_hash_table (table
));
4284 /* Be compatible with XEmacs. */
4289 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4290 doc
: /* Look up KEY in TABLE and return its associated value.
4291 If KEY is not found, return DFLT which defaults to nil. */)
4292 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4294 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4295 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4296 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4300 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4301 doc
: /* Associate KEY with VALUE in hash table TABLE.
4302 If KEY is already present in table, replace its current value with
4303 VALUE. In any case, return VALUE. */)
4304 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4306 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4310 i
= hash_lookup (h
, key
, &hash
);
4312 set_hash_value_slot (h
, i
, value
);
4314 hash_put (h
, key
, value
, hash
);
4320 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4321 doc
: /* Remove KEY from TABLE. */)
4322 (Lisp_Object key
, Lisp_Object table
)
4324 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4325 hash_remove_from_table (h
, key
);
4330 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4331 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4332 FUNCTION is called with two arguments, KEY and VALUE.
4333 `maphash' always returns nil. */)
4334 (Lisp_Object function
, Lisp_Object table
)
4336 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4337 Lisp_Object args
[3];
4340 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4341 if (!NILP (HASH_HASH (h
, i
)))
4344 args
[1] = HASH_KEY (h
, i
);
4345 args
[2] = HASH_VALUE (h
, i
);
4353 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4354 Sdefine_hash_table_test
, 3, 3, 0,
4355 doc
: /* Define a new hash table test with name NAME, a symbol.
4357 In hash tables created with NAME specified as test, use TEST to
4358 compare keys, and HASH for computing hash codes of keys.
4360 TEST must be a function taking two arguments and returning non-nil if
4361 both arguments are the same. HASH must be a function taking one
4362 argument and returning an object that is the hash code of the argument.
4363 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4364 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4365 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4367 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4372 /************************************************************************
4373 MD5, SHA-1, and SHA-2
4374 ************************************************************************/
4381 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4384 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4385 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4389 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4390 register EMACS_INT b
, e
;
4391 register struct buffer
*bp
;
4394 void *(*hash_func
) (const char *, size_t, void *);
4397 CHECK_SYMBOL (algorithm
);
4399 if (STRINGP (object
))
4401 if (NILP (coding_system
))
4403 /* Decide the coding-system to encode the data with. */
4405 if (STRING_MULTIBYTE (object
))
4406 /* use default, we can't guess correct value */
4407 coding_system
= preferred_coding_system ();
4409 coding_system
= Qraw_text
;
4412 if (NILP (Fcoding_system_p (coding_system
)))
4414 /* Invalid coding system. */
4416 if (!NILP (noerror
))
4417 coding_system
= Qraw_text
;
4419 xsignal1 (Qcoding_system_error
, coding_system
);
4422 if (STRING_MULTIBYTE (object
))
4423 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4425 size
= SCHARS (object
);
4426 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4428 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4429 end_byte
= (end_char
== size
4431 : string_char_to_byte (object
, end_char
));
4435 struct buffer
*prev
= current_buffer
;
4437 record_unwind_current_buffer ();
4439 CHECK_BUFFER (object
);
4441 bp
= XBUFFER (object
);
4442 set_buffer_internal (bp
);
4448 CHECK_NUMBER_COERCE_MARKER (start
);
4456 CHECK_NUMBER_COERCE_MARKER (end
);
4461 temp
= b
, b
= e
, e
= temp
;
4463 if (!(BEGV
<= b
&& e
<= ZV
))
4464 args_out_of_range (start
, end
);
4466 if (NILP (coding_system
))
4468 /* Decide the coding-system to encode the data with.
4469 See fileio.c:Fwrite-region */
4471 if (!NILP (Vcoding_system_for_write
))
4472 coding_system
= Vcoding_system_for_write
;
4475 bool force_raw_text
= 0;
4477 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4478 if (NILP (coding_system
)
4479 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4481 coding_system
= Qnil
;
4482 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4486 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4488 /* Check file-coding-system-alist. */
4489 Lisp_Object args
[4], val
;
4491 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4492 args
[3] = Fbuffer_file_name (object
);
4493 val
= Ffind_operation_coding_system (4, args
);
4494 if (CONSP (val
) && !NILP (XCDR (val
)))
4495 coding_system
= XCDR (val
);
4498 if (NILP (coding_system
)
4499 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4501 /* If we still have not decided a coding system, use the
4502 default value of buffer-file-coding-system. */
4503 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4507 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4508 /* Confirm that VAL can surely encode the current region. */
4509 coding_system
= call4 (Vselect_safe_coding_system_function
,
4510 make_number (b
), make_number (e
),
4511 coding_system
, Qnil
);
4514 coding_system
= Qraw_text
;
4517 if (NILP (Fcoding_system_p (coding_system
)))
4519 /* Invalid coding system. */
4521 if (!NILP (noerror
))
4522 coding_system
= Qraw_text
;
4524 xsignal1 (Qcoding_system_error
, coding_system
);
4528 object
= make_buffer_string (b
, e
, 0);
4529 set_buffer_internal (prev
);
4530 /* Discard the unwind protect for recovering the current
4534 if (STRING_MULTIBYTE (object
))
4535 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4537 end_byte
= SBYTES (object
);
4540 if (EQ (algorithm
, Qmd5
))
4542 digest_size
= MD5_DIGEST_SIZE
;
4543 hash_func
= md5_buffer
;
4545 else if (EQ (algorithm
, Qsha1
))
4547 digest_size
= SHA1_DIGEST_SIZE
;
4548 hash_func
= sha1_buffer
;
4550 else if (EQ (algorithm
, Qsha224
))
4552 digest_size
= SHA224_DIGEST_SIZE
;
4553 hash_func
= sha224_buffer
;
4555 else if (EQ (algorithm
, Qsha256
))
4557 digest_size
= SHA256_DIGEST_SIZE
;
4558 hash_func
= sha256_buffer
;
4560 else if (EQ (algorithm
, Qsha384
))
4562 digest_size
= SHA384_DIGEST_SIZE
;
4563 hash_func
= sha384_buffer
;
4565 else if (EQ (algorithm
, Qsha512
))
4567 digest_size
= SHA512_DIGEST_SIZE
;
4568 hash_func
= sha512_buffer
;
4571 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4573 /* allocate 2 x digest_size so that it can be re-used to hold the
4575 digest
= make_uninit_string (digest_size
* 2);
4577 hash_func (SSDATA (object
) + start_byte
,
4578 end_byte
- start_byte
,
4583 unsigned char *p
= SDATA (digest
);
4584 for (i
= digest_size
- 1; i
>= 0; i
--)
4586 static char const hexdigit
[16] = "0123456789abcdef";
4588 p
[2 * i
] = hexdigit
[p_i
>> 4];
4589 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4594 return make_unibyte_string (SSDATA (digest
), digest_size
);
4597 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4598 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4600 A message digest is a cryptographic checksum of a document, and the
4601 algorithm to calculate it is defined in RFC 1321.
4603 The two optional arguments START and END are character positions
4604 specifying for which part of OBJECT the message digest should be
4605 computed. If nil or omitted, the digest is computed for the whole
4608 The MD5 message digest is computed from the result of encoding the
4609 text in a coding system, not directly from the internal Emacs form of
4610 the text. The optional fourth argument CODING-SYSTEM specifies which
4611 coding system to encode the text with. It should be the same coding
4612 system that you used or will use when actually writing the text into a
4615 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4616 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4617 system would be chosen by default for writing this text into a file.
4619 If OBJECT is a string, the most preferred coding system (see the
4620 command `prefer-coding-system') is used.
4622 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4623 guesswork fails. Normally, an error is signaled in such case. */)
4624 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4626 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4629 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4630 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4631 ALGORITHM is a symbol specifying the hash to use:
4632 md5, sha1, sha224, sha256, sha384 or sha512.
4634 The two optional arguments START and END are positions specifying for
4635 which part of OBJECT to compute the hash. If nil or omitted, uses the
4638 If BINARY is non-nil, returns a string in binary form. */)
4639 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4641 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4645 init_fns_once (void)
4647 compare_text_properties
= scm_make_fluid ();
4648 scm_set_smob_equalp (lisp_misc_tag
, misc_equal_p
);
4649 scm_set_smob_equalp (lisp_string_tag
, string_equal_p
);
4650 scm_set_smob_equalp (lisp_vectorlike_tag
, vectorlike_equal_p
);
4658 DEFSYM (Qmd5
, "md5");
4659 DEFSYM (Qsha1
, "sha1");
4660 DEFSYM (Qsha224
, "sha224");
4661 DEFSYM (Qsha256
, "sha256");
4662 DEFSYM (Qsha384
, "sha384");
4663 DEFSYM (Qsha512
, "sha512");
4665 /* Hash table stuff. */
4666 DEFSYM (Qhash_table_p
, "hash-table-p");
4668 DEFSYM (Qeql
, "eql");
4669 DEFSYM (Qequal
, "equal");
4670 DEFSYM (QCtest
, ":test");
4671 DEFSYM (QCsize
, ":size");
4672 DEFSYM (QCrehash_size
, ":rehash-size");
4673 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4674 DEFSYM (QCweakness
, ":weakness");
4675 DEFSYM (Qkey
, "key");
4676 DEFSYM (Qvalue
, "value");
4677 DEFSYM (Qhash_table_test
, "hash-table-test");
4678 DEFSYM (Qkey_or_value
, "key-or-value");
4679 DEFSYM (Qkey_and_value
, "key-and-value");
4681 DEFSYM (Qstring_lessp
, "string-lessp");
4682 DEFSYM (Qprovide
, "provide");
4683 DEFSYM (Qrequire
, "require");
4684 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4685 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4686 DEFSYM (Qwidget_type
, "widget-type");
4688 staticpro (&string_char_byte_cache_string
);
4689 string_char_byte_cache_string
= Qnil
;
4691 require_nesting_list
= Qnil
;
4692 staticpro (&require_nesting_list
);
4694 Fset (Qyes_or_no_p_history
, Qnil
);
4696 DEFVAR_LISP ("features", Vfeatures
,
4697 doc
: /* A list of symbols which are the features of the executing Emacs.
4698 Used by `featurep' and `require', and altered by `provide'. */);
4699 Vfeatures
= list1 (intern_c_string ("emacs"));
4700 DEFSYM (Qsubfeatures
, "subfeatures");
4701 DEFSYM (Qfuncall
, "funcall");
4703 #ifdef HAVE_LANGINFO_CODESET
4704 DEFSYM (Qcodeset
, "codeset");
4705 DEFSYM (Qdays
, "days");
4706 DEFSYM (Qmonths
, "months");
4707 DEFSYM (Qpaper
, "paper");
4708 #endif /* HAVE_LANGINFO_CODESET */
4710 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4711 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4712 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4713 invoked by mouse clicks and mouse menu items.
4715 On some platforms, file selection dialogs are also enabled if this is
4719 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4720 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4721 This applies to commands from menus and tool bar buttons even when
4722 they are initiated from the keyboard. If `use-dialog-box' is nil,
4723 that disables the use of a file dialog, regardless of the value of
4725 use_file_dialog
= 1;
4727 hashtest_eq
.name
= Qeq
;
4728 hashtest_eq
.user_hash_function
= Qnil
;
4729 hashtest_eq
.user_cmp_function
= Qnil
;
4730 hashtest_eq
.cmpfn
= 0;
4731 hashtest_eq
.hashfn
= hashfn_eq
;
4733 hashtest_eql
.name
= Qeql
;
4734 hashtest_eql
.user_hash_function
= Qnil
;
4735 hashtest_eql
.user_cmp_function
= Qnil
;
4736 hashtest_eql
.cmpfn
= cmpfn_eql
;
4737 hashtest_eql
.hashfn
= hashfn_eql
;
4739 hashtest_equal
.name
= Qequal
;
4740 hashtest_equal
.user_hash_function
= Qnil
;
4741 hashtest_equal
.user_cmp_function
= Qnil
;
4742 hashtest_equal
.cmpfn
= cmpfn_equal
;
4743 hashtest_equal
.hashfn
= hashfn_equal
;