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
);
1078 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1079 doc
: /* Return a copy of ALIST.
1080 This is an alist which represents the same mapping from objects to objects,
1081 but does not share the alist structure with ALIST.
1082 The objects mapped (cars and cdrs of elements of the alist)
1083 are shared, however.
1084 Elements of ALIST that are not conses are also shared. */)
1087 register Lisp_Object tem
;
1092 alist
= concat (1, &alist
, concat_cons
, 0);
1093 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1095 register Lisp_Object car
;
1099 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1104 /* Check that ARRAY can have a valid subarray [FROM..TO),
1105 given that its size is SIZE.
1106 If FROM is nil, use 0; if TO is nil, use SIZE.
1107 Count negative values backwards from the end.
1108 Set *IFROM and *ITO to the two indexes used. */
1111 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1112 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1116 if (INTEGERP (from
))
1122 else if (NILP (from
))
1125 wrong_type_argument (Qintegerp
, from
);
1136 wrong_type_argument (Qintegerp
, to
);
1138 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1139 args_out_of_range_3 (array
, from
, to
);
1145 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1146 doc
: /* Return a new string whose contents are a substring of STRING.
1147 The returned string consists of the characters between index FROM
1148 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1149 zero-indexed: 0 means the first character of STRING. Negative values
1150 are counted from the end of STRING. If TO is nil, the substring runs
1151 to the end of STRING.
1153 The STRING argument may also be a vector. In that case, the return
1154 value is a new vector that contains the elements between index FROM
1155 \(inclusive) and index TO (exclusive) of that vector argument.
1157 With one argument, just copy STRING (with properties, if any). */)
1158 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1161 ptrdiff_t size
, ifrom
, ito
;
1163 if (STRINGP (string
))
1164 size
= SCHARS (string
);
1165 else if (VECTORP (string
))
1166 size
= ASIZE (string
);
1168 wrong_type_argument (Qarrayp
, string
);
1170 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1172 if (STRINGP (string
))
1175 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1177 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1178 res
= make_specified_string (SSDATA (string
) + from_byte
,
1179 ito
- ifrom
, to_byte
- from_byte
,
1180 STRING_MULTIBYTE (string
));
1181 copy_text_properties (make_number (ifrom
), make_number (ito
),
1182 string
, make_number (0), res
, Qnil
);
1185 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1191 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1192 doc
: /* Return a substring of STRING, without text properties.
1193 It starts at index FROM and ends before TO.
1194 TO may be nil or omitted; then the substring runs to the end of STRING.
1195 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1196 If FROM or TO is negative, it counts from the end.
1198 With one argument, just copy STRING without its properties. */)
1199 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1201 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1203 CHECK_STRING (string
);
1205 size
= SCHARS (string
);
1206 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1208 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1210 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1211 return make_specified_string (SSDATA (string
) + from_byte
,
1212 to_char
- from_char
, to_byte
- from_byte
,
1213 STRING_MULTIBYTE (string
));
1216 /* Extract a substring of STRING, giving start and end positions
1217 both in characters and in bytes. */
1220 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1221 ptrdiff_t to
, ptrdiff_t to_byte
)
1226 CHECK_VECTOR_OR_STRING (string
);
1228 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1230 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1231 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1233 if (STRINGP (string
))
1235 res
= make_specified_string (SSDATA (string
) + from_byte
,
1236 to
- from
, to_byte
- from_byte
,
1237 STRING_MULTIBYTE (string
));
1238 copy_text_properties (make_number (from
), make_number (to
),
1239 string
, make_number (0), res
, Qnil
);
1242 res
= Fvector (to
- from
, aref_addr (string
, from
));
1247 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1248 doc
: /* Take cdr N times on LIST, return the result. */)
1249 (Lisp_Object n
, Lisp_Object list
)
1254 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1257 CHECK_LIST_CONS (list
, list
);
1263 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1264 doc
: /* Return the Nth element of LIST.
1265 N counts from zero. If LIST is not that long, nil is returned. */)
1266 (Lisp_Object n
, Lisp_Object list
)
1268 return Fcar (Fnthcdr (n
, list
));
1271 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1272 doc
: /* Return element of SEQUENCE at index N. */)
1273 (register Lisp_Object sequence
, Lisp_Object n
)
1276 if (CONSP (sequence
) || NILP (sequence
))
1277 return Fcar (Fnthcdr (n
, sequence
));
1279 /* Faref signals a "not array" error, so check here. */
1280 CHECK_ARRAY (sequence
, Qsequencep
);
1281 return Faref (sequence
, n
);
1284 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1285 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1286 The value is actually the tail of LIST whose car is ELT. */)
1287 (register Lisp_Object elt
, Lisp_Object list
)
1289 register Lisp_Object tail
;
1290 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1292 register Lisp_Object tem
;
1293 CHECK_LIST_CONS (tail
, list
);
1295 if (! NILP (Fequal (elt
, tem
)))
1302 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1303 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1304 The value is actually the tail of LIST whose car is ELT. */)
1305 (register Lisp_Object elt
, Lisp_Object list
)
1309 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1313 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1317 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1328 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1329 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1330 The value is actually the tail of LIST whose car is ELT. */)
1331 (register Lisp_Object elt
, Lisp_Object list
)
1333 register Lisp_Object tail
;
1335 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1337 register Lisp_Object tem
;
1338 CHECK_LIST_CONS (tail
, list
);
1340 if (!NILP (Feql (elt
, tem
)))
1347 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1348 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1349 The value is actually the first element of LIST whose car is KEY.
1350 Elements of LIST that are not conses are ignored. */)
1351 (Lisp_Object key
, Lisp_Object list
)
1356 || (CONSP (XCAR (list
))
1357 && EQ (XCAR (XCAR (list
)), key
)))
1362 || (CONSP (XCAR (list
))
1363 && EQ (XCAR (XCAR (list
)), key
)))
1368 || (CONSP (XCAR (list
))
1369 && EQ (XCAR (XCAR (list
)), key
)))
1379 /* Like Fassq but never report an error and do not allow quits.
1380 Use only on lists known never to be circular. */
1383 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1386 && (!CONSP (XCAR (list
))
1387 || !EQ (XCAR (XCAR (list
)), key
)))
1390 return CAR_SAFE (list
);
1393 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1394 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1395 The value is actually the first element of LIST whose car equals KEY. */)
1396 (Lisp_Object key
, Lisp_Object list
)
1403 || (CONSP (XCAR (list
))
1404 && (car
= XCAR (XCAR (list
)),
1405 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1410 || (CONSP (XCAR (list
))
1411 && (car
= XCAR (XCAR (list
)),
1412 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1417 || (CONSP (XCAR (list
))
1418 && (car
= XCAR (XCAR (list
)),
1419 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1429 /* Like Fassoc but never report an error and do not allow quits.
1430 Use only on lists known never to be circular. */
1433 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1436 && (!CONSP (XCAR (list
))
1437 || (!EQ (XCAR (XCAR (list
)), key
)
1438 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1441 return CONSP (list
) ? XCAR (list
) : Qnil
;
1444 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1445 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1446 The value is actually the first element of LIST whose cdr is KEY. */)
1447 (register Lisp_Object key
, Lisp_Object list
)
1452 || (CONSP (XCAR (list
))
1453 && EQ (XCDR (XCAR (list
)), key
)))
1458 || (CONSP (XCAR (list
))
1459 && EQ (XCDR (XCAR (list
)), key
)))
1464 || (CONSP (XCAR (list
))
1465 && EQ (XCDR (XCAR (list
)), key
)))
1475 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1476 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1477 The value is actually the first element of LIST whose cdr equals KEY. */)
1478 (Lisp_Object key
, Lisp_Object list
)
1485 || (CONSP (XCAR (list
))
1486 && (cdr
= XCDR (XCAR (list
)),
1487 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1492 || (CONSP (XCAR (list
))
1493 && (cdr
= XCDR (XCAR (list
)),
1494 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1499 || (CONSP (XCAR (list
))
1500 && (cdr
= XCDR (XCAR (list
)),
1501 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1511 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1512 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1513 More precisely, this function skips any members `eq' to ELT at the
1514 front of LIST, then removes members `eq' to ELT from the remaining
1515 sublist by modifying its list structure, then returns the resulting
1518 Write `(setq foo (delq element foo))' to be sure of correctly changing
1519 the value of a list `foo'. */)
1520 (register Lisp_Object elt
, Lisp_Object list
)
1522 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1525 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1527 Lisp_Object tem
= XCAR (tail
);
1533 Fsetcdr (prev
, XCDR (tail
));
1541 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1542 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1543 SEQ must be a sequence (i.e. a list, a vector, or a string).
1544 The return value is a sequence of the same type.
1546 If SEQ is a list, this behaves like `delq', except that it compares
1547 with `equal' instead of `eq'. In particular, it may remove elements
1548 by altering the list structure.
1550 If SEQ is not a list, deletion is never performed destructively;
1551 instead this function creates and returns a new vector or string.
1553 Write `(setq foo (delete element foo))' to be sure of correctly
1554 changing the value of a sequence `foo'. */)
1555 (Lisp_Object elt
, Lisp_Object seq
)
1561 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1562 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1565 if (n
!= ASIZE (seq
))
1567 struct Lisp_Vector
*p
= allocate_vector (n
);
1569 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1570 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1571 p
->contents
[n
++] = AREF (seq
, i
);
1573 XSETVECTOR (seq
, p
);
1576 else if (STRINGP (seq
))
1578 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1581 for (i
= nchars
= nbytes
= ibyte
= 0;
1583 ++i
, ibyte
+= cbytes
)
1585 if (STRING_MULTIBYTE (seq
))
1587 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1588 cbytes
= CHAR_BYTES (c
);
1596 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1603 if (nchars
!= SCHARS (seq
))
1607 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1608 if (!STRING_MULTIBYTE (seq
))
1609 STRING_SET_UNIBYTE (tem
);
1611 for (i
= nchars
= nbytes
= ibyte
= 0;
1613 ++i
, ibyte
+= cbytes
)
1615 if (STRING_MULTIBYTE (seq
))
1617 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1618 cbytes
= CHAR_BYTES (c
);
1626 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1628 unsigned char *from
= SDATA (seq
) + ibyte
;
1629 unsigned char *to
= SDATA (tem
) + nbytes
;
1635 for (n
= cbytes
; n
--; )
1645 Lisp_Object tail
, prev
;
1647 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1649 CHECK_LIST_CONS (tail
, seq
);
1651 if (!NILP (Fequal (elt
, XCAR (tail
))))
1656 Fsetcdr (prev
, XCDR (tail
));
1667 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1668 doc
: /* Reverse order of items in a list, vector or string SEQ.
1669 If SEQ is a list, it should be nil-terminated.
1670 This function may destructively modify SEQ to produce the value. */)
1675 else if (STRINGP (seq
))
1676 return Freverse (seq
);
1677 else if (CONSP (seq
))
1679 Lisp_Object prev
, tail
, next
;
1681 for (prev
= Qnil
, tail
= seq
; !NILP (tail
); tail
= next
)
1684 CHECK_LIST_CONS (tail
, tail
);
1686 Fsetcdr (tail
, prev
);
1691 else if (VECTORP (seq
))
1693 ptrdiff_t i
, size
= ASIZE (seq
);
1695 for (i
= 0; i
< size
/ 2; i
++)
1697 Lisp_Object tem
= AREF (seq
, i
);
1698 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1699 ASET (seq
, size
- i
- 1, tem
);
1702 else if (BOOL_VECTOR_P (seq
))
1704 ptrdiff_t i
, size
= bool_vector_size (seq
);
1706 for (i
= 0; i
< size
/ 2; i
++)
1708 bool tem
= bool_vector_bitref (seq
, i
);
1709 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1710 bool_vector_set (seq
, size
- i
- 1, tem
);
1714 wrong_type_argument (Qarrayp
, seq
);
1718 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1719 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1720 See also the function `nreverse', which is used more often. */)
1727 else if (CONSP (seq
))
1729 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1732 new = Fcons (XCAR (seq
), new);
1734 CHECK_LIST_END (seq
, seq
);
1736 else if (VECTORP (seq
))
1738 ptrdiff_t i
, size
= ASIZE (seq
);
1740 new = make_uninit_vector (size
);
1741 for (i
= 0; i
< size
; i
++)
1742 ASET (new, i
, AREF (seq
, size
- i
- 1));
1744 else if (BOOL_VECTOR_P (seq
))
1747 EMACS_INT nbits
= bool_vector_size (seq
);
1749 new = make_uninit_bool_vector (nbits
);
1750 for (i
= 0; i
< nbits
; i
++)
1751 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1753 else if (STRINGP (seq
))
1755 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1761 new = make_uninit_string (size
);
1762 for (i
= 0; i
< size
; i
++)
1763 SSET (new, i
, SREF (seq
, size
- i
- 1));
1767 unsigned char *p
, *q
;
1769 new = make_uninit_multibyte_string (size
, bytes
);
1770 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1771 while (q
> SDATA (new))
1775 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1777 CHAR_STRING (ch
, q
);
1782 wrong_type_argument (Qsequencep
, seq
);
1786 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1787 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1788 Returns the sorted list. LIST is modified by side effects.
1789 PREDICATE is called with two elements of LIST, and should return non-nil
1790 if the first element should sort before the second. */)
1791 (Lisp_Object list
, Lisp_Object predicate
)
1793 Lisp_Object front
, back
;
1794 register Lisp_Object len
, tem
;
1795 struct gcpro gcpro1
, gcpro2
;
1799 len
= Flength (list
);
1800 length
= XINT (len
);
1804 XSETINT (len
, (length
/ 2) - 1);
1805 tem
= Fnthcdr (len
, list
);
1807 Fsetcdr (tem
, Qnil
);
1809 GCPRO2 (front
, back
);
1810 front
= Fsort (front
, predicate
);
1811 back
= Fsort (back
, predicate
);
1813 return merge (front
, back
, predicate
);
1817 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1820 register Lisp_Object tail
;
1822 register Lisp_Object l1
, l2
;
1823 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1830 /* It is sufficient to protect org_l1 and org_l2.
1831 When l1 and l2 are updated, we copy the new values
1832 back into the org_ vars. */
1833 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1853 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1869 Fsetcdr (tail
, tem
);
1875 /* This does not check for quits. That is safe since it must terminate. */
1877 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1878 doc
: /* Extract a value from a property list.
1879 PLIST is a property list, which is a list of the form
1880 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1881 corresponding to the given PROP, or nil if PROP is not one of the
1882 properties on the list. This function never signals an error. */)
1883 (Lisp_Object plist
, Lisp_Object prop
)
1885 Lisp_Object tail
, halftail
;
1887 /* halftail is used to detect circular lists. */
1888 tail
= halftail
= plist
;
1889 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1891 if (EQ (prop
, XCAR (tail
)))
1892 return XCAR (XCDR (tail
));
1894 tail
= XCDR (XCDR (tail
));
1895 halftail
= XCDR (halftail
);
1896 if (EQ (tail
, halftail
))
1903 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1904 doc
: /* Return the value of SYMBOL's PROPNAME property.
1905 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1906 (Lisp_Object symbol
, Lisp_Object propname
)
1908 CHECK_SYMBOL (symbol
);
1909 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1912 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1913 doc
: /* Change value in PLIST of PROP to VAL.
1914 PLIST is a property list, which is a list of the form
1915 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1916 If PROP is already a property on the list, its value is set to VAL,
1917 otherwise the new PROP VAL pair is added. The new plist is returned;
1918 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1919 The PLIST is modified by side effects. */)
1920 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1922 register Lisp_Object tail
, prev
;
1923 Lisp_Object newcell
;
1925 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1926 tail
= XCDR (XCDR (tail
)))
1928 if (EQ (prop
, XCAR (tail
)))
1930 Fsetcar (XCDR (tail
), val
);
1937 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1941 Fsetcdr (XCDR (prev
), newcell
);
1945 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1946 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1947 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1948 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1950 CHECK_SYMBOL (symbol
);
1952 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1956 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1957 doc
: /* Extract a value from a property list, comparing with `equal'.
1958 PLIST is a property list, which is a list of the form
1959 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1960 corresponding to the given PROP, or nil if PROP is not
1961 one of the properties on the list. */)
1962 (Lisp_Object plist
, Lisp_Object prop
)
1967 CONSP (tail
) && CONSP (XCDR (tail
));
1968 tail
= XCDR (XCDR (tail
)))
1970 if (! NILP (Fequal (prop
, XCAR (tail
))))
1971 return XCAR (XCDR (tail
));
1976 CHECK_LIST_END (tail
, prop
);
1981 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1982 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1983 PLIST is a property list, which is a list of the form
1984 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1985 If PROP is already a property on the list, its value is set to VAL,
1986 otherwise the new PROP VAL pair is added. The new plist is returned;
1987 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1988 The PLIST is modified by side effects. */)
1989 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1991 register Lisp_Object tail
, prev
;
1992 Lisp_Object newcell
;
1994 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1995 tail
= XCDR (XCDR (tail
)))
1997 if (! NILP (Fequal (prop
, XCAR (tail
))))
1999 Fsetcar (XCDR (tail
), val
);
2006 newcell
= list2 (prop
, val
);
2010 Fsetcdr (XCDR (prev
), newcell
);
2014 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2015 doc
: /* Return t if the two args are the same Lisp object.
2016 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2017 (Lisp_Object obj1
, Lisp_Object obj2
)
2019 return scm_is_true (scm_eqv_p (obj1
, obj2
)) ? Qt
: Qnil
;
2022 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2023 doc
: /* Return t if two Lisp objects have similar structure and contents.
2024 They must have the same data type.
2025 Conses are compared by comparing the cars and the cdrs.
2026 Vectors and strings are compared element by element.
2027 Numbers are compared by value, but integers cannot equal floats.
2028 (Use `=' if you want integers and floats to be able to be equal.)
2029 Symbols must match exactly. */)
2030 (register Lisp_Object o1
, Lisp_Object o2
)
2032 return scm_is_true (scm_equal_p (o1
, o2
)) ? Qt
: Qnil
;
2035 SCM compare_text_properties
= SCM_BOOL_F
;
2037 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2038 doc
: /* Return t if two Lisp objects have similar structure and contents.
2039 This is like `equal' except that it compares the text properties
2040 of strings. (`equal' ignores text properties.) */)
2041 (register Lisp_Object o1
, Lisp_Object o2
)
2045 scm_dynwind_begin (0);
2046 scm_dynwind_fluid (compare_text_properties
, SCM_BOOL_T
);
2047 tem
= Fequal (o1
, o2
);
2053 misc_equal_p (SCM o1
, SCM o2
)
2055 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2059 if (NILP (Fequal (OVERLAY_START (o1
), OVERLAY_START (o2
)))
2060 || NILP (Fequal (OVERLAY_END (o1
), OVERLAY_END (o2
))))
2062 return scm_equal_p (XOVERLAY (o1
)->plist
, XOVERLAY (o2
)->plist
);
2066 struct Lisp_Marker
*m1
= XMARKER (o1
), *m2
= XMARKER (o2
);
2067 return scm_from_bool (m1
->buffer
== m2
->buffer
2069 || m1
->bytepos
== m2
->bytepos
));
2075 vectorlike_equal_p (SCM o1
, SCM o2
)
2078 ptrdiff_t size
= ASIZE (o1
);
2079 /* Pseudovectors have the type encoded in the size field, so this
2080 test actually checks that the objects have the same type as well
2081 as the same size. */
2082 if (ASIZE (o2
) != size
)
2084 /* Boolvectors are compared much like strings. */
2085 if (BOOL_VECTOR_P (o1
))
2087 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2089 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2090 ((XBOOL_VECTOR (o1
)->size
2091 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2092 / BOOL_VECTOR_BITS_PER_CHAR
)))
2096 if (WINDOW_CONFIGURATIONP (o1
))
2097 return scm_from_bool (compare_window_configurations (o1
, o2
, 0));
2099 /* Aside from them, only true vectors, char-tables, compiled
2100 functions, and fonts (font-spec, font-entity, font-object) are
2101 sensible to compare, so eliminate the others now. */
2102 if (size
& PSEUDOVECTOR_FLAG
)
2104 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2107 size
&= PSEUDOVECTOR_SIZE_MASK
;
2109 for (i
= 0; i
< size
; i
++)
2114 if (scm_is_false (scm_equal_p (v1
, v2
)))
2121 string_equal_p (SCM o1
, SCM o2
)
2123 if (SCHARS (o1
) != SCHARS (o2
))
2125 if (SBYTES (o1
) != SBYTES (o2
))
2127 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2129 if (scm_is_true (scm_fluid_ref (compare_text_properties
))
2130 && !compare_string_intervals (o1
, o2
))
2136 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2137 doc
: /* Store each element of ARRAY with ITEM.
2138 ARRAY is a vector, string, char-table, or bool-vector. */)
2139 (Lisp_Object array
, Lisp_Object item
)
2141 register ptrdiff_t size
, idx
;
2143 if (VECTORP (array
))
2144 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2145 ASET (array
, idx
, item
);
2146 else if (CHAR_TABLE_P (array
))
2150 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2151 set_char_table_contents (array
, i
, item
);
2152 set_char_table_defalt (array
, item
);
2154 else if (STRINGP (array
))
2156 register unsigned char *p
= SDATA (array
);
2158 CHECK_CHARACTER (item
);
2159 charval
= XFASTINT (item
);
2160 size
= SCHARS (array
);
2161 if (STRING_MULTIBYTE (array
))
2163 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2164 int len
= CHAR_STRING (charval
, str
);
2165 ptrdiff_t size_byte
= SBYTES (array
);
2167 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2168 || SCHARS (array
) * len
!= size_byte
)
2169 error ("Attempt to change byte length of a string");
2170 for (idx
= 0; idx
< size_byte
; idx
++)
2171 *p
++ = str
[idx
% len
];
2174 for (idx
= 0; idx
< size
; idx
++)
2177 else if (BOOL_VECTOR_P (array
))
2178 return bool_vector_fill (array
, item
);
2180 wrong_type_argument (Qarrayp
, array
);
2184 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2186 doc
: /* Clear the contents of STRING.
2187 This makes STRING unibyte and may change its length. */)
2188 (Lisp_Object string
)
2191 CHECK_STRING (string
);
2192 len
= SBYTES (string
);
2193 memset (SDATA (string
), 0, len
);
2194 STRING_SET_CHARS (string
, len
);
2195 STRING_SET_UNIBYTE (string
);
2201 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2203 Lisp_Object args
[2];
2206 return Fnconc (2, args
);
2209 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2210 doc
: /* Concatenate any number of lists by altering them.
2211 Only the last argument is not altered, and need not be a list.
2212 usage: (nconc &rest LISTS) */)
2213 (ptrdiff_t nargs
, Lisp_Object
*args
)
2216 register Lisp_Object tail
, tem
, val
;
2220 for (argnum
= 0; argnum
< nargs
; argnum
++)
2223 if (NILP (tem
)) continue;
2228 if (argnum
+ 1 == nargs
) break;
2230 CHECK_LIST_CONS (tem
, tem
);
2239 tem
= args
[argnum
+ 1];
2240 Fsetcdr (tail
, tem
);
2242 args
[argnum
+ 1] = tail
;
2248 /* This is the guts of all mapping functions.
2249 Apply FN to each element of SEQ, one by one,
2250 storing the results into elements of VALS, a C vector of Lisp_Objects.
2251 LENI is the length of VALS, which should also be the length of SEQ. */
2254 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2256 register Lisp_Object tail
;
2258 register EMACS_INT i
;
2259 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2263 /* Don't let vals contain any garbage when GC happens. */
2264 for (i
= 0; i
< leni
; i
++)
2267 GCPRO3 (dummy
, fn
, seq
);
2269 gcpro1
.nvars
= leni
;
2273 /* We need not explicitly protect `tail' because it is used only on lists, and
2274 1) lists are not relocated and 2) the list is marked via `seq' so will not
2277 if (VECTORP (seq
) || COMPILEDP (seq
))
2279 for (i
= 0; i
< leni
; i
++)
2281 dummy
= call1 (fn
, AREF (seq
, i
));
2286 else if (BOOL_VECTOR_P (seq
))
2288 for (i
= 0; i
< leni
; i
++)
2290 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2295 else if (STRINGP (seq
))
2299 for (i
= 0, i_byte
= 0; i
< leni
;)
2302 ptrdiff_t i_before
= i
;
2304 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2305 XSETFASTINT (dummy
, c
);
2306 dummy
= call1 (fn
, dummy
);
2308 vals
[i_before
] = dummy
;
2311 else /* Must be a list, since Flength did not get an error */
2314 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2316 dummy
= call1 (fn
, XCAR (tail
));
2326 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2327 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2328 In between each pair of results, stick in SEPARATOR. Thus, " " as
2329 SEPARATOR results in spaces between the values returned by FUNCTION.
2330 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2331 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2334 register EMACS_INT leni
;
2337 register Lisp_Object
*args
;
2338 struct gcpro gcpro1
;
2342 len
= Flength (sequence
);
2343 if (CHAR_TABLE_P (sequence
))
2344 wrong_type_argument (Qlistp
, sequence
);
2346 nargs
= leni
+ leni
- 1;
2347 if (nargs
< 0) return empty_unibyte_string
;
2349 SAFE_ALLOCA_LISP (args
, nargs
);
2352 mapcar1 (leni
, args
, function
, sequence
);
2355 for (i
= leni
- 1; i
> 0; i
--)
2356 args
[i
+ i
] = args
[i
];
2358 for (i
= 1; i
< nargs
; i
+= 2)
2359 args
[i
] = separator
;
2361 ret
= Fconcat (nargs
, args
);
2367 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2368 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2369 The result is a list just as long as SEQUENCE.
2370 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2371 (Lisp_Object function
, Lisp_Object sequence
)
2373 register Lisp_Object len
;
2374 register EMACS_INT leni
;
2375 register Lisp_Object
*args
;
2379 len
= Flength (sequence
);
2380 if (CHAR_TABLE_P (sequence
))
2381 wrong_type_argument (Qlistp
, sequence
);
2382 leni
= XFASTINT (len
);
2384 SAFE_ALLOCA_LISP (args
, leni
);
2386 mapcar1 (leni
, args
, function
, sequence
);
2388 ret
= Flist (leni
, args
);
2394 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2395 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2396 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2397 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2398 (Lisp_Object function
, Lisp_Object sequence
)
2400 register EMACS_INT leni
;
2402 leni
= XFASTINT (Flength (sequence
));
2403 if (CHAR_TABLE_P (sequence
))
2404 wrong_type_argument (Qlistp
, sequence
);
2405 mapcar1 (leni
, 0, function
, sequence
);
2410 /* This is how C code calls `yes-or-no-p' and allows the user
2413 Anything that calls this function must protect from GC! */
2416 do_yes_or_no_p (Lisp_Object prompt
)
2418 return call1 (intern ("yes-or-no-p"), prompt
);
2421 /* Anything that calls this function must protect from GC! */
2423 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2424 doc
: /* Ask user a yes-or-no question.
2425 Return t if answer is yes, and nil if the answer is no.
2426 PROMPT is the string to display to ask the question. It should end in
2427 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2429 The user must confirm the answer with RET, and can edit it until it
2432 If dialog boxes are supported, a dialog box will be used
2433 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2434 (Lisp_Object prompt
)
2436 register Lisp_Object ans
;
2437 Lisp_Object args
[2];
2438 struct gcpro gcpro1
;
2440 CHECK_STRING (prompt
);
2442 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2445 Lisp_Object pane
, menu
, obj
;
2446 redisplay_preserve_echo_area (4);
2447 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2448 Fcons (build_string ("No"), Qnil
));
2450 menu
= Fcons (prompt
, pane
);
2451 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2457 args
[1] = build_string ("(yes or no) ");
2458 prompt
= Fconcat (2, args
);
2464 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2465 Qyes_or_no_p_history
, Qnil
,
2467 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2472 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2480 message1 ("Please answer yes or no.");
2481 Fsleep_for (make_number (2), Qnil
);
2485 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2486 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2488 Each of the three load averages is multiplied by 100, then converted
2491 When USE-FLOATS is non-nil, floats will be used instead of integers.
2492 These floats are not multiplied by 100.
2494 If the 5-minute or 15-minute load averages are not available, return a
2495 shortened list, containing only those averages which are available.
2497 An error is thrown if the load average can't be obtained. In some
2498 cases making it work would require Emacs being installed setuid or
2499 setgid so that it can read kernel information, and that usually isn't
2501 (Lisp_Object use_floats
)
2504 int loads
= getloadavg (load_ave
, 3);
2505 Lisp_Object ret
= Qnil
;
2508 error ("load-average not implemented for this operating system");
2512 Lisp_Object load
= (NILP (use_floats
)
2513 ? make_number (100.0 * load_ave
[loads
])
2514 : make_float (load_ave
[loads
]));
2515 ret
= Fcons (load
, ret
);
2521 static Lisp_Object Qsubfeatures
;
2523 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2524 doc
: /* Return t if FEATURE is present in this Emacs.
2526 Use this to conditionalize execution of lisp code based on the
2527 presence or absence of Emacs or environment extensions.
2528 Use `provide' to declare that a feature is available. This function
2529 looks at the value of the variable `features'. The optional argument
2530 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2531 (Lisp_Object feature
, Lisp_Object subfeature
)
2533 register Lisp_Object tem
;
2534 CHECK_SYMBOL (feature
);
2535 tem
= Fmemq (feature
, Vfeatures
);
2536 if (!NILP (tem
) && !NILP (subfeature
))
2537 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2538 return (NILP (tem
)) ? Qnil
: Qt
;
2541 static Lisp_Object Qfuncall
;
2543 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2544 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2545 The optional argument SUBFEATURES should be a list of symbols listing
2546 particular subfeatures supported in this version of FEATURE. */)
2547 (Lisp_Object feature
, Lisp_Object subfeatures
)
2549 register Lisp_Object tem
;
2550 CHECK_SYMBOL (feature
);
2551 CHECK_LIST (subfeatures
);
2552 if (!NILP (Vautoload_queue
))
2553 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2555 tem
= Fmemq (feature
, Vfeatures
);
2557 Vfeatures
= Fcons (feature
, Vfeatures
);
2558 if (!NILP (subfeatures
))
2559 Fput (feature
, Qsubfeatures
, subfeatures
);
2560 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2562 /* Run any load-hooks for this file. */
2563 tem
= Fassq (feature
, Vafter_load_alist
);
2565 Fmapc (Qfuncall
, XCDR (tem
));
2570 /* `require' and its subroutines. */
2572 /* List of features currently being require'd, innermost first. */
2574 static Lisp_Object require_nesting_list
;
2577 require_unwind (Lisp_Object old_value
)
2579 require_nesting_list
= old_value
;
2582 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2583 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2584 If FEATURE is not a member of the list `features', then the feature
2585 is not loaded; so load the file FILENAME.
2586 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2587 and `load' will try to load this name appended with the suffix `.elc' or
2588 `.el', in that order. The name without appended suffix will not be used.
2589 See `get-load-suffixes' for the complete list of suffixes.
2590 If the optional third argument NOERROR is non-nil,
2591 then return nil if the file is not found instead of signaling an error.
2592 Normally the return value is FEATURE.
2593 The normal messages at start and end of loading FILENAME are suppressed. */)
2594 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2597 struct gcpro gcpro1
, gcpro2
;
2598 bool from_file
= load_in_progress
;
2600 CHECK_SYMBOL (feature
);
2602 /* Record the presence of `require' in this file
2603 even if the feature specified is already loaded.
2604 But not more than once in any file,
2605 and not when we aren't loading or reading from a file. */
2607 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2608 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2613 tem
= Fcons (Qrequire
, feature
);
2614 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2615 LOADHIST_ATTACH (tem
);
2617 tem
= Fmemq (feature
, Vfeatures
);
2624 /* This is to make sure that loadup.el gives a clear picture
2625 of what files are preloaded and when. */
2626 if (! NILP (Vpurify_flag
))
2627 error ("(require %s) while preparing to dump",
2628 SDATA (SYMBOL_NAME (feature
)));
2630 /* A certain amount of recursive `require' is legitimate,
2631 but if we require the same feature recursively 3 times,
2633 tem
= require_nesting_list
;
2634 while (! NILP (tem
))
2636 if (! NILP (Fequal (feature
, XCAR (tem
))))
2641 error ("Recursive `require' for feature `%s'",
2642 SDATA (SYMBOL_NAME (feature
)));
2644 /* Update the list for any nested `require's that occur. */
2645 record_unwind_protect (require_unwind
, require_nesting_list
);
2646 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2648 /* Value saved here is to be restored into Vautoload_queue */
2649 record_unwind_protect (un_autoload
, Vautoload_queue
);
2650 Vautoload_queue
= Qt
;
2652 /* Load the file. */
2653 GCPRO2 (feature
, filename
);
2654 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2655 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2658 /* If load failed entirely, return nil. */
2665 tem
= Fmemq (feature
, Vfeatures
);
2667 error ("Required feature `%s' was not provided",
2668 SDATA (SYMBOL_NAME (feature
)));
2670 /* Once loading finishes, don't undo it. */
2671 Vautoload_queue
= Qt
;
2678 /* Primitives for work of the "widget" library.
2679 In an ideal world, this section would not have been necessary.
2680 However, lisp function calls being as slow as they are, it turns
2681 out that some functions in the widget library (wid-edit.el) are the
2682 bottleneck of Widget operation. Here is their translation to C,
2683 for the sole reason of efficiency. */
2685 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2686 doc
: /* Return non-nil if PLIST has the property PROP.
2687 PLIST is a property list, which is a list of the form
2688 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2689 Unlike `plist-get', this allows you to distinguish between a missing
2690 property and a property with the value nil.
2691 The value is actually the tail of PLIST whose car is PROP. */)
2692 (Lisp_Object plist
, Lisp_Object prop
)
2694 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2697 plist
= XCDR (plist
);
2698 plist
= CDR (plist
);
2703 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2704 doc
: /* In WIDGET, set PROPERTY to VALUE.
2705 The value can later be retrieved with `widget-get'. */)
2706 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2708 CHECK_CONS (widget
);
2709 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2713 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2714 doc
: /* In WIDGET, get the value of PROPERTY.
2715 The value could either be specified when the widget was created, or
2716 later with `widget-put'. */)
2717 (Lisp_Object widget
, Lisp_Object property
)
2725 CHECK_CONS (widget
);
2726 tmp
= Fplist_member (XCDR (widget
), property
);
2732 tmp
= XCAR (widget
);
2735 widget
= Fget (tmp
, Qwidget_type
);
2739 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2740 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2741 ARGS are passed as extra arguments to the function.
2742 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2743 (ptrdiff_t nargs
, Lisp_Object
*args
)
2745 /* This function can GC. */
2746 Lisp_Object newargs
[3];
2747 struct gcpro gcpro1
, gcpro2
;
2750 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2751 newargs
[1] = args
[0];
2752 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2753 GCPRO2 (newargs
[0], newargs
[2]);
2754 result
= Fapply (3, newargs
);
2759 #ifdef HAVE_LANGINFO_CODESET
2760 #include <langinfo.h>
2763 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2764 doc
: /* Access locale data ITEM for the current C locale, if available.
2765 ITEM should be one of the following:
2767 `codeset', returning the character set as a string (locale item CODESET);
2769 `days', returning a 7-element vector of day names (locale items DAY_n);
2771 `months', returning a 12-element vector of month names (locale items MON_n);
2773 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2774 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2776 If the system can't provide such information through a call to
2777 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2779 See also Info node `(libc)Locales'.
2781 The data read from the system are decoded using `locale-coding-system'. */)
2785 #ifdef HAVE_LANGINFO_CODESET
2787 if (EQ (item
, Qcodeset
))
2789 str
= nl_langinfo (CODESET
);
2790 return build_string (str
);
2793 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2795 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2796 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2798 struct gcpro gcpro1
;
2800 synchronize_system_time_locale ();
2801 for (i
= 0; i
< 7; i
++)
2803 str
= nl_langinfo (days
[i
]);
2804 val
= build_unibyte_string (str
);
2805 /* Fixme: Is this coding system necessarily right, even if
2806 it is consistent with CODESET? If not, what to do? */
2807 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2815 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2817 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2818 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2819 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2821 struct gcpro gcpro1
;
2823 synchronize_system_time_locale ();
2824 for (i
= 0; i
< 12; i
++)
2826 str
= nl_langinfo (months
[i
]);
2827 val
= build_unibyte_string (str
);
2828 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2835 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2836 but is in the locale files. This could be used by ps-print. */
2838 else if (EQ (item
, Qpaper
))
2839 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2840 #endif /* PAPER_WIDTH */
2841 #endif /* HAVE_LANGINFO_CODESET*/
2845 /* base64 encode/decode functions (RFC 2045).
2846 Based on code from GNU recode. */
2848 #define MIME_LINE_LENGTH 76
2850 #define IS_ASCII(Character) \
2852 #define IS_BASE64(Character) \
2853 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2854 #define IS_BASE64_IGNORABLE(Character) \
2855 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2856 || (Character) == '\f' || (Character) == '\r')
2858 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2859 character or return retval if there are no characters left to
2861 #define READ_QUADRUPLET_BYTE(retval) \
2866 if (nchars_return) \
2867 *nchars_return = nchars; \
2872 while (IS_BASE64_IGNORABLE (c))
2874 /* Table of characters coding the 64 values. */
2875 static const char base64_value_to_char
[64] =
2877 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2878 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2879 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2880 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2881 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2882 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2883 '8', '9', '+', '/' /* 60-63 */
2886 /* Table of base64 values for first 128 characters. */
2887 static const short base64_char_to_value
[128] =
2889 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2890 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2891 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2892 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2893 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2894 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2895 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2896 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2897 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2898 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2899 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2900 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2901 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2904 /* The following diagram shows the logical steps by which three octets
2905 get transformed into four base64 characters.
2907 .--------. .--------. .--------.
2908 |aaaaaabb| |bbbbcccc| |ccdddddd|
2909 `--------' `--------' `--------'
2911 .--------+--------+--------+--------.
2912 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2913 `--------+--------+--------+--------'
2915 .--------+--------+--------+--------.
2916 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2917 `--------+--------+--------+--------'
2919 The octets are divided into 6 bit chunks, which are then encoded into
2920 base64 characters. */
2923 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2924 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2927 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2929 doc
: /* Base64-encode the region between BEG and END.
2930 Return the length of the encoded text.
2931 Optional third argument NO-LINE-BREAK means do not break long lines
2932 into shorter lines. */)
2933 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2936 ptrdiff_t allength
, length
;
2937 ptrdiff_t ibeg
, iend
, encoded_length
;
2938 ptrdiff_t old_pos
= PT
;
2941 validate_region (&beg
, &end
);
2943 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2944 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2945 move_gap_both (XFASTINT (beg
), ibeg
);
2947 /* We need to allocate enough room for encoding the text.
2948 We need 33 1/3% more space, plus a newline every 76
2949 characters, and then we round up. */
2950 length
= iend
- ibeg
;
2951 allength
= length
+ length
/3 + 1;
2952 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2954 encoded
= SAFE_ALLOCA (allength
);
2955 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2956 encoded
, length
, NILP (no_line_break
),
2957 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2958 if (encoded_length
> allength
)
2961 if (encoded_length
< 0)
2963 /* The encoding wasn't possible. */
2965 error ("Multibyte character in data for base64 encoding");
2968 /* Now we have encoded the region, so we insert the new contents
2969 and delete the old. (Insert first in order to preserve markers.) */
2970 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2971 insert (encoded
, encoded_length
);
2973 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2975 /* If point was outside of the region, restore it exactly; else just
2976 move to the beginning of the region. */
2977 if (old_pos
>= XFASTINT (end
))
2978 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2979 else if (old_pos
> XFASTINT (beg
))
2980 old_pos
= XFASTINT (beg
);
2983 /* We return the length of the encoded text. */
2984 return make_number (encoded_length
);
2987 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2989 doc
: /* Base64-encode STRING and return the result.
2990 Optional second argument NO-LINE-BREAK means do not break long lines
2991 into shorter lines. */)
2992 (Lisp_Object string
, Lisp_Object no_line_break
)
2994 ptrdiff_t allength
, length
, encoded_length
;
2996 Lisp_Object encoded_string
;
2999 CHECK_STRING (string
);
3001 /* We need to allocate enough room for encoding the text.
3002 We need 33 1/3% more space, plus a newline every 76
3003 characters, and then we round up. */
3004 length
= SBYTES (string
);
3005 allength
= length
+ length
/3 + 1;
3006 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3008 /* We need to allocate enough room for decoding the text. */
3009 encoded
= SAFE_ALLOCA (allength
);
3011 encoded_length
= base64_encode_1 (SSDATA (string
),
3012 encoded
, length
, NILP (no_line_break
),
3013 STRING_MULTIBYTE (string
));
3014 if (encoded_length
> allength
)
3017 if (encoded_length
< 0)
3019 /* The encoding wasn't possible. */
3021 error ("Multibyte character in data for base64 encoding");
3024 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3027 return encoded_string
;
3031 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3032 bool line_break
, bool multibyte
)
3045 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3046 if (CHAR_BYTE8_P (c
))
3047 c
= CHAR_TO_BYTE8 (c
);
3055 /* Wrap line every 76 characters. */
3059 if (counter
< MIME_LINE_LENGTH
/ 4)
3068 /* Process first byte of a triplet. */
3070 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3071 value
= (0x03 & c
) << 4;
3073 /* Process second byte of a triplet. */
3077 *e
++ = base64_value_to_char
[value
];
3085 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3086 if (CHAR_BYTE8_P (c
))
3087 c
= CHAR_TO_BYTE8 (c
);
3095 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3096 value
= (0x0f & c
) << 2;
3098 /* Process third byte of a triplet. */
3102 *e
++ = base64_value_to_char
[value
];
3109 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3110 if (CHAR_BYTE8_P (c
))
3111 c
= CHAR_TO_BYTE8 (c
);
3119 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3120 *e
++ = base64_value_to_char
[0x3f & c
];
3127 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3129 doc
: /* Base64-decode the region between BEG and END.
3130 Return the length of the decoded text.
3131 If the region can't be decoded, signal an error and don't modify the buffer. */)
3132 (Lisp_Object beg
, Lisp_Object end
)
3134 ptrdiff_t ibeg
, iend
, length
, allength
;
3136 ptrdiff_t old_pos
= PT
;
3137 ptrdiff_t decoded_length
;
3138 ptrdiff_t inserted_chars
;
3139 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3142 validate_region (&beg
, &end
);
3144 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3145 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3147 length
= iend
- ibeg
;
3149 /* We need to allocate enough room for decoding the text. If we are
3150 working on a multibyte buffer, each decoded code may occupy at
3152 allength
= multibyte
? length
* 2 : length
;
3153 decoded
= SAFE_ALLOCA (allength
);
3155 move_gap_both (XFASTINT (beg
), ibeg
);
3156 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3158 multibyte
, &inserted_chars
);
3159 if (decoded_length
> allength
)
3162 if (decoded_length
< 0)
3164 /* The decoding wasn't possible. */
3166 error ("Invalid base64 data");
3169 /* Now we have decoded the region, so we insert the new contents
3170 and delete the old. (Insert first in order to preserve markers.) */
3171 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3172 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3175 /* Delete the original text. */
3176 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3177 iend
+ decoded_length
, 1);
3179 /* If point was outside of the region, restore it exactly; else just
3180 move to the beginning of the region. */
3181 if (old_pos
>= XFASTINT (end
))
3182 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3183 else if (old_pos
> XFASTINT (beg
))
3184 old_pos
= XFASTINT (beg
);
3185 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3187 return make_number (inserted_chars
);
3190 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3192 doc
: /* Base64-decode STRING and return the result. */)
3193 (Lisp_Object string
)
3196 ptrdiff_t length
, decoded_length
;
3197 Lisp_Object decoded_string
;
3200 CHECK_STRING (string
);
3202 length
= SBYTES (string
);
3203 /* We need to allocate enough room for decoding the text. */
3204 decoded
= SAFE_ALLOCA (length
);
3206 /* The decoded result should be unibyte. */
3207 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3209 if (decoded_length
> length
)
3211 else if (decoded_length
>= 0)
3212 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3214 decoded_string
= Qnil
;
3217 if (!STRINGP (decoded_string
))
3218 error ("Invalid base64 data");
3220 return decoded_string
;
3223 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3224 MULTIBYTE, the decoded result should be in multibyte
3225 form. If NCHARS_RETURN is not NULL, store the number of produced
3226 characters in *NCHARS_RETURN. */
3229 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3230 bool multibyte
, ptrdiff_t *nchars_return
)
3232 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3235 unsigned long value
;
3236 ptrdiff_t nchars
= 0;
3240 /* Process first byte of a quadruplet. */
3242 READ_QUADRUPLET_BYTE (e
-to
);
3246 value
= base64_char_to_value
[c
] << 18;
3248 /* Process second byte of a quadruplet. */
3250 READ_QUADRUPLET_BYTE (-1);
3254 value
|= base64_char_to_value
[c
] << 12;
3256 c
= (unsigned char) (value
>> 16);
3257 if (multibyte
&& c
>= 128)
3258 e
+= BYTE8_STRING (c
, e
);
3263 /* Process third byte of a quadruplet. */
3265 READ_QUADRUPLET_BYTE (-1);
3269 READ_QUADRUPLET_BYTE (-1);
3278 value
|= base64_char_to_value
[c
] << 6;
3280 c
= (unsigned char) (0xff & value
>> 8);
3281 if (multibyte
&& c
>= 128)
3282 e
+= BYTE8_STRING (c
, e
);
3287 /* Process fourth byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (-1);
3296 value
|= base64_char_to_value
[c
];
3298 c
= (unsigned char) (0xff & value
);
3299 if (multibyte
&& c
>= 128)
3300 e
+= BYTE8_STRING (c
, e
);
3309 /***********************************************************************
3311 ***** Hash Tables *****
3313 ***********************************************************************/
3315 /* Implemented by gerd@gnu.org. This hash table implementation was
3316 inspired by CMUCL hash tables. */
3320 1. For small tables, association lists are probably faster than
3321 hash tables because they have lower overhead.
3323 For uses of hash tables where the O(1) behavior of table
3324 operations is not a requirement, it might therefore be a good idea
3325 not to hash. Instead, we could just do a linear search in the
3326 key_and_value vector of the hash table. This could be done
3327 if a `:linear-search t' argument is given to make-hash-table. */
3329 /* Various symbols. */
3331 static Lisp_Object Qhash_table_p
;
3332 static Lisp_Object Qkey
, Qvalue
, Qeql
;
3333 Lisp_Object Qeq
, Qequal
;
3334 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3335 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3338 /***********************************************************************
3340 ***********************************************************************/
3343 CHECK_HASH_TABLE (Lisp_Object x
)
3345 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3349 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3351 h
->key_and_value
= key_and_value
;
3354 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3359 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3361 gc_aset (h
->next
, idx
, val
);
3364 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3369 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3371 gc_aset (h
->hash
, idx
, val
);
3374 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3379 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3381 gc_aset (h
->index
, idx
, val
);
3384 /* If OBJ is a Lisp hash table, return a pointer to its struct
3385 Lisp_Hash_Table. Otherwise, signal an error. */
3387 static struct Lisp_Hash_Table
*
3388 check_hash_table (Lisp_Object obj
)
3390 CHECK_HASH_TABLE (obj
);
3391 return XHASH_TABLE (obj
);
3395 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3396 number. A number is "almost" a prime number if it is not divisible
3397 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3400 next_almost_prime (EMACS_INT n
)
3402 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3403 for (n
|= 1; ; n
+= 2)
3404 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3409 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3410 which USED[I] is non-zero. If found at index I in ARGS, set
3411 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3412 0. This function is used to extract a keyword/argument pair from
3413 a DEFUN parameter list. */
3416 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3420 for (i
= 1; i
< nargs
; i
++)
3421 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3432 /* Return a Lisp vector which has the same contents as VEC but has
3433 at least INCR_MIN more entries, where INCR_MIN is positive.
3434 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3435 than NITEMS_MAX. Entries in the resulting
3436 vector that are not copied from VEC are set to nil. */
3439 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3441 struct Lisp_Vector
*v
;
3442 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3443 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3444 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3445 ? nitems_max
: C_language_max
);
3446 eassert (VECTORP (vec
));
3447 eassert (0 < incr_min
&& -1 <= nitems_max
);
3448 old_size
= ASIZE (vec
);
3449 incr_max
= n_max
- old_size
;
3450 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3451 if (incr_max
< incr
)
3452 memory_full (SIZE_MAX
);
3453 new_size
= old_size
+ incr
;
3454 v
= allocate_vector (new_size
);
3455 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3456 for (i
= old_size
; i
< new_size
; ++i
)
3457 v
->contents
[i
] = Qnil
;
3458 XSETVECTOR (vec
, v
);
3463 /***********************************************************************
3465 ***********************************************************************/
3467 static struct hash_table_test hashtest_eq
;
3468 struct hash_table_test hashtest_eql
, hashtest_equal
;
3470 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3471 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3472 KEY2 are the same. */
3475 cmpfn_eql (struct hash_table_test
*ht
,
3479 return (FLOATP (key1
)
3481 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3485 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3486 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3487 KEY2 are the same. */
3490 cmpfn_equal (struct hash_table_test
*ht
,
3494 return !NILP (Fequal (key1
, key2
));
3498 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3499 HASH2 in hash table H using H->user_cmp_function. Value is true
3500 if KEY1 and KEY2 are the same. */
3503 cmpfn_user_defined (struct hash_table_test
*ht
,
3507 Lisp_Object args
[3];
3509 args
[0] = ht
->user_cmp_function
;
3512 return !NILP (Ffuncall (3, args
));
3516 /* Value is a hash code for KEY for use in hash table H which uses
3517 `eq' to compare keys. The hash code returned is guaranteed to fit
3518 in a Lisp integer. */
3521 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3523 return scm_ihashq (key
, MOST_POSITIVE_FIXNUM
);
3526 /* Value is a hash code for KEY for use in hash table H which uses
3527 `eql' to compare keys. The hash code returned is guaranteed to fit
3528 in a Lisp integer. */
3531 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3533 return scm_ihashv (key
, MOST_POSITIVE_FIXNUM
);
3536 /* Value is a hash code for KEY for use in hash table H which uses
3537 `equal' to compare keys. The hash code returned is guaranteed to fit
3538 in a Lisp integer. */
3541 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3543 return scm_ihash (key
, MOST_POSITIVE_FIXNUM
);
3546 /* Value is a hash code for KEY for use in hash table H which uses as
3547 user-defined function to compare keys. The hash code returned is
3548 guaranteed to fit in a Lisp integer. */
3551 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3553 Lisp_Object args
[2], hash
;
3555 args
[0] = ht
->user_hash_function
;
3557 hash
= Ffuncall (2, args
);
3558 return hashfn_eq (ht
, hash
);
3561 /* An upper bound on the size of a hash table index. It must fit in
3562 ptrdiff_t and be a valid Emacs fixnum. */
3563 #define INDEX_SIZE_BOUND \
3564 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3566 /* Create and initialize a new hash table.
3568 TEST specifies the test the hash table will use to compare keys.
3569 It must be either one of the predefined tests `eq', `eql' or
3570 `equal' or a symbol denoting a user-defined test named TEST with
3571 test and hash functions USER_TEST and USER_HASH.
3573 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3575 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3576 new size when it becomes full is computed by adding REHASH_SIZE to
3577 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3578 table's new size is computed by multiplying its old size with
3581 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3582 be resized when the ratio of (number of entries in the table) /
3583 (table size) is >= REHASH_THRESHOLD.
3585 WEAK specifies the weakness of the table. If non-nil, it must be
3586 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3589 make_hash_table (struct hash_table_test test
,
3590 Lisp_Object size
, Lisp_Object rehash_size
,
3591 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3593 struct Lisp_Hash_Table
*h
;
3595 EMACS_INT index_size
, sz
;
3599 /* Preconditions. */
3600 eassert (SYMBOLP (test
.name
));
3601 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3602 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3603 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3604 eassert (FLOATP (rehash_threshold
)
3605 && 0 < XFLOAT_DATA (rehash_threshold
)
3606 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3608 if (XFASTINT (size
) == 0)
3609 size
= make_number (1);
3611 sz
= XFASTINT (size
);
3612 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3613 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3614 ? next_almost_prime (index_float
)
3615 : INDEX_SIZE_BOUND
+ 1);
3616 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3617 error ("Hash table too large");
3619 /* Allocate a table and initialize it. */
3620 h
= allocate_hash_table ();
3622 /* Initialize hash table slots. */
3625 h
->rehash_threshold
= rehash_threshold
;
3626 h
->rehash_size
= rehash_size
;
3628 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3629 h
->hash
= Fmake_vector (size
, Qnil
);
3630 h
->next
= Fmake_vector (size
, Qnil
);
3631 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3633 /* Set up the free list. */
3634 for (i
= 0; i
< sz
- 1; ++i
)
3635 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3636 h
->next_free
= make_number (0);
3638 XSET_HASH_TABLE (table
, h
);
3639 eassert (HASH_TABLE_P (table
));
3640 eassert (XHASH_TABLE (table
) == h
);
3646 /* Return a copy of hash table H1. Keys and values are not copied,
3647 only the table itself is. */
3650 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3653 struct Lisp_Hash_Table
*h2
;
3655 h2
= allocate_hash_table ();
3657 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3658 h2
->hash
= Fcopy_sequence (h1
->hash
);
3659 h2
->next
= Fcopy_sequence (h1
->next
);
3660 h2
->index
= Fcopy_sequence (h1
->index
);
3661 XSET_HASH_TABLE (table
, h2
);
3667 /* Resize hash table H if it's too full. If H cannot be resized
3668 because it's already too large, throw an error. */
3671 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3673 if (NILP (h
->next_free
))
3675 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3676 EMACS_INT new_size
, index_size
, nsize
;
3680 if (INTEGERP (h
->rehash_size
))
3681 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3684 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3685 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3687 new_size
= float_new_size
;
3688 if (new_size
<= old_size
)
3689 new_size
= old_size
+ 1;
3692 new_size
= INDEX_SIZE_BOUND
+ 1;
3694 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3695 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3696 ? next_almost_prime (index_float
)
3697 : INDEX_SIZE_BOUND
+ 1);
3698 nsize
= max (index_size
, 2 * new_size
);
3699 if (INDEX_SIZE_BOUND
< nsize
)
3700 error ("Hash table too large to resize");
3702 #ifdef ENABLE_CHECKING
3703 if (HASH_TABLE_P (Vpurify_flag
)
3704 && XHASH_TABLE (Vpurify_flag
) == h
)
3706 Lisp_Object args
[2];
3707 args
[0] = build_string ("Growing hash table to: %d");
3708 args
[1] = make_number (new_size
);
3713 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3714 2 * (new_size
- old_size
), -1));
3715 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3716 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3717 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3719 /* Update the free list. Do it so that new entries are added at
3720 the end of the free list. This makes some operations like
3722 for (i
= old_size
; i
< new_size
- 1; ++i
)
3723 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3725 if (!NILP (h
->next_free
))
3727 Lisp_Object last
, next
;
3729 last
= h
->next_free
;
3730 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3734 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3737 XSETFASTINT (h
->next_free
, old_size
);
3740 for (i
= 0; i
< old_size
; ++i
)
3741 if (!NILP (HASH_HASH (h
, i
)))
3743 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3744 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3745 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3746 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3752 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3753 the hash code of KEY. Value is the index of the entry in H
3754 matching KEY, or -1 if not found. */
3757 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3759 EMACS_UINT hash_code
;
3760 ptrdiff_t start_of_bucket
;
3763 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3764 eassert ((hash_code
& ~INTMASK
) == 0);
3768 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3769 idx
= HASH_INDEX (h
, start_of_bucket
);
3771 /* We need not gcpro idx since it's either an integer or nil. */
3774 ptrdiff_t i
= XFASTINT (idx
);
3775 if (EQ (key
, HASH_KEY (h
, i
))
3777 && hash_code
== XUINT (HASH_HASH (h
, i
))
3778 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3780 idx
= HASH_NEXT (h
, i
);
3783 return NILP (idx
) ? -1 : XFASTINT (idx
);
3787 /* Put an entry into hash table H that associates KEY with VALUE.
3788 HASH is a previously computed hash code of KEY.
3789 Value is the index of the entry in H matching KEY. */
3792 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3795 ptrdiff_t start_of_bucket
, i
;
3797 eassert ((hash
& ~INTMASK
) == 0);
3799 /* Increment count after resizing because resizing may fail. */
3800 maybe_resize_hash_table (h
);
3803 /* Store key/value in the key_and_value vector. */
3804 i
= XFASTINT (h
->next_free
);
3805 h
->next_free
= HASH_NEXT (h
, i
);
3806 set_hash_key_slot (h
, i
, key
);
3807 set_hash_value_slot (h
, i
, value
);
3809 /* Remember its hash code. */
3810 set_hash_hash_slot (h
, i
, make_number (hash
));
3812 /* Add new entry to its collision chain. */
3813 start_of_bucket
= hash
% ASIZE (h
->index
);
3814 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3815 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3820 /* Remove the entry matching KEY from hash table H, if there is one. */
3823 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3825 EMACS_UINT hash_code
;
3826 ptrdiff_t start_of_bucket
;
3827 Lisp_Object idx
, prev
;
3829 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3830 eassert ((hash_code
& ~INTMASK
) == 0);
3831 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3832 idx
= HASH_INDEX (h
, start_of_bucket
);
3835 /* We need not gcpro idx, prev since they're either integers or nil. */
3838 ptrdiff_t i
= XFASTINT (idx
);
3840 if (EQ (key
, HASH_KEY (h
, i
))
3842 && hash_code
== XUINT (HASH_HASH (h
, i
))
3843 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3845 /* Take entry out of collision chain. */
3847 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3849 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3851 /* Clear slots in key_and_value and add the slots to
3853 set_hash_key_slot (h
, i
, Qnil
);
3854 set_hash_value_slot (h
, i
, Qnil
);
3855 set_hash_hash_slot (h
, i
, Qnil
);
3856 set_hash_next_slot (h
, i
, h
->next_free
);
3857 h
->next_free
= make_number (i
);
3859 eassert (h
->count
>= 0);
3865 idx
= HASH_NEXT (h
, i
);
3871 /* Clear hash table H. */
3874 hash_clear (struct Lisp_Hash_Table
*h
)
3878 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3880 for (i
= 0; i
< size
; ++i
)
3882 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3883 set_hash_key_slot (h
, i
, Qnil
);
3884 set_hash_value_slot (h
, i
, Qnil
);
3885 set_hash_hash_slot (h
, i
, Qnil
);
3888 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3889 ASET (h
->index
, i
, Qnil
);
3891 h
->next_free
= make_number (0);
3898 /***********************************************************************
3899 Hash Code Computation
3900 ***********************************************************************/
3902 /* Return a hash for string PTR which has length LEN. The hash value
3903 can be any EMACS_UINT value. */
3906 hash_string (char const *ptr
, ptrdiff_t len
)
3908 char const *p
= ptr
;
3909 char const *end
= p
+ len
;
3911 EMACS_UINT hash
= 0;
3916 hash
= sxhash_combine (hash
, c
);
3922 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
3923 structure. Value is an unsigned integer clipped to INTMASK. */
3926 sxhash (Lisp_Object obj
, int depth
)
3928 return scm_ihash (obj
, MOST_POSITIVE_FIXNUM
);
3933 /***********************************************************************
3935 ***********************************************************************/
3938 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
3939 doc
: /* Compute a hash code for OBJ and return it as integer. */)
3942 EMACS_UINT hash
= sxhash (obj
, 0);
3943 return make_number (hash
);
3947 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
3948 doc
: /* Create and return a new hash table.
3950 Arguments are specified as keyword/argument pairs. The following
3951 arguments are defined:
3953 :test TEST -- TEST must be a symbol that specifies how to compare
3954 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
3955 `equal'. User-supplied test and hash functions can be specified via
3956 `define-hash-table-test'.
3958 :size SIZE -- A hint as to how many elements will be put in the table.
3961 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
3962 fills up. If REHASH-SIZE is an integer, increase the size by that
3963 amount. If it is a float, it must be > 1.0, and the new size is the
3964 old size multiplied by that factor. Default is 1.5.
3966 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
3967 Resize the hash table when the ratio (number of entries / table size)
3968 is greater than or equal to THRESHOLD. Default is 0.8.
3970 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
3971 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
3972 returned is a weak table. Key/value pairs are removed from a weak
3973 hash table when there are no non-weak references pointing to their
3974 key, value, one of key or value, or both key and value, depending on
3975 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
3978 usage: (make-hash-table &rest KEYWORD-ARGS) */)
3979 (ptrdiff_t nargs
, Lisp_Object
*args
)
3981 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3982 struct hash_table_test testdesc
;
3986 /* The vector `used' is used to keep track of arguments that
3987 have been consumed. */
3988 used
= alloca (nargs
* sizeof *used
);
3989 memset (used
, 0, nargs
* sizeof *used
);
3991 /* See if there's a `:test TEST' among the arguments. */
3992 i
= get_key_arg (QCtest
, nargs
, args
, used
);
3993 test
= i
? args
[i
] : Qeql
;
3995 testdesc
= hashtest_eq
;
3996 else if (EQ (test
, Qeql
))
3997 testdesc
= hashtest_eql
;
3998 else if (EQ (test
, Qequal
))
3999 testdesc
= hashtest_equal
;
4002 /* See if it is a user-defined test. */
4005 prop
= Fget (test
, Qhash_table_test
);
4006 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4007 signal_error ("Invalid hash table test", test
);
4008 testdesc
.name
= test
;
4009 testdesc
.user_cmp_function
= XCAR (prop
);
4010 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4011 testdesc
.hashfn
= hashfn_user_defined
;
4012 testdesc
.cmpfn
= cmpfn_user_defined
;
4015 /* See if there's a `:size SIZE' argument. */
4016 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4017 size
= i
? args
[i
] : Qnil
;
4019 size
= make_number (DEFAULT_HASH_SIZE
);
4020 else if (!INTEGERP (size
) || XINT (size
) < 0)
4021 signal_error ("Invalid hash table size", size
);
4023 /* Look for `:rehash-size SIZE'. */
4024 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4025 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4026 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4027 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4028 signal_error ("Invalid hash table rehash size", rehash_size
);
4030 /* Look for `:rehash-threshold THRESHOLD'. */
4031 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4032 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4033 if (! (FLOATP (rehash_threshold
)
4034 && 0 < XFLOAT_DATA (rehash_threshold
)
4035 && XFLOAT_DATA (rehash_threshold
) <= 1))
4036 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4038 /* Look for `:weakness WEAK'. */
4039 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4040 weak
= i
? args
[i
] : Qnil
;
4042 weak
= Qkey_and_value
;
4045 && !EQ (weak
, Qvalue
)
4046 && !EQ (weak
, Qkey_or_value
)
4047 && !EQ (weak
, Qkey_and_value
))
4048 signal_error ("Invalid hash table weakness", weak
);
4050 /* Now, all args should have been used up, or there's a problem. */
4051 for (i
= 0; i
< nargs
; ++i
)
4053 signal_error ("Invalid argument list", args
[i
]);
4055 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4059 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4060 doc
: /* Return a copy of hash table TABLE. */)
4063 return copy_hash_table (check_hash_table (table
));
4067 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4068 doc
: /* Return the number of elements in TABLE. */)
4071 return make_number (check_hash_table (table
)->count
);
4075 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4076 Shash_table_rehash_size
, 1, 1, 0,
4077 doc
: /* Return the current rehash size of TABLE. */)
4080 return check_hash_table (table
)->rehash_size
;
4084 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4085 Shash_table_rehash_threshold
, 1, 1, 0,
4086 doc
: /* Return the current rehash threshold of TABLE. */)
4089 return check_hash_table (table
)->rehash_threshold
;
4093 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4094 doc
: /* Return the size of TABLE.
4095 The size can be used as an argument to `make-hash-table' to create
4096 a hash table than can hold as many elements as TABLE holds
4097 without need for resizing. */)
4100 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4101 return make_number (HASH_TABLE_SIZE (h
));
4105 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4106 doc
: /* Return the test TABLE uses. */)
4109 return check_hash_table (table
)->test
.name
;
4113 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4115 doc
: /* Return the weakness of TABLE. */)
4118 return check_hash_table (table
)->weak
;
4122 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4123 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4126 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4130 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4131 doc
: /* Clear hash table TABLE and return it. */)
4134 hash_clear (check_hash_table (table
));
4135 /* Be compatible with XEmacs. */
4140 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4141 doc
: /* Look up KEY in TABLE and return its associated value.
4142 If KEY is not found, return DFLT which defaults to nil. */)
4143 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4145 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4146 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4147 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4151 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4152 doc
: /* Associate KEY with VALUE in hash table TABLE.
4153 If KEY is already present in table, replace its current value with
4154 VALUE. In any case, return VALUE. */)
4155 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4157 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4161 i
= hash_lookup (h
, key
, &hash
);
4163 set_hash_value_slot (h
, i
, value
);
4165 hash_put (h
, key
, value
, hash
);
4171 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4172 doc
: /* Remove KEY from TABLE. */)
4173 (Lisp_Object key
, Lisp_Object table
)
4175 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4176 hash_remove_from_table (h
, key
);
4181 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4182 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4183 FUNCTION is called with two arguments, KEY and VALUE.
4184 `maphash' always returns nil. */)
4185 (Lisp_Object function
, Lisp_Object table
)
4187 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4188 Lisp_Object args
[3];
4191 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4192 if (!NILP (HASH_HASH (h
, i
)))
4195 args
[1] = HASH_KEY (h
, i
);
4196 args
[2] = HASH_VALUE (h
, i
);
4204 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4205 Sdefine_hash_table_test
, 3, 3, 0,
4206 doc
: /* Define a new hash table test with name NAME, a symbol.
4208 In hash tables created with NAME specified as test, use TEST to
4209 compare keys, and HASH for computing hash codes of keys.
4211 TEST must be a function taking two arguments and returning non-nil if
4212 both arguments are the same. HASH must be a function taking one
4213 argument and returning an object that is the hash code of the argument.
4214 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4215 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4216 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4218 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4223 /************************************************************************
4224 MD5, SHA-1, and SHA-2
4225 ************************************************************************/
4232 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4235 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4236 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4240 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4241 register EMACS_INT b
, e
;
4242 register struct buffer
*bp
;
4245 void *(*hash_func
) (const char *, size_t, void *);
4248 CHECK_SYMBOL (algorithm
);
4250 if (STRINGP (object
))
4252 if (NILP (coding_system
))
4254 /* Decide the coding-system to encode the data with. */
4256 if (STRING_MULTIBYTE (object
))
4257 /* use default, we can't guess correct value */
4258 coding_system
= preferred_coding_system ();
4260 coding_system
= Qraw_text
;
4263 if (NILP (Fcoding_system_p (coding_system
)))
4265 /* Invalid coding system. */
4267 if (!NILP (noerror
))
4268 coding_system
= Qraw_text
;
4270 xsignal1 (Qcoding_system_error
, coding_system
);
4273 if (STRING_MULTIBYTE (object
))
4274 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4276 size
= SCHARS (object
);
4277 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4279 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4280 end_byte
= (end_char
== size
4282 : string_char_to_byte (object
, end_char
));
4288 record_unwind_current_buffer ();
4290 CHECK_BUFFER (object
);
4292 bp
= XBUFFER (object
);
4293 set_buffer_internal (bp
);
4299 CHECK_NUMBER_COERCE_MARKER (start
);
4307 CHECK_NUMBER_COERCE_MARKER (end
);
4312 temp
= b
, b
= e
, e
= temp
;
4314 if (!(BEGV
<= b
&& e
<= ZV
))
4315 args_out_of_range (start
, end
);
4317 if (NILP (coding_system
))
4319 /* Decide the coding-system to encode the data with.
4320 See fileio.c:Fwrite-region */
4322 if (!NILP (Vcoding_system_for_write
))
4323 coding_system
= Vcoding_system_for_write
;
4326 bool force_raw_text
= 0;
4328 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4329 if (NILP (coding_system
)
4330 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4332 coding_system
= Qnil
;
4333 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4337 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4339 /* Check file-coding-system-alist. */
4340 Lisp_Object args
[4], val
;
4342 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4343 args
[3] = Fbuffer_file_name (object
);
4344 val
= Ffind_operation_coding_system (4, args
);
4345 if (CONSP (val
) && !NILP (XCDR (val
)))
4346 coding_system
= XCDR (val
);
4349 if (NILP (coding_system
)
4350 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4352 /* If we still have not decided a coding system, use the
4353 default value of buffer-file-coding-system. */
4354 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4358 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4359 /* Confirm that VAL can surely encode the current region. */
4360 coding_system
= call4 (Vselect_safe_coding_system_function
,
4361 make_number (b
), make_number (e
),
4362 coding_system
, Qnil
);
4365 coding_system
= Qraw_text
;
4368 if (NILP (Fcoding_system_p (coding_system
)))
4370 /* Invalid coding system. */
4372 if (!NILP (noerror
))
4373 coding_system
= Qraw_text
;
4375 xsignal1 (Qcoding_system_error
, coding_system
);
4379 object
= make_buffer_string (b
, e
, 0);
4382 if (STRING_MULTIBYTE (object
))
4383 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4385 end_byte
= SBYTES (object
);
4388 if (EQ (algorithm
, Qmd5
))
4390 digest_size
= MD5_DIGEST_SIZE
;
4391 hash_func
= md5_buffer
;
4393 else if (EQ (algorithm
, Qsha1
))
4395 digest_size
= SHA1_DIGEST_SIZE
;
4396 hash_func
= sha1_buffer
;
4398 else if (EQ (algorithm
, Qsha224
))
4400 digest_size
= SHA224_DIGEST_SIZE
;
4401 hash_func
= sha224_buffer
;
4403 else if (EQ (algorithm
, Qsha256
))
4405 digest_size
= SHA256_DIGEST_SIZE
;
4406 hash_func
= sha256_buffer
;
4408 else if (EQ (algorithm
, Qsha384
))
4410 digest_size
= SHA384_DIGEST_SIZE
;
4411 hash_func
= sha384_buffer
;
4413 else if (EQ (algorithm
, Qsha512
))
4415 digest_size
= SHA512_DIGEST_SIZE
;
4416 hash_func
= sha512_buffer
;
4419 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4421 /* allocate 2 x digest_size so that it can be re-used to hold the
4423 digest
= make_uninit_string (digest_size
* 2);
4425 hash_func (SSDATA (object
) + start_byte
,
4426 end_byte
- start_byte
,
4431 unsigned char *p
= SDATA (digest
);
4432 for (i
= digest_size
- 1; i
>= 0; i
--)
4434 static char const hexdigit
[16] = "0123456789abcdef";
4436 p
[2 * i
] = hexdigit
[p_i
>> 4];
4437 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4442 return make_unibyte_string (SSDATA (digest
), digest_size
);
4445 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4446 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4448 A message digest is a cryptographic checksum of a document, and the
4449 algorithm to calculate it is defined in RFC 1321.
4451 The two optional arguments START and END are character positions
4452 specifying for which part of OBJECT the message digest should be
4453 computed. If nil or omitted, the digest is computed for the whole
4456 The MD5 message digest is computed from the result of encoding the
4457 text in a coding system, not directly from the internal Emacs form of
4458 the text. The optional fourth argument CODING-SYSTEM specifies which
4459 coding system to encode the text with. It should be the same coding
4460 system that you used or will use when actually writing the text into a
4463 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4464 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4465 system would be chosen by default for writing this text into a file.
4467 If OBJECT is a string, the most preferred coding system (see the
4468 command `prefer-coding-system') is used.
4470 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4471 guesswork fails. Normally, an error is signaled in such case. */)
4472 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4474 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4477 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4478 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4479 ALGORITHM is a symbol specifying the hash to use:
4480 md5, sha1, sha224, sha256, sha384 or sha512.
4482 The two optional arguments START and END are positions specifying for
4483 which part of OBJECT to compute the hash. If nil or omitted, uses the
4486 If BINARY is non-nil, returns a string in binary form. */)
4487 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4489 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4492 DEFUN ("eval-scheme", Feval_scheme
, Seval_scheme
, 1, 1,
4494 doc
: /* Evaluate a string containing a Scheme expression. */)
4495 (Lisp_Object string
)
4499 CHECK_STRING (string
);
4501 tem
= scm_c_eval_string (SSDATA (string
));
4502 return (INTERACTIVE
? Fprin1 (tem
, Qt
) : tem
);
4506 init_fns_once (void)
4508 compare_text_properties
= scm_make_fluid ();
4509 scm_set_smob_equalp (lisp_misc_tag
, misc_equal_p
);
4510 scm_set_smob_equalp (lisp_string_tag
, string_equal_p
);
4511 scm_set_smob_equalp (lisp_vectorlike_tag
, vectorlike_equal_p
);
4519 DEFSYM (Qmd5
, "md5");
4520 DEFSYM (Qsha1
, "sha1");
4521 DEFSYM (Qsha224
, "sha224");
4522 DEFSYM (Qsha256
, "sha256");
4523 DEFSYM (Qsha384
, "sha384");
4524 DEFSYM (Qsha512
, "sha512");
4526 /* Hash table stuff. */
4527 DEFSYM (Qhash_table_p
, "hash-table-p");
4529 DEFSYM (Qeql
, "eql");
4530 DEFSYM (Qequal
, "equal");
4531 DEFSYM (QCtest
, ":test");
4532 DEFSYM (QCsize
, ":size");
4533 DEFSYM (QCrehash_size
, ":rehash-size");
4534 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4535 DEFSYM (QCweakness
, ":weakness");
4536 DEFSYM (Qkey
, "key");
4537 DEFSYM (Qvalue
, "value");
4538 DEFSYM (Qhash_table_test
, "hash-table-test");
4539 DEFSYM (Qkey_or_value
, "key-or-value");
4540 DEFSYM (Qkey_and_value
, "key-and-value");
4542 DEFSYM (Qstring_lessp
, "string-lessp");
4543 DEFSYM (Qprovide
, "provide");
4544 DEFSYM (Qrequire
, "require");
4545 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4546 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4547 DEFSYM (Qwidget_type
, "widget-type");
4549 staticpro (&string_char_byte_cache_string
);
4550 string_char_byte_cache_string
= Qnil
;
4552 require_nesting_list
= Qnil
;
4553 staticpro (&require_nesting_list
);
4555 Fset (Qyes_or_no_p_history
, Qnil
);
4557 DEFVAR_LISP ("features", Vfeatures
,
4558 doc
: /* A list of symbols which are the features of the executing Emacs.
4559 Used by `featurep' and `require', and altered by `provide'. */);
4560 Vfeatures
= list1 (intern_c_string ("emacs"));
4561 DEFSYM (Qsubfeatures
, "subfeatures");
4562 DEFSYM (Qfuncall
, "funcall");
4564 #ifdef HAVE_LANGINFO_CODESET
4565 DEFSYM (Qcodeset
, "codeset");
4566 DEFSYM (Qdays
, "days");
4567 DEFSYM (Qmonths
, "months");
4568 DEFSYM (Qpaper
, "paper");
4569 #endif /* HAVE_LANGINFO_CODESET */
4571 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4572 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4573 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4574 invoked by mouse clicks and mouse menu items.
4576 On some platforms, file selection dialogs are also enabled if this is
4580 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4581 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4582 This applies to commands from menus and tool bar buttons even when
4583 they are initiated from the keyboard. If `use-dialog-box' is nil,
4584 that disables the use of a file dialog, regardless of the value of
4586 use_file_dialog
= 1;
4588 hashtest_eq
.name
= Qeq
;
4589 hashtest_eq
.user_hash_function
= Qnil
;
4590 hashtest_eq
.user_cmp_function
= Qnil
;
4591 hashtest_eq
.cmpfn
= 0;
4592 hashtest_eq
.hashfn
= hashfn_eq
;
4594 hashtest_eql
.name
= Qeql
;
4595 hashtest_eql
.user_hash_function
= Qnil
;
4596 hashtest_eql
.user_cmp_function
= Qnil
;
4597 hashtest_eql
.cmpfn
= cmpfn_eql
;
4598 hashtest_eql
.hashfn
= hashfn_eql
;
4600 hashtest_equal
.name
= Qequal
;
4601 hashtest_equal
.user_hash_function
= Qnil
;
4602 hashtest_equal
.user_cmp_function
= Qnil
;
4603 hashtest_equal
.cmpfn
= cmpfn_equal
;
4604 hashtest_equal
.hashfn
= hashfn_equal
;