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 enum concat_target_type
345 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
346 enum concat_target_type target_type
, bool last_special
);
350 concat2 (Lisp_Object s1
, Lisp_Object s2
)
355 return concat (2, args
, concat_string
, 0);
360 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
366 return concat (3, args
, concat_string
, 0);
369 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
370 doc
: /* Concatenate all the arguments and make the result a list.
371 The result is a list whose elements are the elements of all the arguments.
372 Each argument may be a list, vector or string.
373 The last argument is not copied, just used as the tail of the new list.
374 usage: (append &rest SEQUENCES) */)
375 (ptrdiff_t nargs
, Lisp_Object
*args
)
377 return concat (nargs
, args
, concat_cons
, 1);
380 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
381 doc
: /* Concatenate all the arguments and make the result a string.
382 The result is a string whose elements are the elements of all the arguments.
383 Each argument may be a string or a list or vector of characters (integers).
384 usage: (concat &rest SEQUENCES) */)
385 (ptrdiff_t nargs
, Lisp_Object
*args
)
387 return concat (nargs
, args
, concat_string
, 0);
390 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
391 doc
: /* Concatenate all the arguments and make the result a vector.
392 The result is a vector whose elements are the elements of all the arguments.
393 Each argument may be a list, vector or string.
394 usage: (vconcat &rest SEQUENCES) */)
395 (ptrdiff_t nargs
, Lisp_Object
*args
)
397 return concat (nargs
, args
, concat_vector
, 0);
401 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
402 doc
: /* Return a copy of a list, vector, string or char-table.
403 The elements of a list or vector are not copied; they are shared
404 with the original. */)
407 if (NILP (arg
)) return arg
;
409 if (CHAR_TABLE_P (arg
))
411 return copy_char_table (arg
);
414 if (BOOL_VECTOR_P (arg
))
416 EMACS_INT nbits
= bool_vector_size (arg
);
417 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
418 Lisp_Object val
= make_uninit_bool_vector (nbits
);
419 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
424 return concat (1, &arg
, concat_cons
, 0);
425 else if (STRINGP (arg
))
426 return concat (1, &arg
, concat_string
, 0);
427 else if (VECTORP (arg
))
428 return concat (1, &arg
, concat_vector
, 0);
430 wrong_type_argument (Qsequencep
, arg
);
433 /* This structure holds information of an argument of `concat' that is
434 a string and has text properties to be copied. */
437 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
438 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
439 ptrdiff_t to
; /* refer to VAL (the target string) */
443 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
444 enum concat_target_type target_type
, bool last_special
)
450 ptrdiff_t toindex_byte
= 0;
451 EMACS_INT result_len
;
452 EMACS_INT result_len_byte
;
454 Lisp_Object last_tail
;
457 /* When we make a multibyte string, we can't copy text properties
458 while concatenating each string because the length of resulting
459 string can't be decided until we finish the whole concatenation.
460 So, we record strings that have text properties to be copied
461 here, and copy the text properties after the concatenation. */
462 struct textprop_rec
*textprops
= NULL
;
463 /* Number of elements in textprops. */
464 ptrdiff_t num_textprops
= 0;
469 /* In append, the last arg isn't treated like the others */
470 if (last_special
&& nargs
> 0)
473 last_tail
= args
[nargs
];
478 /* Check each argument. */
479 for (argnum
= 0; argnum
< nargs
; argnum
++)
482 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
483 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
484 wrong_type_argument (Qsequencep
, this);
487 /* Compute total length in chars of arguments in RESULT_LEN.
488 If desired output is a string, also compute length in bytes
489 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
490 whether the result should be a multibyte string. */
494 for (argnum
= 0; argnum
< nargs
; argnum
++)
498 len
= XFASTINT (Flength (this));
499 if (target_type
== concat_string
)
501 /* We must count the number of bytes needed in the string
502 as well as the number of characters. */
506 ptrdiff_t this_len_byte
;
508 if (VECTORP (this) || COMPILEDP (this))
509 for (i
= 0; i
< len
; i
++)
512 CHECK_CHARACTER (ch
);
514 this_len_byte
= CHAR_BYTES (c
);
515 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
517 result_len_byte
+= this_len_byte
;
518 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
521 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
522 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
523 else if (CONSP (this))
524 for (; CONSP (this); this = XCDR (this))
527 CHECK_CHARACTER (ch
);
529 this_len_byte
= CHAR_BYTES (c
);
530 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
532 result_len_byte
+= this_len_byte
;
533 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
536 else if (STRINGP (this))
538 if (STRING_MULTIBYTE (this))
541 this_len_byte
= SBYTES (this);
544 this_len_byte
= count_size_as_multibyte (SDATA (this),
546 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
548 result_len_byte
+= this_len_byte
;
553 if (MOST_POSITIVE_FIXNUM
< result_len
)
554 memory_full (SIZE_MAX
);
557 if (! some_multibyte
)
558 result_len_byte
= result_len
;
560 /* Create the output object. */
561 if (target_type
== concat_cons
)
562 val
= Fmake_list (make_number (result_len
), Qnil
);
563 else if (target_type
== concat_vector
)
564 val
= Fmake_vector (make_number (result_len
), Qnil
);
565 else if (some_multibyte
)
566 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
568 val
= make_uninit_string (result_len
);
570 /* In `append', if all but last arg are nil, return last arg. */
571 if (target_type
== concat_cons
&& EQ (val
, Qnil
))
574 /* Copy the contents of the args into the result. */
576 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
578 toindex
= 0, toindex_byte
= 0;
582 SAFE_NALLOCA (textprops
, 1, nargs
);
584 for (argnum
= 0; argnum
< nargs
; argnum
++)
587 ptrdiff_t thisleni
= 0;
588 register ptrdiff_t thisindex
= 0;
589 register ptrdiff_t thisindex_byte
= 0;
593 thislen
= Flength (this), thisleni
= XINT (thislen
);
595 /* Between strings of the same kind, copy fast. */
596 if (STRINGP (this) && STRINGP (val
)
597 && STRING_MULTIBYTE (this) == some_multibyte
)
599 ptrdiff_t thislen_byte
= SBYTES (this);
601 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
602 if (string_intervals (this))
604 textprops
[num_textprops
].argnum
= argnum
;
605 textprops
[num_textprops
].from
= 0;
606 textprops
[num_textprops
++].to
= toindex
;
608 toindex_byte
+= thislen_byte
;
611 /* Copy a single-byte string to a multibyte string. */
612 else if (STRINGP (this) && STRINGP (val
))
614 if (string_intervals (this))
616 textprops
[num_textprops
].argnum
= argnum
;
617 textprops
[num_textprops
].from
= 0;
618 textprops
[num_textprops
++].to
= toindex
;
620 toindex_byte
+= copy_text (SDATA (this),
621 SDATA (val
) + toindex_byte
,
622 SCHARS (this), 0, 1);
626 /* Copy element by element. */
629 register Lisp_Object elt
;
631 /* Fetch next element of `this' arg into `elt', or break if
632 `this' is exhausted. */
633 if (NILP (this)) break;
635 elt
= XCAR (this), this = XCDR (this);
636 else if (thisindex
>= thisleni
)
638 else if (STRINGP (this))
641 if (STRING_MULTIBYTE (this))
642 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
647 c
= SREF (this, thisindex
); thisindex
++;
648 if (some_multibyte
&& !ASCII_CHAR_P (c
))
649 c
= BYTE8_TO_CHAR (c
);
651 XSETFASTINT (elt
, c
);
653 else if (BOOL_VECTOR_P (this))
655 elt
= bool_vector_ref (this, thisindex
);
660 elt
= AREF (this, thisindex
);
664 /* Store this element into the result. */
671 else if (VECTORP (val
))
673 ASET (val
, toindex
, elt
);
679 CHECK_CHARACTER (elt
);
682 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
684 SSET (val
, toindex_byte
++, c
);
690 XSETCDR (prev
, last_tail
);
692 if (num_textprops
> 0)
695 ptrdiff_t last_to_end
= -1;
697 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
699 this = args
[textprops
[argnum
].argnum
];
700 props
= text_property_list (this,
702 make_number (SCHARS (this)),
704 /* If successive arguments have properties, be sure that the
705 value of `composition' property be the copy. */
706 if (last_to_end
== textprops
[argnum
].to
)
707 make_composition_value_copy (props
);
708 add_text_properties_from_list (val
, props
,
709 make_number (textprops
[argnum
].to
));
710 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
718 static Lisp_Object string_char_byte_cache_string
;
719 static ptrdiff_t string_char_byte_cache_charpos
;
720 static ptrdiff_t string_char_byte_cache_bytepos
;
723 clear_string_char_byte_cache (void)
725 string_char_byte_cache_string
= Qnil
;
728 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
731 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
734 ptrdiff_t best_below
, best_below_byte
;
735 ptrdiff_t best_above
, best_above_byte
;
737 best_below
= best_below_byte
= 0;
738 best_above
= SCHARS (string
);
739 best_above_byte
= SBYTES (string
);
740 if (best_above
== best_above_byte
)
743 if (EQ (string
, string_char_byte_cache_string
))
745 if (string_char_byte_cache_charpos
< char_index
)
747 best_below
= string_char_byte_cache_charpos
;
748 best_below_byte
= string_char_byte_cache_bytepos
;
752 best_above
= string_char_byte_cache_charpos
;
753 best_above_byte
= string_char_byte_cache_bytepos
;
757 if (char_index
- best_below
< best_above
- char_index
)
759 unsigned char *p
= SDATA (string
) + best_below_byte
;
761 while (best_below
< char_index
)
763 p
+= BYTES_BY_CHAR_HEAD (*p
);
766 i_byte
= p
- SDATA (string
);
770 unsigned char *p
= SDATA (string
) + best_above_byte
;
772 while (best_above
> char_index
)
775 while (!CHAR_HEAD_P (*p
)) p
--;
778 i_byte
= p
- SDATA (string
);
781 string_char_byte_cache_bytepos
= i_byte
;
782 string_char_byte_cache_charpos
= char_index
;
783 string_char_byte_cache_string
= string
;
788 /* Return the character index corresponding to BYTE_INDEX in STRING. */
791 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
794 ptrdiff_t best_below
, best_below_byte
;
795 ptrdiff_t best_above
, best_above_byte
;
797 best_below
= best_below_byte
= 0;
798 best_above
= SCHARS (string
);
799 best_above_byte
= SBYTES (string
);
800 if (best_above
== best_above_byte
)
803 if (EQ (string
, string_char_byte_cache_string
))
805 if (string_char_byte_cache_bytepos
< byte_index
)
807 best_below
= string_char_byte_cache_charpos
;
808 best_below_byte
= string_char_byte_cache_bytepos
;
812 best_above
= string_char_byte_cache_charpos
;
813 best_above_byte
= string_char_byte_cache_bytepos
;
817 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
819 unsigned char *p
= SDATA (string
) + best_below_byte
;
820 unsigned char *pend
= SDATA (string
) + byte_index
;
824 p
+= BYTES_BY_CHAR_HEAD (*p
);
828 i_byte
= p
- SDATA (string
);
832 unsigned char *p
= SDATA (string
) + best_above_byte
;
833 unsigned char *pbeg
= SDATA (string
) + byte_index
;
838 while (!CHAR_HEAD_P (*p
)) p
--;
842 i_byte
= p
- SDATA (string
);
845 string_char_byte_cache_bytepos
= i_byte
;
846 string_char_byte_cache_charpos
= i
;
847 string_char_byte_cache_string
= string
;
852 /* Convert STRING to a multibyte string. */
855 string_make_multibyte (Lisp_Object string
)
862 if (STRING_MULTIBYTE (string
))
865 nbytes
= count_size_as_multibyte (SDATA (string
),
867 /* If all the chars are ASCII, they won't need any more bytes
868 once converted. In that case, we can return STRING itself. */
869 if (nbytes
== SBYTES (string
))
872 buf
= SAFE_ALLOCA (nbytes
);
873 copy_text (SDATA (string
), buf
, SBYTES (string
),
876 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
883 /* Convert STRING (if unibyte) to a multibyte string without changing
884 the number of characters. Characters 0200 trough 0237 are
885 converted to eight-bit characters. */
888 string_to_multibyte (Lisp_Object string
)
895 if (STRING_MULTIBYTE (string
))
898 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
899 /* If all the chars are ASCII, they won't need any more bytes once
901 if (nbytes
== SBYTES (string
))
902 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
904 buf
= SAFE_ALLOCA (nbytes
);
905 memcpy (buf
, SDATA (string
), SBYTES (string
));
906 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
908 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
915 /* Convert STRING to a single-byte string. */
918 string_make_unibyte (Lisp_Object string
)
925 if (! STRING_MULTIBYTE (string
))
928 nchars
= SCHARS (string
);
930 buf
= SAFE_ALLOCA (nchars
);
931 copy_text (SDATA (string
), buf
, SBYTES (string
),
934 ret
= make_unibyte_string ((char *) buf
, nchars
);
940 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
942 doc
: /* Return the multibyte equivalent of STRING.
943 If STRING is unibyte and contains non-ASCII characters, the function
944 `unibyte-char-to-multibyte' is used to convert each unibyte character
945 to a multibyte character. In this case, the returned string is a
946 newly created string with no text properties. If STRING is multibyte
947 or entirely ASCII, it is returned unchanged. In particular, when
948 STRING is unibyte and entirely ASCII, the returned string is unibyte.
949 \(When the characters are all ASCII, Emacs primitives will treat the
950 string the same way whether it is unibyte or multibyte.) */)
953 CHECK_STRING (string
);
955 return string_make_multibyte (string
);
958 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
960 doc
: /* Return the unibyte equivalent of STRING.
961 Multibyte character codes are converted to unibyte according to
962 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
963 If the lookup in the translation table fails, this function takes just
964 the low 8 bits of each character. */)
967 CHECK_STRING (string
);
969 return string_make_unibyte (string
);
972 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
974 doc
: /* Return a unibyte string with the same individual bytes as STRING.
975 If STRING is unibyte, the result is STRING itself.
976 Otherwise it is a newly created string, with no text properties.
977 If STRING is multibyte and contains a character of charset
978 `eight-bit', it is converted to the corresponding single byte. */)
981 CHECK_STRING (string
);
983 if (STRING_MULTIBYTE (string
))
985 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
986 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
988 string
= make_unibyte_string ((char *) str
, bytes
);
994 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
996 doc
: /* Return a multibyte string with the same individual bytes as STRING.
997 If STRING is multibyte, the result is STRING itself.
998 Otherwise it is a newly created string, with no text properties.
1000 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1001 part of a correct utf-8 sequence), it is converted to the corresponding
1002 multibyte character of charset `eight-bit'.
1003 See also `string-to-multibyte'.
1005 Beware, this often doesn't really do what you think it does.
1006 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1007 If you're not sure, whether to use `string-as-multibyte' or
1008 `string-to-multibyte', use `string-to-multibyte'. */)
1009 (Lisp_Object string
)
1011 CHECK_STRING (string
);
1013 if (! STRING_MULTIBYTE (string
))
1015 Lisp_Object new_string
;
1016 ptrdiff_t nchars
, nbytes
;
1018 parse_str_as_multibyte (SDATA (string
),
1021 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1022 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1023 if (nbytes
!= SBYTES (string
))
1024 str_as_multibyte (SDATA (new_string
), nbytes
,
1025 SBYTES (string
), NULL
);
1026 string
= new_string
;
1027 set_string_intervals (string
, NULL
);
1032 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1034 doc
: /* Return a multibyte string with the same individual chars as STRING.
1035 If STRING is multibyte, the result is STRING itself.
1036 Otherwise it is a newly created string, with no text properties.
1038 If STRING is unibyte and contains an 8-bit byte, it is converted to
1039 the corresponding multibyte character of charset `eight-bit'.
1041 This differs from `string-as-multibyte' by converting each byte of a correct
1042 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1043 correct sequence. */)
1044 (Lisp_Object string
)
1046 CHECK_STRING (string
);
1048 return string_to_multibyte (string
);
1051 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1053 doc
: /* Return a unibyte string with the same individual chars as STRING.
1054 If STRING is unibyte, the result is STRING itself.
1055 Otherwise it is a newly created string, with no text properties,
1056 where each `eight-bit' character is converted to the corresponding byte.
1057 If STRING contains a non-ASCII, non-`eight-bit' character,
1058 an error is signaled. */)
1059 (Lisp_Object string
)
1061 CHECK_STRING (string
);
1063 if (STRING_MULTIBYTE (string
))
1065 ptrdiff_t chars
= SCHARS (string
);
1066 unsigned char *str
= xmalloc_atomic (chars
);
1067 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1069 if (converted
< chars
)
1070 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1071 string
= make_unibyte_string ((char *) str
, chars
);
1077 DEFUN ("string-to-scheme", Fstring_to_scheme
, Sstring_to_scheme
, 1, 1, 0, 0)
1078 (Lisp_Object string
)
1080 CHECK_STRING (string
);
1081 return scm_from_utf8_stringn (SSDATA (string
), SBYTES (string
));
1084 DEFUN ("string-from-scheme", Fstring_from_scheme
, Sstring_from_scheme
, 1, 1, 0, 0)
1085 (Lisp_Object string
)
1090 CHECK_STRING (string
);
1091 s
= scm_to_utf8_stringn (string
, &lenp
);
1092 return make_string (s
, lenp
);
1095 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1096 doc
: /* Return a copy of ALIST.
1097 This is an alist which represents the same mapping from objects to objects,
1098 but does not share the alist structure with ALIST.
1099 The objects mapped (cars and cdrs of elements of the alist)
1100 are shared, however.
1101 Elements of ALIST that are not conses are also shared. */)
1104 register Lisp_Object tem
;
1109 alist
= concat (1, &alist
, concat_cons
, 0);
1110 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1112 register Lisp_Object car
;
1116 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1121 /* Check that ARRAY can have a valid subarray [FROM..TO),
1122 given that its size is SIZE.
1123 If FROM is nil, use 0; if TO is nil, use SIZE.
1124 Count negative values backwards from the end.
1125 Set *IFROM and *ITO to the two indexes used. */
1128 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1129 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1133 if (INTEGERP (from
))
1139 else if (NILP (from
))
1142 wrong_type_argument (Qintegerp
, from
);
1153 wrong_type_argument (Qintegerp
, to
);
1155 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1156 args_out_of_range_3 (array
, from
, to
);
1162 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1163 doc
: /* Return a new string whose contents are a substring of STRING.
1164 The returned string consists of the characters between index FROM
1165 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1166 zero-indexed: 0 means the first character of STRING. Negative values
1167 are counted from the end of STRING. If TO is nil, the substring runs
1168 to the end of STRING.
1170 The STRING argument may also be a vector. In that case, the return
1171 value is a new vector that contains the elements between index FROM
1172 \(inclusive) and index TO (exclusive) of that vector argument.
1174 With one argument, just copy STRING (with properties, if any). */)
1175 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1178 ptrdiff_t size
, ifrom
, ito
;
1180 if (STRINGP (string
))
1181 size
= SCHARS (string
);
1182 else if (VECTORP (string
))
1183 size
= ASIZE (string
);
1185 wrong_type_argument (Qarrayp
, string
);
1187 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1189 if (STRINGP (string
))
1192 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1194 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1195 res
= make_specified_string (SSDATA (string
) + from_byte
,
1196 ito
- ifrom
, to_byte
- from_byte
,
1197 STRING_MULTIBYTE (string
));
1198 copy_text_properties (make_number (ifrom
), make_number (ito
),
1199 string
, make_number (0), res
, Qnil
);
1202 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1208 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1209 doc
: /* Return a substring of STRING, without text properties.
1210 It starts at index FROM and ends before TO.
1211 TO may be nil or omitted; then the substring runs to the end of STRING.
1212 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1213 If FROM or TO is negative, it counts from the end.
1215 With one argument, just copy STRING without its properties. */)
1216 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1218 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1220 CHECK_STRING (string
);
1222 size
= SCHARS (string
);
1223 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1225 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1227 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1228 return make_specified_string (SSDATA (string
) + from_byte
,
1229 to_char
- from_char
, to_byte
- from_byte
,
1230 STRING_MULTIBYTE (string
));
1233 /* Extract a substring of STRING, giving start and end positions
1234 both in characters and in bytes. */
1237 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1238 ptrdiff_t to
, ptrdiff_t to_byte
)
1243 CHECK_VECTOR_OR_STRING (string
);
1245 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1247 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1248 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1250 if (STRINGP (string
))
1252 res
= make_specified_string (SSDATA (string
) + from_byte
,
1253 to
- from
, to_byte
- from_byte
,
1254 STRING_MULTIBYTE (string
));
1255 copy_text_properties (make_number (from
), make_number (to
),
1256 string
, make_number (0), res
, Qnil
);
1259 res
= Fvector (to
- from
, aref_addr (string
, from
));
1264 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1265 doc
: /* Take cdr N times on LIST, return the result. */)
1266 (Lisp_Object n
, Lisp_Object list
)
1271 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1274 CHECK_LIST_CONS (list
, list
);
1280 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1281 doc
: /* Return the Nth element of LIST.
1282 N counts from zero. If LIST is not that long, nil is returned. */)
1283 (Lisp_Object n
, Lisp_Object list
)
1285 return Fcar (Fnthcdr (n
, list
));
1288 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1289 doc
: /* Return element of SEQUENCE at index N. */)
1290 (register Lisp_Object sequence
, Lisp_Object n
)
1293 if (CONSP (sequence
) || NILP (sequence
))
1294 return Fcar (Fnthcdr (n
, sequence
));
1296 /* Faref signals a "not array" error, so check here. */
1297 CHECK_ARRAY (sequence
, Qsequencep
);
1298 return Faref (sequence
, n
);
1301 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1302 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1303 The value is actually the tail of LIST whose car is ELT. */)
1304 (register Lisp_Object elt
, Lisp_Object list
)
1306 register Lisp_Object tail
;
1307 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1309 register Lisp_Object tem
;
1310 CHECK_LIST_CONS (tail
, list
);
1312 if (! NILP (Fequal (elt
, tem
)))
1319 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1320 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1321 The value is actually the tail of LIST whose car is ELT. */)
1322 (register Lisp_Object elt
, Lisp_Object list
)
1326 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1330 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1334 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1345 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1346 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1347 The value is actually the tail of LIST whose car is ELT. */)
1348 (register Lisp_Object elt
, Lisp_Object list
)
1350 register Lisp_Object tail
;
1352 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1354 register Lisp_Object tem
;
1355 CHECK_LIST_CONS (tail
, list
);
1357 if (!NILP (Feql (elt
, tem
)))
1364 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1365 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1366 The value is actually the first element of LIST whose car is KEY.
1367 Elements of LIST that are not conses are ignored. */)
1368 (Lisp_Object key
, Lisp_Object list
)
1373 || (CONSP (XCAR (list
))
1374 && EQ (XCAR (XCAR (list
)), key
)))
1379 || (CONSP (XCAR (list
))
1380 && EQ (XCAR (XCAR (list
)), key
)))
1385 || (CONSP (XCAR (list
))
1386 && EQ (XCAR (XCAR (list
)), key
)))
1396 /* Like Fassq but never report an error and do not allow quits.
1397 Use only on lists known never to be circular. */
1400 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1403 && (!CONSP (XCAR (list
))
1404 || !EQ (XCAR (XCAR (list
)), key
)))
1407 return CAR_SAFE (list
);
1410 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1411 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1412 The value is actually the first element of LIST whose car equals KEY. */)
1413 (Lisp_Object key
, Lisp_Object list
)
1420 || (CONSP (XCAR (list
))
1421 && (car
= XCAR (XCAR (list
)),
1422 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1427 || (CONSP (XCAR (list
))
1428 && (car
= XCAR (XCAR (list
)),
1429 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1434 || (CONSP (XCAR (list
))
1435 && (car
= XCAR (XCAR (list
)),
1436 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1446 /* Like Fassoc but never report an error and do not allow quits.
1447 Use only on lists known never to be circular. */
1450 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1453 && (!CONSP (XCAR (list
))
1454 || (!EQ (XCAR (XCAR (list
)), key
)
1455 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1458 return CONSP (list
) ? XCAR (list
) : Qnil
;
1461 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1462 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1463 The value is actually the first element of LIST whose cdr is KEY. */)
1464 (register Lisp_Object key
, Lisp_Object list
)
1469 || (CONSP (XCAR (list
))
1470 && EQ (XCDR (XCAR (list
)), key
)))
1475 || (CONSP (XCAR (list
))
1476 && EQ (XCDR (XCAR (list
)), key
)))
1481 || (CONSP (XCAR (list
))
1482 && EQ (XCDR (XCAR (list
)), key
)))
1492 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1493 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1494 The value is actually the first element of LIST whose cdr equals KEY. */)
1495 (Lisp_Object key
, Lisp_Object list
)
1502 || (CONSP (XCAR (list
))
1503 && (cdr
= XCDR (XCAR (list
)),
1504 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1509 || (CONSP (XCAR (list
))
1510 && (cdr
= XCDR (XCAR (list
)),
1511 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1516 || (CONSP (XCAR (list
))
1517 && (cdr
= XCDR (XCAR (list
)),
1518 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1528 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1529 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1530 More precisely, this function skips any members `eq' to ELT at the
1531 front of LIST, then removes members `eq' to ELT from the remaining
1532 sublist by modifying its list structure, then returns the resulting
1535 Write `(setq foo (delq element foo))' to be sure of correctly changing
1536 the value of a list `foo'. */)
1537 (register Lisp_Object elt
, Lisp_Object list
)
1539 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1542 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1544 Lisp_Object tem
= XCAR (tail
);
1550 Fsetcdr (prev
, XCDR (tail
));
1558 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1559 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1560 SEQ must be a sequence (i.e. a list, a vector, or a string).
1561 The return value is a sequence of the same type.
1563 If SEQ is a list, this behaves like `delq', except that it compares
1564 with `equal' instead of `eq'. In particular, it may remove elements
1565 by altering the list structure.
1567 If SEQ is not a list, deletion is never performed destructively;
1568 instead this function creates and returns a new vector or string.
1570 Write `(setq foo (delete element foo))' to be sure of correctly
1571 changing the value of a sequence `foo'. */)
1572 (Lisp_Object elt
, Lisp_Object seq
)
1578 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1579 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1582 if (n
!= ASIZE (seq
))
1584 struct Lisp_Vector
*p
= allocate_vector (n
);
1586 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1587 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1588 p
->contents
[n
++] = AREF (seq
, i
);
1590 XSETVECTOR (seq
, p
);
1593 else if (STRINGP (seq
))
1595 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1598 for (i
= nchars
= nbytes
= ibyte
= 0;
1600 ++i
, ibyte
+= cbytes
)
1602 if (STRING_MULTIBYTE (seq
))
1604 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1605 cbytes
= CHAR_BYTES (c
);
1613 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1620 if (nchars
!= SCHARS (seq
))
1624 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1625 if (!STRING_MULTIBYTE (seq
))
1626 STRING_SET_UNIBYTE (tem
);
1628 for (i
= nchars
= nbytes
= ibyte
= 0;
1630 ++i
, ibyte
+= cbytes
)
1632 if (STRING_MULTIBYTE (seq
))
1634 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1635 cbytes
= CHAR_BYTES (c
);
1643 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1645 unsigned char *from
= SDATA (seq
) + ibyte
;
1646 unsigned char *to
= SDATA (tem
) + nbytes
;
1652 for (n
= cbytes
; n
--; )
1662 Lisp_Object tail
, prev
;
1664 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1666 CHECK_LIST_CONS (tail
, seq
);
1668 if (!NILP (Fequal (elt
, XCAR (tail
))))
1673 Fsetcdr (prev
, XCDR (tail
));
1684 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1685 doc
: /* Reverse order of items in a list, vector or string SEQ.
1686 If SEQ is a list, it should be nil-terminated.
1687 This function may destructively modify SEQ to produce the value. */)
1692 else if (STRINGP (seq
))
1693 return Freverse (seq
);
1694 else if (CONSP (seq
))
1696 Lisp_Object prev
, tail
, next
;
1698 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1701 CHECK_LIST_CONS (tail
, tail
);
1703 Fsetcdr (tail
, prev
);
1708 else if (VECTORP (seq
))
1710 ptrdiff_t i
, size
= ASIZE (seq
);
1712 for (i
= 0; i
< size
/ 2; i
++)
1714 Lisp_Object tem
= AREF (seq
, i
);
1715 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1716 ASET (seq
, size
- i
- 1, tem
);
1719 else if (BOOL_VECTOR_P (seq
))
1721 ptrdiff_t i
, size
= bool_vector_size (seq
);
1723 for (i
= 0; i
< size
/ 2; i
++)
1725 bool tem
= bool_vector_bitref (seq
, i
);
1726 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1727 bool_vector_set (seq
, size
- i
- 1, tem
);
1731 wrong_type_argument (Qarrayp
, seq
);
1735 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1736 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1737 See also the function `nreverse', which is used more often. */)
1744 else if (CONSP (seq
))
1746 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1749 new = Fcons (XCAR (seq
), new);
1751 CHECK_LIST_END (seq
, seq
);
1753 else if (VECTORP (seq
))
1755 ptrdiff_t i
, size
= ASIZE (seq
);
1757 new = make_uninit_vector (size
);
1758 for (i
= 0; i
< size
; i
++)
1759 ASET (new, i
, AREF (seq
, size
- i
- 1));
1761 else if (BOOL_VECTOR_P (seq
))
1764 EMACS_INT nbits
= bool_vector_size (seq
);
1766 new = make_uninit_bool_vector (nbits
);
1767 for (i
= 0; i
< nbits
; i
++)
1768 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1770 else if (STRINGP (seq
))
1772 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1778 new = make_uninit_string (size
);
1779 for (i
= 0; i
< size
; i
++)
1780 SSET (new, i
, SREF (seq
, size
- i
- 1));
1784 unsigned char *p
, *q
;
1786 new = make_uninit_multibyte_string (size
, bytes
);
1787 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1788 while (q
> SDATA (new))
1792 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1794 CHAR_STRING (ch
, q
);
1799 wrong_type_argument (Qsequencep
, seq
);
1803 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1804 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1805 Returns the sorted list. LIST is modified by side effects.
1806 PREDICATE is called with two elements of LIST, and should return non-nil
1807 if the first element should sort before the second. */)
1808 (Lisp_Object list
, Lisp_Object predicate
)
1810 Lisp_Object front
, back
;
1811 register Lisp_Object len
, tem
;
1812 struct gcpro gcpro1
, gcpro2
;
1816 len
= Flength (list
);
1817 length
= XINT (len
);
1821 XSETINT (len
, (length
/ 2) - 1);
1822 tem
= Fnthcdr (len
, list
);
1824 Fsetcdr (tem
, Qnil
);
1826 GCPRO2 (front
, back
);
1827 front
= Fsort (front
, predicate
);
1828 back
= Fsort (back
, predicate
);
1830 return merge (front
, back
, predicate
);
1834 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1837 register Lisp_Object tail
;
1839 register Lisp_Object l1
, l2
;
1840 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1847 /* It is sufficient to protect org_l1 and org_l2.
1848 When l1 and l2 are updated, we copy the new values
1849 back into the org_ vars. */
1850 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1870 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1886 Fsetcdr (tail
, tem
);
1892 /* This does not check for quits. That is safe since it must terminate. */
1894 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1895 doc
: /* Extract a value from a property list.
1896 PLIST is a property list, which is a list of the form
1897 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1898 corresponding to the given PROP, or nil if PROP is not one of the
1899 properties on the list. This function never signals an error. */)
1900 (Lisp_Object plist
, Lisp_Object prop
)
1902 Lisp_Object tail
, halftail
;
1904 /* halftail is used to detect circular lists. */
1905 tail
= halftail
= plist
;
1906 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1908 if (EQ (prop
, XCAR (tail
)))
1909 return XCAR (XCDR (tail
));
1911 tail
= XCDR (XCDR (tail
));
1912 halftail
= XCDR (halftail
);
1913 if (EQ (tail
, halftail
))
1920 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1921 doc
: /* Return the value of SYMBOL's PROPNAME property.
1922 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1923 (Lisp_Object symbol
, Lisp_Object propname
)
1925 CHECK_SYMBOL (symbol
);
1926 return Fplist_get (symbol_plist (symbol
), propname
);
1929 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1930 doc
: /* Change value in PLIST of PROP to VAL.
1931 PLIST is a property list, which is a list of the form
1932 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1933 If PROP is already a property on the list, its value is set to VAL,
1934 otherwise the new PROP VAL pair is added. The new plist is returned;
1935 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1936 The PLIST is modified by side effects. */)
1937 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1939 register Lisp_Object tail
, prev
;
1940 Lisp_Object newcell
;
1942 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1943 tail
= XCDR (XCDR (tail
)))
1945 if (EQ (prop
, XCAR (tail
)))
1947 Fsetcar (XCDR (tail
), val
);
1954 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1958 Fsetcdr (XCDR (prev
), newcell
);
1962 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1963 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1964 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1965 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1967 CHECK_SYMBOL (symbol
);
1969 (symbol
, Fplist_put (symbol_plist (symbol
), propname
, value
));
1973 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1974 doc
: /* Extract a value from a property list, comparing with `equal'.
1975 PLIST is a property list, which is a list of the form
1976 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1977 corresponding to the given PROP, or nil if PROP is not
1978 one of the properties on the list. */)
1979 (Lisp_Object plist
, Lisp_Object prop
)
1984 CONSP (tail
) && CONSP (XCDR (tail
));
1985 tail
= XCDR (XCDR (tail
)))
1987 if (! NILP (Fequal (prop
, XCAR (tail
))))
1988 return XCAR (XCDR (tail
));
1993 CHECK_LIST_END (tail
, prop
);
1998 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1999 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2000 PLIST is a property list, which is a list of the form
2001 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2002 If PROP is already a property on the list, its value is set to VAL,
2003 otherwise the new PROP VAL pair is added. The new plist is returned;
2004 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2005 The PLIST is modified by side effects. */)
2006 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2008 register Lisp_Object tail
, prev
;
2009 Lisp_Object newcell
;
2011 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2012 tail
= XCDR (XCDR (tail
)))
2014 if (! NILP (Fequal (prop
, XCAR (tail
))))
2016 Fsetcar (XCDR (tail
), val
);
2023 newcell
= list2 (prop
, val
);
2027 Fsetcdr (XCDR (prev
), newcell
);
2031 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2032 doc
: /* Return t if the two args are the same Lisp object.
2033 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2034 (Lisp_Object obj1
, Lisp_Object obj2
)
2036 return scm_is_true (scm_eqv_p (obj1
, obj2
)) ? Qt
: Qnil
;
2039 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2040 doc
: /* Return t if two Lisp objects have similar structure and contents.
2041 They must have the same data type.
2042 Conses are compared by comparing the cars and the cdrs.
2043 Vectors and strings are compared element by element.
2044 Numbers are compared by value, but integers cannot equal floats.
2045 (Use `=' if you want integers and floats to be able to be equal.)
2046 Symbols must match exactly. */)
2047 (register Lisp_Object o1
, Lisp_Object o2
)
2049 return scm_is_true (scm_equal_p (o1
, o2
)) ? Qt
: Qnil
;
2052 SCM compare_text_properties
= SCM_BOOL_F
;
2054 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2055 doc
: /* Return t if two Lisp objects have similar structure and contents.
2056 This is like `equal' except that it compares the text properties
2057 of strings. (`equal' ignores text properties.) */)
2058 (register Lisp_Object o1
, Lisp_Object o2
)
2063 scm_dynwind_fluid (compare_text_properties
, SCM_BOOL_T
);
2064 tem
= Fequal (o1
, o2
);
2070 misc_equal_p (SCM o1
, SCM o2
)
2072 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2076 if (NILP (Fequal (OVERLAY_START (o1
), OVERLAY_START (o2
)))
2077 || NILP (Fequal (OVERLAY_END (o1
), OVERLAY_END (o2
))))
2079 return scm_equal_p (XOVERLAY (o1
)->plist
, XOVERLAY (o2
)->plist
);
2083 struct Lisp_Marker
*m1
= XMARKER (o1
), *m2
= XMARKER (o2
);
2084 return scm_from_bool (m1
->buffer
== m2
->buffer
2086 || m1
->bytepos
== m2
->bytepos
));
2092 vectorlike_equal_p (SCM o1
, SCM o2
)
2095 ptrdiff_t size
= ASIZE (o1
);
2096 /* Pseudovectors have the type encoded in the size field, so this
2097 test actually checks that the objects have the same type as well
2098 as the same size. */
2099 if (ASIZE (o2
) != size
)
2101 /* Boolvectors are compared much like strings. */
2102 if (BOOL_VECTOR_P (o1
))
2104 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2106 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2107 ((XBOOL_VECTOR (o1
)->size
2108 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2109 / BOOL_VECTOR_BITS_PER_CHAR
)))
2113 if (WINDOW_CONFIGURATIONP (o1
))
2114 return scm_from_bool (compare_window_configurations (o1
, o2
, 0));
2116 /* Aside from them, only true vectors, char-tables, compiled
2117 functions, and fonts (font-spec, font-entity, font-object) are
2118 sensible to compare, so eliminate the others now. */
2119 if (size
& PSEUDOVECTOR_FLAG
)
2121 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2124 size
&= PSEUDOVECTOR_SIZE_MASK
;
2126 for (i
= 0; i
< size
; i
++)
2131 if (scm_is_false (scm_equal_p (v1
, v2
)))
2138 string_equal_p (SCM o1
, SCM o2
)
2140 if (SCHARS (o1
) != SCHARS (o2
))
2142 if (SBYTES (o1
) != SBYTES (o2
))
2144 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2146 if (scm_is_true (scm_fluid_ref (compare_text_properties
))
2147 && !compare_string_intervals (o1
, o2
))
2153 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2154 doc
: /* Store each element of ARRAY with ITEM.
2155 ARRAY is a vector, string, char-table, or bool-vector. */)
2156 (Lisp_Object array
, Lisp_Object item
)
2158 register ptrdiff_t size
, idx
;
2160 if (VECTORP (array
))
2161 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2162 ASET (array
, idx
, item
);
2163 else if (CHAR_TABLE_P (array
))
2167 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2168 set_char_table_contents (array
, i
, item
);
2169 set_char_table_defalt (array
, item
);
2171 else if (STRINGP (array
))
2173 register unsigned char *p
= SDATA (array
);
2175 CHECK_CHARACTER (item
);
2176 charval
= XFASTINT (item
);
2177 size
= SCHARS (array
);
2178 if (STRING_MULTIBYTE (array
))
2180 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2181 int len
= CHAR_STRING (charval
, str
);
2182 ptrdiff_t size_byte
= SBYTES (array
);
2184 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2185 || SCHARS (array
) * len
!= size_byte
)
2186 error ("Attempt to change byte length of a string");
2187 for (idx
= 0; idx
< size_byte
; idx
++)
2188 *p
++ = str
[idx
% len
];
2191 for (idx
= 0; idx
< size
; idx
++)
2194 else if (BOOL_VECTOR_P (array
))
2195 return bool_vector_fill (array
, item
);
2197 wrong_type_argument (Qarrayp
, array
);
2201 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2203 doc
: /* Clear the contents of STRING.
2204 This makes STRING unibyte and may change its length. */)
2205 (Lisp_Object string
)
2208 CHECK_STRING (string
);
2209 len
= SBYTES (string
);
2210 memset (SDATA (string
), 0, len
);
2211 STRING_SET_CHARS (string
, len
);
2212 STRING_SET_UNIBYTE (string
);
2218 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2220 Lisp_Object args
[2];
2223 return Fnconc (2, args
);
2226 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2227 doc
: /* Concatenate any number of lists by altering them.
2228 Only the last argument is not altered, and need not be a list.
2229 usage: (nconc &rest LISTS) */)
2230 (ptrdiff_t nargs
, Lisp_Object
*args
)
2233 register Lisp_Object tail
, tem
, val
;
2237 for (argnum
= 0; argnum
< nargs
; argnum
++)
2240 if (NILP (tem
)) continue;
2245 if (argnum
+ 1 == nargs
) break;
2247 CHECK_LIST_CONS (tem
, tem
);
2256 tem
= args
[argnum
+ 1];
2257 Fsetcdr (tail
, tem
);
2259 args
[argnum
+ 1] = tail
;
2265 /* This is the guts of all mapping functions.
2266 Apply FN to each element of SEQ, one by one,
2267 storing the results into elements of VALS, a C vector of Lisp_Objects.
2268 LENI is the length of VALS, which should also be the length of SEQ. */
2271 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2273 register Lisp_Object tail
;
2275 register EMACS_INT i
;
2276 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2280 /* Don't let vals contain any garbage when GC happens. */
2281 for (i
= 0; i
< leni
; i
++)
2284 GCPRO3 (dummy
, fn
, seq
);
2286 gcpro1
.nvars
= leni
;
2290 /* We need not explicitly protect `tail' because it is used only on lists, and
2291 1) lists are not relocated and 2) the list is marked via `seq' so will not
2294 if (VECTORP (seq
) || COMPILEDP (seq
))
2296 for (i
= 0; i
< leni
; i
++)
2298 dummy
= call1 (fn
, AREF (seq
, i
));
2303 else if (BOOL_VECTOR_P (seq
))
2305 for (i
= 0; i
< leni
; i
++)
2307 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2312 else if (STRINGP (seq
))
2316 for (i
= 0, i_byte
= 0; i
< leni
;)
2319 ptrdiff_t i_before
= i
;
2321 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2322 XSETFASTINT (dummy
, c
);
2323 dummy
= call1 (fn
, dummy
);
2325 vals
[i_before
] = dummy
;
2328 else /* Must be a list, since Flength did not get an error */
2331 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2333 dummy
= call1 (fn
, XCAR (tail
));
2343 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2344 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2345 In between each pair of results, stick in SEPARATOR. Thus, " " as
2346 SEPARATOR results in spaces between the values returned by FUNCTION.
2347 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2348 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2351 register EMACS_INT leni
;
2354 register Lisp_Object
*args
;
2355 struct gcpro gcpro1
;
2359 len
= Flength (sequence
);
2360 if (CHAR_TABLE_P (sequence
))
2361 wrong_type_argument (Qlistp
, sequence
);
2363 nargs
= leni
+ leni
- 1;
2364 if (nargs
< 0) return empty_unibyte_string
;
2366 SAFE_ALLOCA_LISP (args
, nargs
);
2369 mapcar1 (leni
, args
, function
, sequence
);
2372 for (i
= leni
- 1; i
> 0; i
--)
2373 args
[i
+ i
] = args
[i
];
2375 for (i
= 1; i
< nargs
; i
+= 2)
2376 args
[i
] = separator
;
2378 ret
= Fconcat (nargs
, args
);
2384 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2385 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2386 The result is a list just as long as SEQUENCE.
2387 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2388 (Lisp_Object function
, Lisp_Object sequence
)
2390 register Lisp_Object len
;
2391 register EMACS_INT leni
;
2392 register Lisp_Object
*args
;
2396 len
= Flength (sequence
);
2397 if (CHAR_TABLE_P (sequence
))
2398 wrong_type_argument (Qlistp
, sequence
);
2399 leni
= XFASTINT (len
);
2401 SAFE_ALLOCA_LISP (args
, leni
);
2403 mapcar1 (leni
, args
, function
, sequence
);
2405 ret
= Flist (leni
, args
);
2411 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2412 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2413 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2414 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2415 (Lisp_Object function
, Lisp_Object sequence
)
2417 register EMACS_INT leni
;
2419 leni
= XFASTINT (Flength (sequence
));
2420 if (CHAR_TABLE_P (sequence
))
2421 wrong_type_argument (Qlistp
, sequence
);
2422 mapcar1 (leni
, 0, function
, sequence
);
2427 /* This is how C code calls `yes-or-no-p' and allows the user
2430 Anything that calls this function must protect from GC! */
2433 do_yes_or_no_p (Lisp_Object prompt
)
2435 return call1 (intern ("yes-or-no-p"), prompt
);
2438 /* Anything that calls this function must protect from GC! */
2440 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2441 doc
: /* Ask user a yes-or-no question.
2442 Return t if answer is yes, and nil if the answer is no.
2443 PROMPT is the string to display to ask the question. It should end in
2444 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2446 The user must confirm the answer with RET, and can edit it until it
2449 If dialog boxes are supported, a dialog box will be used
2450 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2451 (Lisp_Object prompt
)
2453 register Lisp_Object ans
;
2454 Lisp_Object args
[2];
2455 struct gcpro gcpro1
;
2457 CHECK_STRING (prompt
);
2459 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2462 Lisp_Object pane
, menu
, obj
;
2463 redisplay_preserve_echo_area (4);
2464 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2465 Fcons (build_string ("No"), Qnil
));
2467 menu
= Fcons (prompt
, pane
);
2468 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2474 args
[1] = build_string ("(yes or no) ");
2475 prompt
= Fconcat (2, args
);
2481 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2482 Qyes_or_no_p_history
, Qnil
,
2484 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2489 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2497 message1 ("Please answer yes or no.");
2498 Fsleep_for (make_number (2), Qnil
);
2502 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2503 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2505 Each of the three load averages is multiplied by 100, then converted
2508 When USE-FLOATS is non-nil, floats will be used instead of integers.
2509 These floats are not multiplied by 100.
2511 If the 5-minute or 15-minute load averages are not available, return a
2512 shortened list, containing only those averages which are available.
2514 An error is thrown if the load average can't be obtained. In some
2515 cases making it work would require Emacs being installed setuid or
2516 setgid so that it can read kernel information, and that usually isn't
2518 (Lisp_Object use_floats
)
2521 int loads
= getloadavg (load_ave
, 3);
2522 Lisp_Object ret
= Qnil
;
2525 error ("load-average not implemented for this operating system");
2529 Lisp_Object load
= (NILP (use_floats
)
2530 ? make_number (100.0 * load_ave
[loads
])
2531 : make_float (load_ave
[loads
]));
2532 ret
= Fcons (load
, ret
);
2538 static Lisp_Object Qsubfeatures
;
2540 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2541 doc
: /* Return t if FEATURE is present in this Emacs.
2543 Use this to conditionalize execution of lisp code based on the
2544 presence or absence of Emacs or environment extensions.
2545 Use `provide' to declare that a feature is available. This function
2546 looks at the value of the variable `features'. The optional argument
2547 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2548 (Lisp_Object feature
, Lisp_Object subfeature
)
2550 register Lisp_Object tem
;
2551 CHECK_SYMBOL (feature
);
2552 tem
= Fmemq (feature
, Vfeatures
);
2553 if (!NILP (tem
) && !NILP (subfeature
))
2554 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2555 return (NILP (tem
)) ? Qnil
: Qt
;
2558 static Lisp_Object Qfuncall
;
2560 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2561 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2562 The optional argument SUBFEATURES should be a list of symbols listing
2563 particular subfeatures supported in this version of FEATURE. */)
2564 (Lisp_Object feature
, Lisp_Object subfeatures
)
2566 register Lisp_Object tem
;
2567 CHECK_SYMBOL (feature
);
2568 CHECK_LIST (subfeatures
);
2569 if (!NILP (Vautoload_queue
))
2570 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2572 tem
= Fmemq (feature
, Vfeatures
);
2574 Vfeatures
= Fcons (feature
, Vfeatures
);
2575 if (!NILP (subfeatures
))
2576 Fput (feature
, Qsubfeatures
, subfeatures
);
2577 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2579 /* Run any load-hooks for this file. */
2580 tem
= Fassq (feature
, Vafter_load_alist
);
2582 Fmapc (Qfuncall
, XCDR (tem
));
2587 /* `require' and its subroutines. */
2589 /* List of features currently being require'd, innermost first. */
2591 static Lisp_Object require_nesting_list
;
2594 require_unwind (Lisp_Object old_value
)
2596 require_nesting_list
= old_value
;
2599 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2600 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2601 If FEATURE is not a member of the list `features', then the feature
2602 is not loaded; so load the file FILENAME.
2603 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2604 and `load' will try to load this name appended with the suffix `.elc' or
2605 `.el', in that order. The name without appended suffix will not be used.
2606 See `get-load-suffixes' for the complete list of suffixes.
2607 If the optional third argument NOERROR is non-nil,
2608 then return nil if the file is not found instead of signaling an error.
2609 Normally the return value is FEATURE.
2610 The normal messages at start and end of loading FILENAME are suppressed. */)
2611 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2614 struct gcpro gcpro1
, gcpro2
;
2615 bool from_file
= load_in_progress
;
2617 CHECK_SYMBOL (feature
);
2619 /* Record the presence of `require' in this file
2620 even if the feature specified is already loaded.
2621 But not more than once in any file,
2622 and not when we aren't loading or reading from a file. */
2624 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2625 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2630 tem
= Fcons (Qrequire
, feature
);
2631 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2632 LOADHIST_ATTACH (tem
);
2634 tem
= Fmemq (feature
, Vfeatures
);
2641 /* This is to make sure that loadup.el gives a clear picture
2642 of what files are preloaded and when. */
2643 if (! NILP (Vpurify_flag
))
2644 error ("(require %s) while preparing to dump",
2645 SDATA (SYMBOL_NAME (feature
)));
2647 /* A certain amount of recursive `require' is legitimate,
2648 but if we require the same feature recursively 3 times,
2650 tem
= require_nesting_list
;
2651 while (! NILP (tem
))
2653 if (! NILP (Fequal (feature
, XCAR (tem
))))
2658 error ("Recursive `require' for feature `%s'",
2659 SDATA (SYMBOL_NAME (feature
)));
2661 /* Update the list for any nested `require's that occur. */
2662 record_unwind_protect (require_unwind
, require_nesting_list
);
2663 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2665 /* Value saved here is to be restored into Vautoload_queue */
2666 record_unwind_protect (un_autoload
, Vautoload_queue
);
2667 Vautoload_queue
= Qt
;
2669 /* Load the file. */
2670 GCPRO2 (feature
, filename
);
2671 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2672 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2675 /* If load failed entirely, return nil. */
2682 tem
= Fmemq (feature
, Vfeatures
);
2684 error ("Required feature `%s' was not provided",
2685 SDATA (SYMBOL_NAME (feature
)));
2687 /* Once loading finishes, don't undo it. */
2688 Vautoload_queue
= Qt
;
2695 /* Primitives for work of the "widget" library.
2696 In an ideal world, this section would not have been necessary.
2697 However, lisp function calls being as slow as they are, it turns
2698 out that some functions in the widget library (wid-edit.el) are the
2699 bottleneck of Widget operation. Here is their translation to C,
2700 for the sole reason of efficiency. */
2702 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2703 doc
: /* Return non-nil if PLIST has the property PROP.
2704 PLIST is a property list, which is a list of the form
2705 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2706 Unlike `plist-get', this allows you to distinguish between a missing
2707 property and a property with the value nil.
2708 The value is actually the tail of PLIST whose car is PROP. */)
2709 (Lisp_Object plist
, Lisp_Object prop
)
2711 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2714 plist
= XCDR (plist
);
2715 plist
= CDR (plist
);
2720 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2721 doc
: /* In WIDGET, set PROPERTY to VALUE.
2722 The value can later be retrieved with `widget-get'. */)
2723 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2725 CHECK_CONS (widget
);
2726 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2730 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2731 doc
: /* In WIDGET, get the value of PROPERTY.
2732 The value could either be specified when the widget was created, or
2733 later with `widget-put'. */)
2734 (Lisp_Object widget
, Lisp_Object property
)
2742 CHECK_CONS (widget
);
2743 tmp
= Fplist_member (XCDR (widget
), property
);
2749 tmp
= XCAR (widget
);
2752 widget
= Fget (tmp
, Qwidget_type
);
2756 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2757 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2758 ARGS are passed as extra arguments to the function.
2759 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2760 (ptrdiff_t nargs
, Lisp_Object
*args
)
2762 /* This function can GC. */
2763 struct gcpro gcpro1
, gcpro2
;
2766 result
= call3 (intern ("apply"),
2767 Fwidget_get (args
[0], args
[1]),
2769 Flist (nargs
- 2, args
+ 2));
2773 #ifdef HAVE_LANGINFO_CODESET
2774 #include <langinfo.h>
2777 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2778 doc
: /* Access locale data ITEM for the current C locale, if available.
2779 ITEM should be one of the following:
2781 `codeset', returning the character set as a string (locale item CODESET);
2783 `days', returning a 7-element vector of day names (locale items DAY_n);
2785 `months', returning a 12-element vector of month names (locale items MON_n);
2787 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2788 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2790 If the system can't provide such information through a call to
2791 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2793 See also Info node `(libc)Locales'.
2795 The data read from the system are decoded using `locale-coding-system'. */)
2799 #ifdef HAVE_LANGINFO_CODESET
2801 if (EQ (item
, Qcodeset
))
2803 str
= nl_langinfo (CODESET
);
2804 return build_string (str
);
2807 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2809 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2810 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2812 struct gcpro gcpro1
;
2814 synchronize_system_time_locale ();
2815 for (i
= 0; i
< 7; i
++)
2817 str
= nl_langinfo (days
[i
]);
2818 val
= build_unibyte_string (str
);
2819 /* Fixme: Is this coding system necessarily right, even if
2820 it is consistent with CODESET? If not, what to do? */
2821 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2829 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2831 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2832 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2833 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2835 struct gcpro gcpro1
;
2837 synchronize_system_time_locale ();
2838 for (i
= 0; i
< 12; i
++)
2840 str
= nl_langinfo (months
[i
]);
2841 val
= build_unibyte_string (str
);
2842 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2849 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2850 but is in the locale files. This could be used by ps-print. */
2852 else if (EQ (item
, Qpaper
))
2853 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2854 #endif /* PAPER_WIDTH */
2855 #endif /* HAVE_LANGINFO_CODESET*/
2859 /* base64 encode/decode functions (RFC 2045).
2860 Based on code from GNU recode. */
2862 #define MIME_LINE_LENGTH 76
2864 #define IS_ASCII(Character) \
2866 #define IS_BASE64(Character) \
2867 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2868 #define IS_BASE64_IGNORABLE(Character) \
2869 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2870 || (Character) == '\f' || (Character) == '\r')
2872 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2873 character or return retval if there are no characters left to
2875 #define READ_QUADRUPLET_BYTE(retval) \
2880 if (nchars_return) \
2881 *nchars_return = nchars; \
2886 while (IS_BASE64_IGNORABLE (c))
2888 /* Table of characters coding the 64 values. */
2889 static const char base64_value_to_char
[64] =
2891 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2892 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2893 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2894 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2895 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2896 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2897 '8', '9', '+', '/' /* 60-63 */
2900 /* Table of base64 values for first 128 characters. */
2901 static const short base64_char_to_value
[128] =
2903 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2904 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2905 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2906 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2907 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2908 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2909 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2910 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2911 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2912 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2913 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2914 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2915 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2918 /* The following diagram shows the logical steps by which three octets
2919 get transformed into four base64 characters.
2921 .--------. .--------. .--------.
2922 |aaaaaabb| |bbbbcccc| |ccdddddd|
2923 `--------' `--------' `--------'
2925 .--------+--------+--------+--------.
2926 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2927 `--------+--------+--------+--------'
2929 .--------+--------+--------+--------.
2930 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2931 `--------+--------+--------+--------'
2933 The octets are divided into 6 bit chunks, which are then encoded into
2934 base64 characters. */
2937 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2938 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2941 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2943 doc
: /* Base64-encode the region between BEG and END.
2944 Return the length of the encoded text.
2945 Optional third argument NO-LINE-BREAK means do not break long lines
2946 into shorter lines. */)
2947 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2950 ptrdiff_t allength
, length
;
2951 ptrdiff_t ibeg
, iend
, encoded_length
;
2952 ptrdiff_t old_pos
= PT
;
2955 validate_region (&beg
, &end
);
2957 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2958 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2959 move_gap_both (XFASTINT (beg
), ibeg
);
2961 /* We need to allocate enough room for encoding the text.
2962 We need 33 1/3% more space, plus a newline every 76
2963 characters, and then we round up. */
2964 length
= iend
- ibeg
;
2965 allength
= length
+ length
/3 + 1;
2966 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2968 encoded
= SAFE_ALLOCA (allength
);
2969 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2970 encoded
, length
, NILP (no_line_break
),
2971 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2972 if (encoded_length
> allength
)
2975 if (encoded_length
< 0)
2977 /* The encoding wasn't possible. */
2979 error ("Multibyte character in data for base64 encoding");
2982 /* Now we have encoded the region, so we insert the new contents
2983 and delete the old. (Insert first in order to preserve markers.) */
2984 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2985 insert (encoded
, encoded_length
);
2987 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2989 /* If point was outside of the region, restore it exactly; else just
2990 move to the beginning of the region. */
2991 if (old_pos
>= XFASTINT (end
))
2992 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2993 else if (old_pos
> XFASTINT (beg
))
2994 old_pos
= XFASTINT (beg
);
2997 /* We return the length of the encoded text. */
2998 return make_number (encoded_length
);
3001 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3003 doc
: /* Base64-encode STRING and return the result.
3004 Optional second argument NO-LINE-BREAK means do not break long lines
3005 into shorter lines. */)
3006 (Lisp_Object string
, Lisp_Object no_line_break
)
3008 ptrdiff_t allength
, length
, encoded_length
;
3010 Lisp_Object encoded_string
;
3013 CHECK_STRING (string
);
3015 /* We need to allocate enough room for encoding the text.
3016 We need 33 1/3% more space, plus a newline every 76
3017 characters, and then we round up. */
3018 length
= SBYTES (string
);
3019 allength
= length
+ length
/3 + 1;
3020 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3022 /* We need to allocate enough room for decoding the text. */
3023 encoded
= SAFE_ALLOCA (allength
);
3025 encoded_length
= base64_encode_1 (SSDATA (string
),
3026 encoded
, length
, NILP (no_line_break
),
3027 STRING_MULTIBYTE (string
));
3028 if (encoded_length
> allength
)
3031 if (encoded_length
< 0)
3033 /* The encoding wasn't possible. */
3035 error ("Multibyte character in data for base64 encoding");
3038 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3041 return encoded_string
;
3045 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3046 bool line_break
, bool multibyte
)
3059 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3060 if (CHAR_BYTE8_P (c
))
3061 c
= CHAR_TO_BYTE8 (c
);
3069 /* Wrap line every 76 characters. */
3073 if (counter
< MIME_LINE_LENGTH
/ 4)
3082 /* Process first byte of a triplet. */
3084 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3085 value
= (0x03 & c
) << 4;
3087 /* Process second byte of a triplet. */
3091 *e
++ = base64_value_to_char
[value
];
3099 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3100 if (CHAR_BYTE8_P (c
))
3101 c
= CHAR_TO_BYTE8 (c
);
3109 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3110 value
= (0x0f & c
) << 2;
3112 /* Process third byte of a triplet. */
3116 *e
++ = base64_value_to_char
[value
];
3123 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3124 if (CHAR_BYTE8_P (c
))
3125 c
= CHAR_TO_BYTE8 (c
);
3133 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3134 *e
++ = base64_value_to_char
[0x3f & c
];
3141 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3143 doc
: /* Base64-decode the region between BEG and END.
3144 Return the length of the decoded text.
3145 If the region can't be decoded, signal an error and don't modify the buffer. */)
3146 (Lisp_Object beg
, Lisp_Object end
)
3148 ptrdiff_t ibeg
, iend
, length
, allength
;
3150 ptrdiff_t old_pos
= PT
;
3151 ptrdiff_t decoded_length
;
3152 ptrdiff_t inserted_chars
;
3153 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3156 validate_region (&beg
, &end
);
3158 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3159 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3161 length
= iend
- ibeg
;
3163 /* We need to allocate enough room for decoding the text. If we are
3164 working on a multibyte buffer, each decoded code may occupy at
3166 allength
= multibyte
? length
* 2 : length
;
3167 decoded
= SAFE_ALLOCA (allength
);
3169 move_gap_both (XFASTINT (beg
), ibeg
);
3170 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3172 multibyte
, &inserted_chars
);
3173 if (decoded_length
> allength
)
3176 if (decoded_length
< 0)
3178 /* The decoding wasn't possible. */
3180 error ("Invalid base64 data");
3183 /* Now we have decoded the region, so we insert the new contents
3184 and delete the old. (Insert first in order to preserve markers.) */
3185 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3186 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3189 /* Delete the original text. */
3190 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3191 iend
+ decoded_length
, 1);
3193 /* If point was outside of the region, restore it exactly; else just
3194 move to the beginning of the region. */
3195 if (old_pos
>= XFASTINT (end
))
3196 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3197 else if (old_pos
> XFASTINT (beg
))
3198 old_pos
= XFASTINT (beg
);
3199 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3201 return make_number (inserted_chars
);
3204 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3206 doc
: /* Base64-decode STRING and return the result. */)
3207 (Lisp_Object string
)
3210 ptrdiff_t length
, decoded_length
;
3211 Lisp_Object decoded_string
;
3214 CHECK_STRING (string
);
3216 length
= SBYTES (string
);
3217 /* We need to allocate enough room for decoding the text. */
3218 decoded
= SAFE_ALLOCA (length
);
3220 /* The decoded result should be unibyte. */
3221 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3223 if (decoded_length
> length
)
3225 else if (decoded_length
>= 0)
3226 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3228 decoded_string
= Qnil
;
3231 if (!STRINGP (decoded_string
))
3232 error ("Invalid base64 data");
3234 return decoded_string
;
3237 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3238 MULTIBYTE, the decoded result should be in multibyte
3239 form. If NCHARS_RETURN is not NULL, store the number of produced
3240 characters in *NCHARS_RETURN. */
3243 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3244 bool multibyte
, ptrdiff_t *nchars_return
)
3246 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3249 unsigned long value
;
3250 ptrdiff_t nchars
= 0;
3254 /* Process first byte of a quadruplet. */
3256 READ_QUADRUPLET_BYTE (e
-to
);
3260 value
= base64_char_to_value
[c
] << 18;
3262 /* Process second byte of a quadruplet. */
3264 READ_QUADRUPLET_BYTE (-1);
3268 value
|= base64_char_to_value
[c
] << 12;
3270 c
= (unsigned char) (value
>> 16);
3271 if (multibyte
&& c
>= 128)
3272 e
+= BYTE8_STRING (c
, e
);
3277 /* Process third byte of a quadruplet. */
3279 READ_QUADRUPLET_BYTE (-1);
3283 READ_QUADRUPLET_BYTE (-1);
3292 value
|= base64_char_to_value
[c
] << 6;
3294 c
= (unsigned char) (0xff & value
>> 8);
3295 if (multibyte
&& c
>= 128)
3296 e
+= BYTE8_STRING (c
, e
);
3301 /* Process fourth byte of a quadruplet. */
3303 READ_QUADRUPLET_BYTE (-1);
3310 value
|= base64_char_to_value
[c
];
3312 c
= (unsigned char) (0xff & value
);
3313 if (multibyte
&& c
>= 128)
3314 e
+= BYTE8_STRING (c
, e
);
3323 /***********************************************************************
3325 ***** Hash Tables *****
3327 ***********************************************************************/
3329 /* Implemented by gerd@gnu.org. This hash table implementation was
3330 inspired by CMUCL hash tables. */
3334 1. For small tables, association lists are probably faster than
3335 hash tables because they have lower overhead.
3337 For uses of hash tables where the O(1) behavior of table
3338 operations is not a requirement, it might therefore be a good idea
3339 not to hash. Instead, we could just do a linear search in the
3340 key_and_value vector of the hash table. This could be done
3341 if a `:linear-search t' argument is given to make-hash-table. */
3343 /* Various symbols. */
3345 static Lisp_Object Qhash_table_p
;
3346 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3347 Lisp_Object Qeq
, Qequal
;
3348 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3349 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3352 /***********************************************************************
3354 ***********************************************************************/
3357 CHECK_HASH_TABLE (Lisp_Object x
)
3359 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3363 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3365 h
->key_and_value
= key_and_value
;
3368 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3373 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3375 gc_aset (h
->next
, idx
, val
);
3378 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3383 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3385 gc_aset (h
->hash
, idx
, val
);
3388 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3393 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3395 gc_aset (h
->index
, idx
, val
);
3398 /* If OBJ is a Lisp hash table, return a pointer to its struct
3399 Lisp_Hash_Table. Otherwise, signal an error. */
3401 static struct Lisp_Hash_Table
*
3402 check_hash_table (Lisp_Object obj
)
3404 CHECK_HASH_TABLE (obj
);
3405 return XHASH_TABLE (obj
);
3409 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3410 number. A number is "almost" a prime number if it is not divisible
3411 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3414 next_almost_prime (EMACS_INT n
)
3416 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3417 for (n
|= 1; ; n
+= 2)
3418 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3423 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3424 which USED[I] is non-zero. If found at index I in ARGS, set
3425 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3426 0. This function is used to extract a keyword/argument pair from
3427 a DEFUN parameter list. */
3430 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3434 for (i
= 1; i
< nargs
; i
++)
3435 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3446 /* Return a Lisp vector which has the same contents as VEC but has
3447 at least INCR_MIN more entries, where INCR_MIN is positive.
3448 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3449 than NITEMS_MAX. Entries in the resulting
3450 vector that are not copied from VEC are set to nil. */
3453 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3455 struct Lisp_Vector
*v
;
3456 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3457 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3458 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3459 ? nitems_max
: C_language_max
);
3460 eassert (VECTORP (vec
));
3461 eassert (0 < incr_min
&& -1 <= nitems_max
);
3462 old_size
= ASIZE (vec
);
3463 incr_max
= n_max
- old_size
;
3464 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3465 if (incr_max
< incr
)
3466 memory_full (SIZE_MAX
);
3467 new_size
= old_size
+ incr
;
3468 v
= allocate_vector (new_size
);
3469 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3470 for (i
= old_size
; i
< new_size
; ++i
)
3471 v
->contents
[i
] = Qnil
;
3472 XSETVECTOR (vec
, v
);
3477 /***********************************************************************
3479 ***********************************************************************/
3481 static struct hash_table_test hashtest_eq
;
3482 struct hash_table_test hashtest_eql
, hashtest_equal
;
3484 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3485 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3486 KEY2 are the same. */
3489 cmpfn_eql (struct hash_table_test
*ht
,
3493 return (FLOATP (key1
)
3495 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3499 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3500 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3501 KEY2 are the same. */
3504 cmpfn_equal (struct hash_table_test
*ht
,
3508 return !NILP (Fequal (key1
, key2
));
3512 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3513 HASH2 in hash table H using H->user_cmp_function. Value is true
3514 if KEY1 and KEY2 are the same. */
3517 cmpfn_user_defined (struct hash_table_test
*ht
,
3521 Lisp_Object args
[3];
3523 args
[0] = ht
->user_cmp_function
;
3526 return !NILP (Ffuncall (3, args
));
3530 /* Value is a hash code for KEY for use in hash table H which uses
3531 `eq' to compare keys. The hash code returned is guaranteed to fit
3532 in a Lisp integer. */
3535 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3537 return scm_ihashq (key
, MOST_POSITIVE_FIXNUM
);
3540 /* Value is a hash code for KEY for use in hash table H which uses
3541 `eql' to compare keys. The hash code returned is guaranteed to fit
3542 in a Lisp integer. */
3545 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3547 return scm_ihashv (key
, MOST_POSITIVE_FIXNUM
);
3550 /* Value is a hash code for KEY for use in hash table H which uses
3551 `equal' to compare keys. The hash code returned is guaranteed to fit
3552 in a Lisp integer. */
3555 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3557 return scm_ihash (key
, MOST_POSITIVE_FIXNUM
);
3560 /* Value is a hash code for KEY for use in hash table H which uses as
3561 user-defined function to compare keys. The hash code returned is
3562 guaranteed to fit in a Lisp integer. */
3565 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3567 Lisp_Object args
[2], hash
;
3569 args
[0] = ht
->user_hash_function
;
3571 hash
= Ffuncall (2, args
);
3572 return hashfn_eq (ht
, hash
);
3575 /* An upper bound on the size of a hash table index. It must fit in
3576 ptrdiff_t and be a valid Emacs fixnum. */
3577 #define INDEX_SIZE_BOUND \
3578 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3580 /* Create and initialize a new hash table.
3582 TEST specifies the test the hash table will use to compare keys.
3583 It must be either one of the predefined tests `eq', `eql' or
3584 `equal' or a symbol denoting a user-defined test named TEST with
3585 test and hash functions USER_TEST and USER_HASH.
3587 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3589 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3590 new size when it becomes full is computed by adding REHASH_SIZE to
3591 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3592 table's new size is computed by multiplying its old size with
3595 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3596 be resized when the ratio of (number of entries in the table) /
3597 (table size) is >= REHASH_THRESHOLD.
3599 WEAK specifies the weakness of the table. If non-nil, it must be
3600 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3603 make_hash_table (struct hash_table_test test
,
3604 Lisp_Object size
, Lisp_Object rehash_size
,
3605 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3607 struct Lisp_Hash_Table
*h
;
3609 EMACS_INT index_size
, sz
;
3613 /* Preconditions. */
3614 eassert (SYMBOLP (test
.name
));
3615 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3616 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3617 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3618 eassert (FLOATP (rehash_threshold
)
3619 && 0 < XFLOAT_DATA (rehash_threshold
)
3620 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3622 if (XFASTINT (size
) == 0)
3623 size
= make_number (1);
3625 sz
= XFASTINT (size
);
3626 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3627 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3628 ? next_almost_prime (index_float
)
3629 : INDEX_SIZE_BOUND
+ 1);
3630 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3631 error ("Hash table too large");
3633 /* Allocate a table and initialize it. */
3634 h
= allocate_hash_table ();
3636 /* Initialize hash table slots. */
3639 h
->rehash_threshold
= rehash_threshold
;
3640 h
->rehash_size
= rehash_size
;
3642 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3643 h
->hash
= Fmake_vector (size
, Qnil
);
3644 h
->next
= Fmake_vector (size
, Qnil
);
3645 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3647 /* Set up the free list. */
3648 for (i
= 0; i
< sz
- 1; ++i
)
3649 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3650 h
->next_free
= make_number (0);
3652 XSET_HASH_TABLE (table
, h
);
3653 eassert (HASH_TABLE_P (table
));
3654 eassert (XHASH_TABLE (table
) == h
);
3660 /* Return a copy of hash table H1. Keys and values are not copied,
3661 only the table itself is. */
3664 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3667 struct Lisp_Hash_Table
*h2
;
3669 h2
= allocate_hash_table ();
3671 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3672 h2
->hash
= Fcopy_sequence (h1
->hash
);
3673 h2
->next
= Fcopy_sequence (h1
->next
);
3674 h2
->index
= Fcopy_sequence (h1
->index
);
3675 XSET_HASH_TABLE (table
, h2
);
3681 /* Resize hash table H if it's too full. If H cannot be resized
3682 because it's already too large, throw an error. */
3685 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3687 if (NILP (h
->next_free
))
3689 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3690 EMACS_INT new_size
, index_size
, nsize
;
3694 if (INTEGERP (h
->rehash_size
))
3695 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3698 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3699 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3701 new_size
= float_new_size
;
3702 if (new_size
<= old_size
)
3703 new_size
= old_size
+ 1;
3706 new_size
= INDEX_SIZE_BOUND
+ 1;
3708 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3709 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3710 ? next_almost_prime (index_float
)
3711 : INDEX_SIZE_BOUND
+ 1);
3712 nsize
= max (index_size
, 2 * new_size
);
3713 if (INDEX_SIZE_BOUND
< nsize
)
3714 error ("Hash table too large to resize");
3716 #ifdef ENABLE_CHECKING
3717 if (HASH_TABLE_P (Vpurify_flag
)
3718 && XHASH_TABLE (Vpurify_flag
) == h
)
3720 Lisp_Object args
[2];
3721 args
[0] = build_string ("Growing hash table to: %d");
3722 args
[1] = make_number (new_size
);
3727 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3728 2 * (new_size
- old_size
), -1));
3729 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3730 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3731 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3733 /* Update the free list. Do it so that new entries are added at
3734 the end of the free list. This makes some operations like
3736 for (i
= old_size
; i
< new_size
- 1; ++i
)
3737 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3739 if (!NILP (h
->next_free
))
3741 Lisp_Object last
, next
;
3743 last
= h
->next_free
;
3744 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3748 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3751 XSETFASTINT (h
->next_free
, old_size
);
3754 for (i
= 0; i
< old_size
; ++i
)
3755 if (!NILP (HASH_HASH (h
, i
)))
3757 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3758 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3759 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3760 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3766 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3767 the hash code of KEY. Value is the index of the entry in H
3768 matching KEY, or -1 if not found. */
3771 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3773 EMACS_UINT hash_code
;
3774 ptrdiff_t start_of_bucket
;
3777 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3778 eassert ((hash_code
& ~INTMASK
) == 0);
3782 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3783 idx
= HASH_INDEX (h
, start_of_bucket
);
3785 /* We need not gcpro idx since it's either an integer or nil. */
3788 ptrdiff_t i
= XFASTINT (idx
);
3789 if (EQ (key
, HASH_KEY (h
, i
))
3791 && hash_code
== XUINT (HASH_HASH (h
, i
))
3792 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3794 idx
= HASH_NEXT (h
, i
);
3797 return NILP (idx
) ? -1 : XFASTINT (idx
);
3801 /* Put an entry into hash table H that associates KEY with VALUE.
3802 HASH is a previously computed hash code of KEY.
3803 Value is the index of the entry in H matching KEY. */
3806 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3809 ptrdiff_t start_of_bucket
, i
;
3811 eassert ((hash
& ~INTMASK
) == 0);
3813 /* Increment count after resizing because resizing may fail. */
3814 maybe_resize_hash_table (h
);
3817 /* Store key/value in the key_and_value vector. */
3818 i
= XFASTINT (h
->next_free
);
3819 h
->next_free
= HASH_NEXT (h
, i
);
3820 set_hash_key_slot (h
, i
, key
);
3821 set_hash_value_slot (h
, i
, value
);
3823 /* Remember its hash code. */
3824 set_hash_hash_slot (h
, i
, make_number (hash
));
3826 /* Add new entry to its collision chain. */
3827 start_of_bucket
= hash
% ASIZE (h
->index
);
3828 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3829 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3834 /* Remove the entry matching KEY from hash table H, if there is one. */
3837 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3839 EMACS_UINT hash_code
;
3840 ptrdiff_t start_of_bucket
;
3841 Lisp_Object idx
, prev
;
3843 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3844 eassert ((hash_code
& ~INTMASK
) == 0);
3845 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3846 idx
= HASH_INDEX (h
, start_of_bucket
);
3849 /* We need not gcpro idx, prev since they're either integers or nil. */
3852 ptrdiff_t i
= XFASTINT (idx
);
3854 if (EQ (key
, HASH_KEY (h
, i
))
3856 && hash_code
== XUINT (HASH_HASH (h
, i
))
3857 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3859 /* Take entry out of collision chain. */
3861 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3863 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3865 /* Clear slots in key_and_value and add the slots to
3867 set_hash_key_slot (h
, i
, Qnil
);
3868 set_hash_value_slot (h
, i
, Qnil
);
3869 set_hash_hash_slot (h
, i
, Qnil
);
3870 set_hash_next_slot (h
, i
, h
->next_free
);
3871 h
->next_free
= make_number (i
);
3873 eassert (h
->count
>= 0);
3879 idx
= HASH_NEXT (h
, i
);
3885 /* Clear hash table H. */
3888 hash_clear (struct Lisp_Hash_Table
*h
)
3892 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3894 for (i
= 0; i
< size
; ++i
)
3896 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3897 set_hash_key_slot (h
, i
, Qnil
);
3898 set_hash_value_slot (h
, i
, Qnil
);
3899 set_hash_hash_slot (h
, i
, Qnil
);
3902 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3903 ASET (h
->index
, i
, Qnil
);
3905 h
->next_free
= make_number (0);
3912 /***********************************************************************
3913 Hash Code Computation
3914 ***********************************************************************/
3916 /* Return a hash for string PTR which has length LEN. The hash value
3917 can be any EMACS_UINT value. */
3920 hash_string (char const *ptr
, ptrdiff_t len
)
3922 char const *p
= ptr
;
3923 char const *end
= p
+ len
;
3925 EMACS_UINT hash
= 0;
3930 hash
= sxhash_combine (hash
, c
);
3936 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
3937 structure. Value is an unsigned integer clipped to INTMASK. */
3940 sxhash (Lisp_Object obj
, int depth
)
3942 return scm_ihash (obj
, MOST_POSITIVE_FIXNUM
);
3947 /***********************************************************************
3949 ***********************************************************************/
3952 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
3953 doc
: /* Compute a hash code for OBJ and return it as integer. */)
3956 EMACS_UINT hash
= sxhash (obj
, 0);
3957 return make_number (hash
);
3961 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
3962 doc
: /* Create and return a new hash table.
3964 Arguments are specified as keyword/argument pairs. The following
3965 arguments are defined:
3967 :test TEST -- TEST must be a symbol that specifies how to compare
3968 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
3969 `equal'. User-supplied test and hash functions can be specified via
3970 `define-hash-table-test'.
3972 :size SIZE -- A hint as to how many elements will be put in the table.
3975 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
3976 fills up. If REHASH-SIZE is an integer, increase the size by that
3977 amount. If it is a float, it must be > 1.0, and the new size is the
3978 old size multiplied by that factor. Default is 1.5.
3980 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
3981 Resize the hash table when the ratio (number of entries / table size)
3982 is greater than or equal to THRESHOLD. Default is 0.8.
3984 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
3985 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
3986 returned is a weak table. Key/value pairs are removed from a weak
3987 hash table when there are no non-weak references pointing to their
3988 key, value, one of key or value, or both key and value, depending on
3989 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
3992 usage: (make-hash-table &rest KEYWORD-ARGS) */)
3993 (ptrdiff_t nargs
, Lisp_Object
*args
)
3995 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3996 struct hash_table_test testdesc
;
4000 /* The vector `used' is used to keep track of arguments that
4001 have been consumed. */
4002 used
= alloca (nargs
* sizeof *used
);
4003 memset (used
, 0, nargs
* sizeof *used
);
4005 /* See if there's a `:test TEST' among the arguments. */
4006 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4007 test
= i
? args
[i
] : Qeql
;
4009 testdesc
= hashtest_eq
;
4010 else if (EQ (test
, Qeql
))
4011 testdesc
= hashtest_eql
;
4012 else if (EQ (test
, Qequal
))
4013 testdesc
= hashtest_equal
;
4016 /* See if it is a user-defined test. */
4019 prop
= Fget (test
, Qhash_table_test
);
4020 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4021 signal_error ("Invalid hash table test", test
);
4022 testdesc
.name
= test
;
4023 testdesc
.user_cmp_function
= XCAR (prop
);
4024 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4025 testdesc
.hashfn
= hashfn_user_defined
;
4026 testdesc
.cmpfn
= cmpfn_user_defined
;
4029 /* See if there's a `:size SIZE' argument. */
4030 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4031 size
= i
? args
[i
] : Qnil
;
4033 size
= make_number (DEFAULT_HASH_SIZE
);
4034 else if (!INTEGERP (size
) || XINT (size
) < 0)
4035 signal_error ("Invalid hash table size", size
);
4037 /* Look for `:rehash-size SIZE'. */
4038 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4039 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4040 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4041 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4042 signal_error ("Invalid hash table rehash size", rehash_size
);
4044 /* Look for `:rehash-threshold THRESHOLD'. */
4045 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4046 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4047 if (! (FLOATP (rehash_threshold
)
4048 && 0 < XFLOAT_DATA (rehash_threshold
)
4049 && XFLOAT_DATA (rehash_threshold
) <= 1))
4050 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4052 /* Look for `:weakness WEAK'. */
4053 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4054 weak
= i
? args
[i
] : Qnil
;
4056 weak
= Qkey_and_value
;
4059 && !EQ (weak
, Qvalue
)
4060 && !EQ (weak
, Qkey_or_value
)
4061 && !EQ (weak
, Qkey_and_value
))
4062 signal_error ("Invalid hash table weakness", weak
);
4064 /* Now, all args should have been used up, or there's a problem. */
4065 for (i
= 0; i
< nargs
; ++i
)
4067 signal_error ("Invalid argument list", args
[i
]);
4069 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4073 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4074 doc
: /* Return a copy of hash table TABLE. */)
4077 return copy_hash_table (check_hash_table (table
));
4081 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4082 doc
: /* Return the number of elements in TABLE. */)
4085 return make_number (check_hash_table (table
)->count
);
4089 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4090 Shash_table_rehash_size
, 1, 1, 0,
4091 doc
: /* Return the current rehash size of TABLE. */)
4094 return check_hash_table (table
)->rehash_size
;
4098 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4099 Shash_table_rehash_threshold
, 1, 1, 0,
4100 doc
: /* Return the current rehash threshold of TABLE. */)
4103 return check_hash_table (table
)->rehash_threshold
;
4107 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4108 doc
: /* Return the size of TABLE.
4109 The size can be used as an argument to `make-hash-table' to create
4110 a hash table than can hold as many elements as TABLE holds
4111 without need for resizing. */)
4114 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4115 return make_number (HASH_TABLE_SIZE (h
));
4119 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4120 doc
: /* Return the test TABLE uses. */)
4123 return check_hash_table (table
)->test
.name
;
4127 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4129 doc
: /* Return the weakness of TABLE. */)
4132 return check_hash_table (table
)->weak
;
4136 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4137 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4140 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4144 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4145 doc
: /* Clear hash table TABLE and return it. */)
4148 hash_clear (check_hash_table (table
));
4149 /* Be compatible with XEmacs. */
4154 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4155 doc
: /* Look up KEY in TABLE and return its associated value.
4156 If KEY is not found, return DFLT which defaults to nil. */)
4157 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4159 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4160 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4161 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4165 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4166 doc
: /* Associate KEY with VALUE in hash table TABLE.
4167 If KEY is already present in table, replace its current value with
4168 VALUE. In any case, return VALUE. */)
4169 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4171 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4175 i
= hash_lookup (h
, key
, &hash
);
4177 set_hash_value_slot (h
, i
, value
);
4179 hash_put (h
, key
, value
, hash
);
4185 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4186 doc
: /* Remove KEY from TABLE. */)
4187 (Lisp_Object key
, Lisp_Object table
)
4189 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4190 hash_remove_from_table (h
, key
);
4195 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4196 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4197 FUNCTION is called with two arguments, KEY and VALUE.
4198 `maphash' always returns nil. */)
4199 (Lisp_Object function
, Lisp_Object table
)
4201 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4202 Lisp_Object args
[3];
4205 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4206 if (!NILP (HASH_HASH (h
, i
)))
4209 args
[1] = HASH_KEY (h
, i
);
4210 args
[2] = HASH_VALUE (h
, i
);
4218 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4219 Sdefine_hash_table_test
, 3, 3, 0,
4220 doc
: /* Define a new hash table test with name NAME, a symbol.
4222 In hash tables created with NAME specified as test, use TEST to
4223 compare keys, and HASH for computing hash codes of keys.
4225 TEST must be a function taking two arguments and returning non-nil if
4226 both arguments are the same. HASH must be a function taking one
4227 argument and returning an object that is the hash code of the argument.
4228 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4229 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4230 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4232 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4237 /************************************************************************
4238 MD5, SHA-1, and SHA-2
4239 ************************************************************************/
4246 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4249 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4250 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4254 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4255 register EMACS_INT b
, e
;
4256 register struct buffer
*bp
;
4259 void *(*hash_func
) (const char *, size_t, void *);
4262 CHECK_SYMBOL (algorithm
);
4264 if (STRINGP (object
))
4266 if (NILP (coding_system
))
4268 /* Decide the coding-system to encode the data with. */
4270 if (STRING_MULTIBYTE (object
))
4271 /* use default, we can't guess correct value */
4272 coding_system
= preferred_coding_system ();
4274 coding_system
= Qraw_text
;
4277 if (NILP (Fcoding_system_p (coding_system
)))
4279 /* Invalid coding system. */
4281 if (!NILP (noerror
))
4282 coding_system
= Qraw_text
;
4284 xsignal1 (Qcoding_system_error
, coding_system
);
4287 if (STRING_MULTIBYTE (object
))
4288 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4290 size
= SCHARS (object
);
4291 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4293 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4294 end_byte
= (end_char
== size
4296 : string_char_to_byte (object
, end_char
));
4302 record_unwind_current_buffer ();
4304 CHECK_BUFFER (object
);
4306 bp
= XBUFFER (object
);
4307 set_buffer_internal (bp
);
4313 CHECK_NUMBER_COERCE_MARKER (start
);
4321 CHECK_NUMBER_COERCE_MARKER (end
);
4326 temp
= b
, b
= e
, e
= temp
;
4328 if (!(BEGV
<= b
&& e
<= ZV
))
4329 args_out_of_range (start
, end
);
4331 if (NILP (coding_system
))
4333 /* Decide the coding-system to encode the data with.
4334 See fileio.c:Fwrite-region */
4336 if (!NILP (Vcoding_system_for_write
))
4337 coding_system
= Vcoding_system_for_write
;
4340 bool force_raw_text
= 0;
4342 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4343 if (NILP (coding_system
)
4344 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4346 coding_system
= Qnil
;
4347 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4351 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4353 /* Check file-coding-system-alist. */
4354 Lisp_Object args
[4], val
;
4356 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4357 args
[3] = Fbuffer_file_name (object
);
4358 val
= Ffind_operation_coding_system (4, args
);
4359 if (CONSP (val
) && !NILP (XCDR (val
)))
4360 coding_system
= XCDR (val
);
4363 if (NILP (coding_system
)
4364 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4366 /* If we still have not decided a coding system, use the
4367 default value of buffer-file-coding-system. */
4368 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4372 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4373 /* Confirm that VAL can surely encode the current region. */
4374 coding_system
= call4 (Vselect_safe_coding_system_function
,
4375 make_number (b
), make_number (e
),
4376 coding_system
, Qnil
);
4379 coding_system
= Qraw_text
;
4382 if (NILP (Fcoding_system_p (coding_system
)))
4384 /* Invalid coding system. */
4386 if (!NILP (noerror
))
4387 coding_system
= Qraw_text
;
4389 xsignal1 (Qcoding_system_error
, coding_system
);
4393 object
= make_buffer_string (b
, e
, 0);
4396 if (STRING_MULTIBYTE (object
))
4397 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4399 end_byte
= SBYTES (object
);
4402 if (EQ (algorithm
, Qmd5
))
4404 digest_size
= MD5_DIGEST_SIZE
;
4405 hash_func
= md5_buffer
;
4407 else if (EQ (algorithm
, Qsha1
))
4409 digest_size
= SHA1_DIGEST_SIZE
;
4410 hash_func
= sha1_buffer
;
4412 else if (EQ (algorithm
, Qsha224
))
4414 digest_size
= SHA224_DIGEST_SIZE
;
4415 hash_func
= sha224_buffer
;
4417 else if (EQ (algorithm
, Qsha256
))
4419 digest_size
= SHA256_DIGEST_SIZE
;
4420 hash_func
= sha256_buffer
;
4422 else if (EQ (algorithm
, Qsha384
))
4424 digest_size
= SHA384_DIGEST_SIZE
;
4425 hash_func
= sha384_buffer
;
4427 else if (EQ (algorithm
, Qsha512
))
4429 digest_size
= SHA512_DIGEST_SIZE
;
4430 hash_func
= sha512_buffer
;
4433 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4435 /* allocate 2 x digest_size so that it can be re-used to hold the
4437 digest
= make_uninit_string (digest_size
* 2);
4439 hash_func (SSDATA (object
) + start_byte
,
4440 end_byte
- start_byte
,
4445 unsigned char *p
= SDATA (digest
);
4446 for (i
= digest_size
- 1; i
>= 0; i
--)
4448 static char const hexdigit
[16] = "0123456789abcdef";
4450 p
[2 * i
] = hexdigit
[p_i
>> 4];
4451 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4456 return make_unibyte_string (SSDATA (digest
), digest_size
);
4459 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4460 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4462 A message digest is a cryptographic checksum of a document, and the
4463 algorithm to calculate it is defined in RFC 1321.
4465 The two optional arguments START and END are character positions
4466 specifying for which part of OBJECT the message digest should be
4467 computed. If nil or omitted, the digest is computed for the whole
4470 The MD5 message digest is computed from the result of encoding the
4471 text in a coding system, not directly from the internal Emacs form of
4472 the text. The optional fourth argument CODING-SYSTEM specifies which
4473 coding system to encode the text with. It should be the same coding
4474 system that you used or will use when actually writing the text into a
4477 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4478 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4479 system would be chosen by default for writing this text into a file.
4481 If OBJECT is a string, the most preferred coding system (see the
4482 command `prefer-coding-system') is used.
4484 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4485 guesswork fails. Normally, an error is signaled in such case. */)
4486 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4488 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4491 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4492 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4493 ALGORITHM is a symbol specifying the hash to use:
4494 md5, sha1, sha224, sha256, sha384 or sha512.
4496 The two optional arguments START and END are positions specifying for
4497 which part of OBJECT to compute the hash. If nil or omitted, uses the
4500 If BINARY is non-nil, returns a string in binary form. */)
4501 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4503 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4506 DEFUN ("eval-scheme", Feval_scheme
, Seval_scheme
, 1, 1,
4508 doc
: /* Evaluate a string containing a Scheme expression. */)
4509 (Lisp_Object string
)
4513 CHECK_STRING (string
);
4515 tem
= scm_c_eval_string (SSDATA (string
));
4516 return (INTERACTIVE
? Fprin1 (tem
, Qt
) : tem
);
4520 init_fns_once (void)
4522 compare_text_properties
= scm_make_fluid ();
4523 scm_set_smob_equalp (lisp_misc_tag
, misc_equal_p
);
4524 scm_set_smob_equalp (lisp_string_tag
, string_equal_p
);
4525 scm_set_smob_equalp (lisp_vectorlike_tag
, vectorlike_equal_p
);
4533 DEFSYM (Qmd5
, "md5");
4534 DEFSYM (Qsha1
, "sha1");
4535 DEFSYM (Qsha224
, "sha224");
4536 DEFSYM (Qsha256
, "sha256");
4537 DEFSYM (Qsha384
, "sha384");
4538 DEFSYM (Qsha512
, "sha512");
4540 /* Hash table stuff. */
4541 DEFSYM (Qhash_table_p
, "hash-table-p");
4543 DEFSYM (Qeql
, "eql");
4544 DEFSYM (Qequal
, "equal");
4545 DEFSYM (QCtest
, ":test");
4546 DEFSYM (QCsize
, ":size");
4547 DEFSYM (QCrehash_size
, ":rehash-size");
4548 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4549 DEFSYM (QCweakness
, ":weakness");
4550 DEFSYM (Qkey
, "key");
4551 DEFSYM (Qvalue
, "value");
4552 DEFSYM (Qhash_table_test
, "hash-table-test");
4553 DEFSYM (Qkey_or_value
, "key-or-value");
4554 DEFSYM (Qkey_and_value
, "key-and-value");
4556 DEFSYM (Qstring_lessp
, "string-lessp");
4557 DEFSYM (Qprovide
, "provide");
4558 DEFSYM (Qrequire
, "require");
4559 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4560 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4561 DEFSYM (Qwidget_type
, "widget-type");
4563 staticpro (&string_char_byte_cache_string
);
4564 string_char_byte_cache_string
= Qnil
;
4566 require_nesting_list
= Qnil
;
4567 staticpro (&require_nesting_list
);
4569 Fset (Qyes_or_no_p_history
, Qnil
);
4571 DEFVAR_LISP ("features", Vfeatures
,
4572 doc
: /* A list of symbols which are the features of the executing Emacs.
4573 Used by `featurep' and `require', and altered by `provide'. */);
4574 Vfeatures
= list1 (intern_c_string ("emacs"));
4575 DEFSYM (Qsubfeatures
, "subfeatures");
4576 DEFSYM (Qfuncall
, "funcall");
4578 #ifdef HAVE_LANGINFO_CODESET
4579 DEFSYM (Qcodeset
, "codeset");
4580 DEFSYM (Qdays
, "days");
4581 DEFSYM (Qmonths
, "months");
4582 DEFSYM (Qpaper
, "paper");
4583 #endif /* HAVE_LANGINFO_CODESET */
4585 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4586 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4587 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4588 invoked by mouse clicks and mouse menu items.
4590 On some platforms, file selection dialogs are also enabled if this is
4594 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4595 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4596 This applies to commands from menus and tool bar buttons even when
4597 they are initiated from the keyboard. If `use-dialog-box' is nil,
4598 that disables the use of a file dialog, regardless of the value of
4600 use_file_dialog
= 1;
4602 hashtest_eq
.name
= Qeq
;
4603 hashtest_eq
.user_hash_function
= Qnil
;
4604 hashtest_eq
.user_cmp_function
= Qnil
;
4605 hashtest_eq
.cmpfn
= 0;
4606 hashtest_eq
.hashfn
= hashfn_eq
;
4608 hashtest_eql
.name
= Qeql
;
4609 hashtest_eql
.user_hash_function
= Qnil
;
4610 hashtest_eql
.user_cmp_function
= Qnil
;
4611 hashtest_eql
.cmpfn
= cmpfn_eql
;
4612 hashtest_eql
.hashfn
= hashfn_eql
;
4614 hashtest_equal
.name
= Qequal
;
4615 hashtest_equal
.user_hash_function
= Qnil
;
4616 hashtest_equal
.user_cmp_function
= Qnil
;
4617 hashtest_equal
.cmpfn
= cmpfn_equal
;
4618 hashtest_equal
.hashfn
= hashfn_equal
;