1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2012
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 #include "character.h"
34 #include "intervals.h"
37 #include "blockinput.h"
39 #if defined (HAVE_X_WINDOWS)
42 #endif /* HAVE_MENUS */
44 Lisp_Object Qstring_lessp
;
45 static Lisp_Object Qprovide
, Qrequire
;
46 static Lisp_Object Qyes_or_no_p_history
;
47 Lisp_Object Qcursor_in_echo_area
;
48 static Lisp_Object Qwidget_type
;
49 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
51 static Lisp_Object Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
;
53 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool);
55 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
56 doc
: /* Return the argument unchanged. */)
62 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
63 doc
: /* Return a pseudo-random number.
64 All integers representable in Lisp, i.e. between `most-negative-fixnum'
65 and `most-positive-fixnum', inclusive, are equally likely.
67 With positive integer LIMIT, return random number in interval [0,LIMIT).
68 With argument t, set the random number seed from the current time and pid.
69 Other values of LIMIT are ignored. */)
76 else if (STRINGP (limit
))
77 seed_random (SSDATA (limit
), SBYTES (limit
));
80 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
81 val
%= XFASTINT (limit
);
82 return make_number (val
);
85 /* Heuristic on how many iterations of a tight loop can be safely done
86 before it's time to do a QUIT. This must be a power of 2. */
87 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
89 /* Random data-structure functions */
91 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
92 doc
: /* Return the length of vector, list or string SEQUENCE.
93 A byte-code function object is also allowed.
94 If the string contains multibyte characters, this is not necessarily
95 the number of bytes in the string; it is the number of characters.
96 To get the number of bytes, use `string-bytes'. */)
97 (register Lisp_Object sequence
)
99 register Lisp_Object val
;
101 if (STRINGP (sequence
))
102 XSETFASTINT (val
, SCHARS (sequence
));
103 else if (VECTORP (sequence
))
104 XSETFASTINT (val
, ASIZE (sequence
));
105 else if (CHAR_TABLE_P (sequence
))
106 XSETFASTINT (val
, MAX_CHAR
);
107 else if (BOOL_VECTOR_P (sequence
))
108 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
109 else if (COMPILEDP (sequence
))
110 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
111 else if (CONSP (sequence
))
118 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
120 if (MOST_POSITIVE_FIXNUM
< i
)
121 error ("List too long");
124 sequence
= XCDR (sequence
);
126 while (CONSP (sequence
));
128 CHECK_LIST_END (sequence
, sequence
);
130 val
= make_number (i
);
132 else if (NILP (sequence
))
133 XSETFASTINT (val
, 0);
135 wrong_type_argument (Qsequencep
, sequence
);
140 /* This does not check for quits. That is safe since it must terminate. */
142 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
143 doc
: /* Return the length of a list, but avoid error or infinite loop.
144 This function never gets an error. If LIST is not really a list,
145 it returns 0. If LIST is circular, it returns a finite value
146 which is at least the number of distinct elements. */)
149 Lisp_Object tail
, halftail
;
154 return make_number (0);
156 /* halftail is used to detect circular lists. */
157 for (tail
= halftail
= list
; ; )
162 if (EQ (tail
, halftail
))
165 if ((lolen
& 1) == 0)
167 halftail
= XCDR (halftail
);
168 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
172 hilen
+= UINTMAX_MAX
+ 1.0;
177 /* If the length does not fit into a fixnum, return a float.
178 On all known practical machines this returns an upper bound on
180 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
183 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
184 doc
: /* Return the number of bytes in STRING.
185 If STRING is multibyte, this may be greater than the length of STRING. */)
188 CHECK_STRING (string
);
189 return make_number (SBYTES (string
));
192 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
193 doc
: /* Return t if two strings have identical contents.
194 Case is significant, but text properties are ignored.
195 Symbols are also allowed; their print names are used instead. */)
196 (register Lisp_Object s1
, Lisp_Object s2
)
199 s1
= SYMBOL_NAME (s1
);
201 s2
= SYMBOL_NAME (s2
);
205 if (SCHARS (s1
) != SCHARS (s2
)
206 || SBYTES (s1
) != SBYTES (s2
)
207 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
212 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
213 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
214 In string STR1, skip the first START1 characters and stop at END1.
215 In string STR2, skip the first START2 characters and stop at END2.
216 END1 and END2 default to the full lengths of the respective strings.
218 Case is significant in this comparison if IGNORE-CASE is nil.
219 Unibyte strings are converted to multibyte for comparison.
221 The value is t if the strings (or specified portions) match.
222 If string STR1 is less, the value is a negative number N;
223 - 1 - N is the number of characters that match at the beginning.
224 If string STR1 is greater, the value is a positive number N;
225 N - 1 is the number of characters that match at the beginning. */)
226 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
228 register ptrdiff_t end1_char
, end2_char
;
229 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
234 start1
= make_number (0);
236 start2
= make_number (0);
237 CHECK_NATNUM (start1
);
238 CHECK_NATNUM (start2
);
244 end1_char
= SCHARS (str1
);
245 if (! NILP (end1
) && end1_char
> XINT (end1
))
246 end1_char
= XINT (end1
);
247 if (end1_char
< XINT (start1
))
248 args_out_of_range (str1
, start1
);
250 end2_char
= SCHARS (str2
);
251 if (! NILP (end2
) && end2_char
> XINT (end2
))
252 end2_char
= XINT (end2
);
253 if (end2_char
< XINT (start2
))
254 args_out_of_range (str2
, start2
);
259 i1_byte
= string_char_to_byte (str1
, i1
);
260 i2_byte
= string_char_to_byte (str2
, i2
);
262 while (i1
< end1_char
&& i2
< end2_char
)
264 /* When we find a mismatch, we must compare the
265 characters, not just the bytes. */
268 if (STRING_MULTIBYTE (str1
))
269 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
272 c1
= SREF (str1
, i1
++);
273 MAKE_CHAR_MULTIBYTE (c1
);
276 if (STRING_MULTIBYTE (str2
))
277 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
280 c2
= SREF (str2
, i2
++);
281 MAKE_CHAR_MULTIBYTE (c2
);
287 if (! NILP (ignore_case
))
291 tem
= Fupcase (make_number (c1
));
293 tem
= Fupcase (make_number (c2
));
300 /* Note that I1 has already been incremented
301 past the character that we are comparing;
302 hence we don't add or subtract 1 here. */
304 return make_number (- i1
+ XINT (start1
));
306 return make_number (i1
- XINT (start1
));
310 return make_number (i1
- XINT (start1
) + 1);
312 return make_number (- i1
+ XINT (start1
) - 1);
317 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
318 doc
: /* Return t if first arg string is less than second in lexicographic order.
320 Symbols are also allowed; their print names are used instead. */)
321 (register Lisp_Object s1
, Lisp_Object s2
)
323 register ptrdiff_t end
;
324 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
327 s1
= SYMBOL_NAME (s1
);
329 s2
= SYMBOL_NAME (s2
);
333 i1
= i1_byte
= i2
= i2_byte
= 0;
336 if (end
> SCHARS (s2
))
341 /* When we find a mismatch, we must compare the
342 characters, not just the bytes. */
345 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
346 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
349 return c1
< c2
? Qt
: Qnil
;
351 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
354 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
355 enum Lisp_Type target_type
, bool last_special
);
359 concat2 (Lisp_Object s1
, Lisp_Object s2
)
364 return concat (2, args
, Lisp_String
, 0);
369 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
375 return concat (3, args
, Lisp_String
, 0);
378 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
379 doc
: /* Concatenate all the arguments and make the result a list.
380 The result is a list whose elements are the elements of all the arguments.
381 Each argument may be a list, vector or string.
382 The last argument is not copied, just used as the tail of the new list.
383 usage: (append &rest SEQUENCES) */)
384 (ptrdiff_t nargs
, Lisp_Object
*args
)
386 return concat (nargs
, args
, Lisp_Cons
, 1);
389 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
390 doc
: /* Concatenate all the arguments and make the result a string.
391 The result is a string whose elements are the elements of all the arguments.
392 Each argument may be a string or a list or vector of characters (integers).
393 usage: (concat &rest SEQUENCES) */)
394 (ptrdiff_t nargs
, Lisp_Object
*args
)
396 return concat (nargs
, args
, Lisp_String
, 0);
399 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
400 doc
: /* Concatenate all the arguments and make the result a vector.
401 The result is a vector whose elements are the elements of all the arguments.
402 Each argument may be a list, vector or string.
403 usage: (vconcat &rest SEQUENCES) */)
404 (ptrdiff_t nargs
, Lisp_Object
*args
)
406 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
410 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
411 doc
: /* Return a copy of a list, vector, string or char-table.
412 The elements of a list or vector are not copied; they are shared
413 with the original. */)
416 if (NILP (arg
)) return arg
;
418 if (CHAR_TABLE_P (arg
))
420 return copy_char_table (arg
);
423 if (BOOL_VECTOR_P (arg
))
426 ptrdiff_t size_in_chars
427 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
428 / BOOL_VECTOR_BITS_PER_CHAR
);
430 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
431 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
436 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
437 wrong_type_argument (Qsequencep
, arg
);
439 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
442 /* This structure holds information of an argument of `concat' that is
443 a string and has text properties to be copied. */
446 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
447 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
448 ptrdiff_t to
; /* refer to VAL (the target string) */
452 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
453 enum Lisp_Type target_type
, bool last_special
)
459 ptrdiff_t toindex_byte
= 0;
460 EMACS_INT result_len
;
461 EMACS_INT result_len_byte
;
463 Lisp_Object last_tail
;
466 /* When we make a multibyte string, we can't copy text properties
467 while concatenating each string because the length of resulting
468 string can't be decided until we finish the whole concatenation.
469 So, we record strings that have text properties to be copied
470 here, and copy the text properties after the concatenation. */
471 struct textprop_rec
*textprops
= NULL
;
472 /* Number of elements in textprops. */
473 ptrdiff_t num_textprops
= 0;
478 /* In append, the last arg isn't treated like the others */
479 if (last_special
&& nargs
> 0)
482 last_tail
= args
[nargs
];
487 /* Check each argument. */
488 for (argnum
= 0; argnum
< nargs
; argnum
++)
491 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
492 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
493 wrong_type_argument (Qsequencep
, this);
496 /* Compute total length in chars of arguments in RESULT_LEN.
497 If desired output is a string, also compute length in bytes
498 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
499 whether the result should be a multibyte string. */
503 for (argnum
= 0; argnum
< nargs
; argnum
++)
507 len
= XFASTINT (Flength (this));
508 if (target_type
== Lisp_String
)
510 /* We must count the number of bytes needed in the string
511 as well as the number of characters. */
515 ptrdiff_t this_len_byte
;
517 if (VECTORP (this) || COMPILEDP (this))
518 for (i
= 0; i
< len
; i
++)
521 CHECK_CHARACTER (ch
);
523 this_len_byte
= CHAR_BYTES (c
);
524 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
526 result_len_byte
+= this_len_byte
;
527 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
530 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
531 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
532 else if (CONSP (this))
533 for (; CONSP (this); this = XCDR (this))
536 CHECK_CHARACTER (ch
);
538 this_len_byte
= CHAR_BYTES (c
);
539 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
541 result_len_byte
+= this_len_byte
;
542 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
545 else if (STRINGP (this))
547 if (STRING_MULTIBYTE (this))
550 this_len_byte
= SBYTES (this);
553 this_len_byte
= count_size_as_multibyte (SDATA (this),
555 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
557 result_len_byte
+= this_len_byte
;
562 if (MOST_POSITIVE_FIXNUM
< result_len
)
563 memory_full (SIZE_MAX
);
566 if (! some_multibyte
)
567 result_len_byte
= result_len
;
569 /* Create the output object. */
570 if (target_type
== Lisp_Cons
)
571 val
= Fmake_list (make_number (result_len
), Qnil
);
572 else if (target_type
== Lisp_Vectorlike
)
573 val
= Fmake_vector (make_number (result_len
), Qnil
);
574 else if (some_multibyte
)
575 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
577 val
= make_uninit_string (result_len
);
579 /* In `append', if all but last arg are nil, return last arg. */
580 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
583 /* Copy the contents of the args into the result. */
585 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
587 toindex
= 0, toindex_byte
= 0;
591 SAFE_NALLOCA (textprops
, 1, nargs
);
593 for (argnum
= 0; argnum
< nargs
; argnum
++)
596 ptrdiff_t thisleni
= 0;
597 register ptrdiff_t thisindex
= 0;
598 register ptrdiff_t thisindex_byte
= 0;
602 thislen
= Flength (this), thisleni
= XINT (thislen
);
604 /* Between strings of the same kind, copy fast. */
605 if (STRINGP (this) && STRINGP (val
)
606 && STRING_MULTIBYTE (this) == some_multibyte
)
608 ptrdiff_t thislen_byte
= SBYTES (this);
610 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
611 if (string_intervals (this))
613 textprops
[num_textprops
].argnum
= argnum
;
614 textprops
[num_textprops
].from
= 0;
615 textprops
[num_textprops
++].to
= toindex
;
617 toindex_byte
+= thislen_byte
;
620 /* Copy a single-byte string to a multibyte string. */
621 else if (STRINGP (this) && STRINGP (val
))
623 if (string_intervals (this))
625 textprops
[num_textprops
].argnum
= argnum
;
626 textprops
[num_textprops
].from
= 0;
627 textprops
[num_textprops
++].to
= toindex
;
629 toindex_byte
+= copy_text (SDATA (this),
630 SDATA (val
) + toindex_byte
,
631 SCHARS (this), 0, 1);
635 /* Copy element by element. */
638 register Lisp_Object elt
;
640 /* Fetch next element of `this' arg into `elt', or break if
641 `this' is exhausted. */
642 if (NILP (this)) break;
644 elt
= XCAR (this), this = XCDR (this);
645 else if (thisindex
>= thisleni
)
647 else if (STRINGP (this))
650 if (STRING_MULTIBYTE (this))
651 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
656 c
= SREF (this, thisindex
); thisindex
++;
657 if (some_multibyte
&& !ASCII_CHAR_P (c
))
658 c
= BYTE8_TO_CHAR (c
);
660 XSETFASTINT (elt
, c
);
662 else if (BOOL_VECTOR_P (this))
665 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
666 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
674 elt
= AREF (this, thisindex
);
678 /* Store this element into the result. */
685 else if (VECTORP (val
))
687 ASET (val
, toindex
, elt
);
693 CHECK_CHARACTER (elt
);
696 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
698 SSET (val
, toindex_byte
++, c
);
704 XSETCDR (prev
, last_tail
);
706 if (num_textprops
> 0)
709 ptrdiff_t last_to_end
= -1;
711 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
713 this = args
[textprops
[argnum
].argnum
];
714 props
= text_property_list (this,
716 make_number (SCHARS (this)),
718 /* If successive arguments have properties, be sure that the
719 value of `composition' property be the copy. */
720 if (last_to_end
== textprops
[argnum
].to
)
721 make_composition_value_copy (props
);
722 add_text_properties_from_list (val
, props
,
723 make_number (textprops
[argnum
].to
));
724 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
732 static Lisp_Object string_char_byte_cache_string
;
733 static ptrdiff_t string_char_byte_cache_charpos
;
734 static ptrdiff_t string_char_byte_cache_bytepos
;
737 clear_string_char_byte_cache (void)
739 string_char_byte_cache_string
= Qnil
;
742 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
745 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
748 ptrdiff_t best_below
, best_below_byte
;
749 ptrdiff_t best_above
, best_above_byte
;
751 best_below
= best_below_byte
= 0;
752 best_above
= SCHARS (string
);
753 best_above_byte
= SBYTES (string
);
754 if (best_above
== best_above_byte
)
757 if (EQ (string
, string_char_byte_cache_string
))
759 if (string_char_byte_cache_charpos
< char_index
)
761 best_below
= string_char_byte_cache_charpos
;
762 best_below_byte
= string_char_byte_cache_bytepos
;
766 best_above
= string_char_byte_cache_charpos
;
767 best_above_byte
= string_char_byte_cache_bytepos
;
771 if (char_index
- best_below
< best_above
- char_index
)
773 unsigned char *p
= SDATA (string
) + best_below_byte
;
775 while (best_below
< char_index
)
777 p
+= BYTES_BY_CHAR_HEAD (*p
);
780 i_byte
= p
- SDATA (string
);
784 unsigned char *p
= SDATA (string
) + best_above_byte
;
786 while (best_above
> char_index
)
789 while (!CHAR_HEAD_P (*p
)) p
--;
792 i_byte
= p
- SDATA (string
);
795 string_char_byte_cache_bytepos
= i_byte
;
796 string_char_byte_cache_charpos
= char_index
;
797 string_char_byte_cache_string
= string
;
802 /* Return the character index corresponding to BYTE_INDEX in STRING. */
805 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
808 ptrdiff_t best_below
, best_below_byte
;
809 ptrdiff_t best_above
, best_above_byte
;
811 best_below
= best_below_byte
= 0;
812 best_above
= SCHARS (string
);
813 best_above_byte
= SBYTES (string
);
814 if (best_above
== best_above_byte
)
817 if (EQ (string
, string_char_byte_cache_string
))
819 if (string_char_byte_cache_bytepos
< byte_index
)
821 best_below
= string_char_byte_cache_charpos
;
822 best_below_byte
= string_char_byte_cache_bytepos
;
826 best_above
= string_char_byte_cache_charpos
;
827 best_above_byte
= string_char_byte_cache_bytepos
;
831 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
833 unsigned char *p
= SDATA (string
) + best_below_byte
;
834 unsigned char *pend
= SDATA (string
) + byte_index
;
838 p
+= BYTES_BY_CHAR_HEAD (*p
);
842 i_byte
= p
- SDATA (string
);
846 unsigned char *p
= SDATA (string
) + best_above_byte
;
847 unsigned char *pbeg
= SDATA (string
) + byte_index
;
852 while (!CHAR_HEAD_P (*p
)) p
--;
856 i_byte
= p
- SDATA (string
);
859 string_char_byte_cache_bytepos
= i_byte
;
860 string_char_byte_cache_charpos
= i
;
861 string_char_byte_cache_string
= string
;
866 /* Convert STRING to a multibyte string. */
869 string_make_multibyte (Lisp_Object string
)
876 if (STRING_MULTIBYTE (string
))
879 nbytes
= count_size_as_multibyte (SDATA (string
),
881 /* If all the chars are ASCII, they won't need any more bytes
882 once converted. In that case, we can return STRING itself. */
883 if (nbytes
== SBYTES (string
))
886 buf
= SAFE_ALLOCA (nbytes
);
887 copy_text (SDATA (string
), buf
, SBYTES (string
),
890 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
897 /* Convert STRING (if unibyte) to a multibyte string without changing
898 the number of characters. Characters 0200 trough 0237 are
899 converted to eight-bit characters. */
902 string_to_multibyte (Lisp_Object string
)
909 if (STRING_MULTIBYTE (string
))
912 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
913 /* If all the chars are ASCII, they won't need any more bytes once
915 if (nbytes
== SBYTES (string
))
916 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
918 buf
= SAFE_ALLOCA (nbytes
);
919 memcpy (buf
, SDATA (string
), SBYTES (string
));
920 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
922 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
929 /* Convert STRING to a single-byte string. */
932 string_make_unibyte (Lisp_Object string
)
939 if (! STRING_MULTIBYTE (string
))
942 nchars
= SCHARS (string
);
944 buf
= SAFE_ALLOCA (nchars
);
945 copy_text (SDATA (string
), buf
, SBYTES (string
),
948 ret
= make_unibyte_string ((char *) buf
, nchars
);
954 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
956 doc
: /* Return the multibyte equivalent of STRING.
957 If STRING is unibyte and contains non-ASCII characters, the function
958 `unibyte-char-to-multibyte' is used to convert each unibyte character
959 to a multibyte character. In this case, the returned string is a
960 newly created string with no text properties. If STRING is multibyte
961 or entirely ASCII, it is returned unchanged. In particular, when
962 STRING is unibyte and entirely ASCII, the returned string is unibyte.
963 \(When the characters are all ASCII, Emacs primitives will treat the
964 string the same way whether it is unibyte or multibyte.) */)
967 CHECK_STRING (string
);
969 return string_make_multibyte (string
);
972 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
974 doc
: /* Return the unibyte equivalent of STRING.
975 Multibyte character codes are converted to unibyte according to
976 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
977 If the lookup in the translation table fails, this function takes just
978 the low 8 bits of each character. */)
981 CHECK_STRING (string
);
983 return string_make_unibyte (string
);
986 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
988 doc
: /* Return a unibyte string with the same individual bytes as STRING.
989 If STRING is unibyte, the result is STRING itself.
990 Otherwise it is a newly created string, with no text properties.
991 If STRING is multibyte and contains a character of charset
992 `eight-bit', it is converted to the corresponding single byte. */)
995 CHECK_STRING (string
);
997 if (STRING_MULTIBYTE (string
))
999 ptrdiff_t bytes
= SBYTES (string
);
1000 unsigned char *str
= xmalloc (bytes
);
1002 memcpy (str
, SDATA (string
), bytes
);
1003 bytes
= str_as_unibyte (str
, bytes
);
1004 string
= make_unibyte_string ((char *) str
, bytes
);
1010 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1012 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1013 If STRING is multibyte, the result is STRING itself.
1014 Otherwise it is a newly created string, with no text properties.
1016 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1017 part of a correct utf-8 sequence), it is converted to the corresponding
1018 multibyte character of charset `eight-bit'.
1019 See also `string-to-multibyte'.
1021 Beware, this often doesn't really do what you think it does.
1022 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1023 If you're not sure, whether to use `string-as-multibyte' or
1024 `string-to-multibyte', use `string-to-multibyte'. */)
1025 (Lisp_Object string
)
1027 CHECK_STRING (string
);
1029 if (! STRING_MULTIBYTE (string
))
1031 Lisp_Object new_string
;
1032 ptrdiff_t nchars
, nbytes
;
1034 parse_str_as_multibyte (SDATA (string
),
1037 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1038 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1039 if (nbytes
!= SBYTES (string
))
1040 str_as_multibyte (SDATA (new_string
), nbytes
,
1041 SBYTES (string
), NULL
);
1042 string
= new_string
;
1043 set_string_intervals (string
, NULL
);
1048 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1050 doc
: /* Return a multibyte string with the same individual chars as STRING.
1051 If STRING is multibyte, the result is STRING itself.
1052 Otherwise it is a newly created string, with no text properties.
1054 If STRING is unibyte and contains an 8-bit byte, it is converted to
1055 the corresponding multibyte character of charset `eight-bit'.
1057 This differs from `string-as-multibyte' by converting each byte of a correct
1058 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1059 correct sequence. */)
1060 (Lisp_Object string
)
1062 CHECK_STRING (string
);
1064 return string_to_multibyte (string
);
1067 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1069 doc
: /* Return a unibyte string with the same individual chars as STRING.
1070 If STRING is unibyte, the result is STRING itself.
1071 Otherwise it is a newly created string, with no text properties,
1072 where each `eight-bit' character is converted to the corresponding byte.
1073 If STRING contains a non-ASCII, non-`eight-bit' character,
1074 an error is signaled. */)
1075 (Lisp_Object string
)
1077 CHECK_STRING (string
);
1079 if (STRING_MULTIBYTE (string
))
1081 ptrdiff_t chars
= SCHARS (string
);
1082 unsigned char *str
= xmalloc (chars
);
1083 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1085 if (converted
< chars
)
1086 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1087 string
= make_unibyte_string ((char *) str
, chars
);
1094 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1095 doc
: /* Return a copy of ALIST.
1096 This is an alist which represents the same mapping from objects to objects,
1097 but does not share the alist structure with ALIST.
1098 The objects mapped (cars and cdrs of elements of the alist)
1099 are shared, however.
1100 Elements of ALIST that are not conses are also shared. */)
1103 register Lisp_Object tem
;
1108 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1109 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1111 register Lisp_Object car
;
1115 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1120 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1121 doc
: /* Return a new string whose contents are a substring of STRING.
1122 The returned string consists of the characters between index FROM
1123 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1124 zero-indexed: 0 means the first character of STRING. Negative values
1125 are counted from the end of STRING. If TO is nil, the substring runs
1126 to the end of STRING.
1128 The STRING argument may also be a vector. In that case, the return
1129 value is a new vector that contains the elements between index FROM
1130 \(inclusive) and index TO (exclusive) of that vector argument. */)
1131 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1135 EMACS_INT from_char
, to_char
;
1137 CHECK_VECTOR_OR_STRING (string
);
1138 CHECK_NUMBER (from
);
1140 if (STRINGP (string
))
1141 size
= SCHARS (string
);
1143 size
= ASIZE (string
);
1151 to_char
= XINT (to
);
1156 from_char
= XINT (from
);
1159 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1160 args_out_of_range_3 (string
, make_number (from_char
),
1161 make_number (to_char
));
1163 if (STRINGP (string
))
1166 (NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
));
1167 ptrdiff_t from_byte
= string_char_to_byte (string
, from_char
);
1168 res
= make_specified_string (SSDATA (string
) + from_byte
,
1169 to_char
- from_char
, to_byte
- from_byte
,
1170 STRING_MULTIBYTE (string
));
1171 copy_text_properties (make_number (from_char
), make_number (to_char
),
1172 string
, make_number (0), res
, Qnil
);
1175 res
= Fvector (to_char
- from_char
, aref_addr (string
, from_char
));
1181 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1182 doc
: /* Return a substring of STRING, without text properties.
1183 It starts at index FROM and ends before TO.
1184 TO may be nil or omitted; then the substring runs to the end of STRING.
1185 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1186 If FROM or TO is negative, it counts from the end.
1188 With one argument, just copy STRING without its properties. */)
1189 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1192 EMACS_INT from_char
, to_char
;
1193 ptrdiff_t from_byte
, to_byte
;
1195 CHECK_STRING (string
);
1197 size
= SCHARS (string
);
1203 CHECK_NUMBER (from
);
1204 from_char
= XINT (from
);
1214 to_char
= XINT (to
);
1219 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1220 args_out_of_range_3 (string
, make_number (from_char
),
1221 make_number (to_char
));
1223 from_byte
= NILP (from
) ? 0 : string_char_to_byte (string
, from_char
);
1225 NILP (to
) ? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1226 return make_specified_string (SSDATA (string
) + from_byte
,
1227 to_char
- from_char
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1231 /* Extract a substring of STRING, giving start and end positions
1232 both in characters and in bytes. */
1235 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1236 ptrdiff_t to
, ptrdiff_t to_byte
)
1241 CHECK_VECTOR_OR_STRING (string
);
1243 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1245 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1246 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1248 if (STRINGP (string
))
1250 res
= make_specified_string (SSDATA (string
) + from_byte
,
1251 to
- from
, to_byte
- from_byte
,
1252 STRING_MULTIBYTE (string
));
1253 copy_text_properties (make_number (from
), make_number (to
),
1254 string
, make_number (0), res
, Qnil
);
1257 res
= Fvector (to
- from
, aref_addr (string
, from
));
1262 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1263 doc
: /* Take cdr N times on LIST, return the result. */)
1264 (Lisp_Object n
, Lisp_Object list
)
1269 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1272 CHECK_LIST_CONS (list
, list
);
1278 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1279 doc
: /* Return the Nth element of LIST.
1280 N counts from zero. If LIST is not that long, nil is returned. */)
1281 (Lisp_Object n
, Lisp_Object list
)
1283 return Fcar (Fnthcdr (n
, list
));
1286 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1287 doc
: /* Return element of SEQUENCE at index N. */)
1288 (register Lisp_Object sequence
, Lisp_Object n
)
1291 if (CONSP (sequence
) || NILP (sequence
))
1292 return Fcar (Fnthcdr (n
, sequence
));
1294 /* Faref signals a "not array" error, so check here. */
1295 CHECK_ARRAY (sequence
, Qsequencep
);
1296 return Faref (sequence
, n
);
1299 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1300 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1301 The value is actually the tail of LIST whose car is ELT. */)
1302 (register Lisp_Object elt
, Lisp_Object list
)
1304 register Lisp_Object tail
;
1305 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1307 register Lisp_Object tem
;
1308 CHECK_LIST_CONS (tail
, list
);
1310 if (! NILP (Fequal (elt
, tem
)))
1317 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1318 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1319 The value is actually the tail of LIST whose car is ELT. */)
1320 (register Lisp_Object elt
, Lisp_Object list
)
1324 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1328 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1332 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1343 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1344 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1345 The value is actually the tail of LIST whose car is ELT. */)
1346 (register Lisp_Object elt
, Lisp_Object list
)
1348 register Lisp_Object tail
;
1351 return Fmemq (elt
, list
);
1353 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1355 register Lisp_Object tem
;
1356 CHECK_LIST_CONS (tail
, list
);
1358 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1365 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1366 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1367 The value is actually the first element of LIST whose car is KEY.
1368 Elements of LIST that are not conses are ignored. */)
1369 (Lisp_Object key
, Lisp_Object list
)
1374 || (CONSP (XCAR (list
))
1375 && EQ (XCAR (XCAR (list
)), key
)))
1380 || (CONSP (XCAR (list
))
1381 && EQ (XCAR (XCAR (list
)), key
)))
1386 || (CONSP (XCAR (list
))
1387 && EQ (XCAR (XCAR (list
)), key
)))
1397 /* Like Fassq but never report an error and do not allow quits.
1398 Use only on lists known never to be circular. */
1401 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1404 && (!CONSP (XCAR (list
))
1405 || !EQ (XCAR (XCAR (list
)), key
)))
1408 return CAR_SAFE (list
);
1411 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1412 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1413 The value is actually the first element of LIST whose car equals KEY. */)
1414 (Lisp_Object key
, Lisp_Object list
)
1421 || (CONSP (XCAR (list
))
1422 && (car
= XCAR (XCAR (list
)),
1423 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1428 || (CONSP (XCAR (list
))
1429 && (car
= XCAR (XCAR (list
)),
1430 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1435 || (CONSP (XCAR (list
))
1436 && (car
= XCAR (XCAR (list
)),
1437 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1447 /* Like Fassoc but never report an error and do not allow quits.
1448 Use only on lists known never to be circular. */
1451 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1454 && (!CONSP (XCAR (list
))
1455 || (!EQ (XCAR (XCAR (list
)), key
)
1456 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1459 return CONSP (list
) ? XCAR (list
) : Qnil
;
1462 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1463 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1464 The value is actually the first element of LIST whose cdr is KEY. */)
1465 (register Lisp_Object key
, Lisp_Object list
)
1470 || (CONSP (XCAR (list
))
1471 && EQ (XCDR (XCAR (list
)), key
)))
1476 || (CONSP (XCAR (list
))
1477 && EQ (XCDR (XCAR (list
)), key
)))
1482 || (CONSP (XCAR (list
))
1483 && EQ (XCDR (XCAR (list
)), key
)))
1493 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1495 The value is actually the first element of LIST whose cdr equals KEY. */)
1496 (Lisp_Object key
, Lisp_Object list
)
1503 || (CONSP (XCAR (list
))
1504 && (cdr
= XCDR (XCAR (list
)),
1505 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1510 || (CONSP (XCAR (list
))
1511 && (cdr
= XCDR (XCAR (list
)),
1512 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1529 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1530 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1531 More precisely, this function skips any members `eq' to ELT at the
1532 front of LIST, then removes members `eq' to ELT from the remaining
1533 sublist by modifying its list structure, then returns the resulting
1536 Write `(setq foo (delq element foo))' to be sure of correctly changing
1537 the value of a list `foo'. */)
1538 (register Lisp_Object elt
, Lisp_Object list
)
1540 register Lisp_Object tail
, prev
;
1541 register Lisp_Object tem
;
1545 while (!NILP (tail
))
1547 CHECK_LIST_CONS (tail
, list
);
1554 Fsetcdr (prev
, XCDR (tail
));
1564 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1565 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1566 SEQ must be a sequence (i.e. a list, a vector, or a string).
1567 The return value is a sequence of the same type.
1569 If SEQ is a list, this behaves like `delq', except that it compares
1570 with `equal' instead of `eq'. In particular, it may remove elements
1571 by altering the list structure.
1573 If SEQ is not a list, deletion is never performed destructively;
1574 instead this function creates and returns a new vector or string.
1576 Write `(setq foo (delete element foo))' to be sure of correctly
1577 changing the value of a sequence `foo'. */)
1578 (Lisp_Object elt
, Lisp_Object seq
)
1584 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1585 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1588 if (n
!= ASIZE (seq
))
1590 struct Lisp_Vector
*p
= allocate_vector (n
);
1592 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1593 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1594 p
->contents
[n
++] = AREF (seq
, i
);
1596 XSETVECTOR (seq
, p
);
1599 else if (STRINGP (seq
))
1601 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1604 for (i
= nchars
= nbytes
= ibyte
= 0;
1606 ++i
, ibyte
+= cbytes
)
1608 if (STRING_MULTIBYTE (seq
))
1610 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1611 cbytes
= CHAR_BYTES (c
);
1619 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1626 if (nchars
!= SCHARS (seq
))
1630 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1631 if (!STRING_MULTIBYTE (seq
))
1632 STRING_SET_UNIBYTE (tem
);
1634 for (i
= nchars
= nbytes
= ibyte
= 0;
1636 ++i
, ibyte
+= cbytes
)
1638 if (STRING_MULTIBYTE (seq
))
1640 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1641 cbytes
= CHAR_BYTES (c
);
1649 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1651 unsigned char *from
= SDATA (seq
) + ibyte
;
1652 unsigned char *to
= SDATA (tem
) + nbytes
;
1658 for (n
= cbytes
; n
--; )
1668 Lisp_Object tail
, prev
;
1670 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1672 CHECK_LIST_CONS (tail
, seq
);
1674 if (!NILP (Fequal (elt
, XCAR (tail
))))
1679 Fsetcdr (prev
, XCDR (tail
));
1690 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1691 doc
: /* Reverse LIST by modifying cdr pointers.
1692 Return the reversed list. Expects a properly nil-terminated list. */)
1695 register Lisp_Object prev
, tail
, next
;
1697 if (NILP (list
)) return list
;
1700 while (!NILP (tail
))
1703 CHECK_LIST_CONS (tail
, tail
);
1705 Fsetcdr (tail
, prev
);
1712 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1713 doc
: /* Reverse LIST, copying. Return the reversed list.
1714 See also the function `nreverse', which is used more often. */)
1719 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1722 new = Fcons (XCAR (list
), new);
1724 CHECK_LIST_END (list
, list
);
1728 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1730 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1731 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1732 Returns the sorted list. LIST is modified by side effects.
1733 PREDICATE is called with two elements of LIST, and should return non-nil
1734 if the first element should sort before the second. */)
1735 (Lisp_Object list
, Lisp_Object predicate
)
1737 Lisp_Object front
, back
;
1738 register Lisp_Object len
, tem
;
1739 struct gcpro gcpro1
, gcpro2
;
1743 len
= Flength (list
);
1744 length
= XINT (len
);
1748 XSETINT (len
, (length
/ 2) - 1);
1749 tem
= Fnthcdr (len
, list
);
1751 Fsetcdr (tem
, Qnil
);
1753 GCPRO2 (front
, back
);
1754 front
= Fsort (front
, predicate
);
1755 back
= Fsort (back
, predicate
);
1757 return merge (front
, back
, predicate
);
1761 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1764 register Lisp_Object tail
;
1766 register Lisp_Object l1
, l2
;
1767 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1774 /* It is sufficient to protect org_l1 and org_l2.
1775 When l1 and l2 are updated, we copy the new values
1776 back into the org_ vars. */
1777 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1797 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1813 Fsetcdr (tail
, tem
);
1819 /* This does not check for quits. That is safe since it must terminate. */
1821 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1822 doc
: /* Extract a value from a property list.
1823 PLIST is a property list, which is a list of the form
1824 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1825 corresponding to the given PROP, or nil if PROP is not one of the
1826 properties on the list. This function never signals an error. */)
1827 (Lisp_Object plist
, Lisp_Object prop
)
1829 Lisp_Object tail
, halftail
;
1831 /* halftail is used to detect circular lists. */
1832 tail
= halftail
= plist
;
1833 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1835 if (EQ (prop
, XCAR (tail
)))
1836 return XCAR (XCDR (tail
));
1838 tail
= XCDR (XCDR (tail
));
1839 halftail
= XCDR (halftail
);
1840 if (EQ (tail
, halftail
))
1847 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1848 doc
: /* Return the value of SYMBOL's PROPNAME property.
1849 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1850 (Lisp_Object symbol
, Lisp_Object propname
)
1852 CHECK_SYMBOL (symbol
);
1853 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1856 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1857 doc
: /* Change value in PLIST of PROP to VAL.
1858 PLIST is a property list, which is a list of the form
1859 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1860 If PROP is already a property on the list, its value is set to VAL,
1861 otherwise the new PROP VAL pair is added. The new plist is returned;
1862 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1863 The PLIST is modified by side effects. */)
1864 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1866 register Lisp_Object tail
, prev
;
1867 Lisp_Object newcell
;
1869 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1870 tail
= XCDR (XCDR (tail
)))
1872 if (EQ (prop
, XCAR (tail
)))
1874 Fsetcar (XCDR (tail
), val
);
1881 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1885 Fsetcdr (XCDR (prev
), newcell
);
1889 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1890 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1891 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1892 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1894 CHECK_SYMBOL (symbol
);
1896 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
1900 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1901 doc
: /* Extract a value from a property list, comparing with `equal'.
1902 PLIST is a property list, which is a list of the form
1903 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1904 corresponding to the given PROP, or nil if PROP is not
1905 one of the properties on the list. */)
1906 (Lisp_Object plist
, Lisp_Object prop
)
1911 CONSP (tail
) && CONSP (XCDR (tail
));
1912 tail
= XCDR (XCDR (tail
)))
1914 if (! NILP (Fequal (prop
, XCAR (tail
))))
1915 return XCAR (XCDR (tail
));
1920 CHECK_LIST_END (tail
, prop
);
1925 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1926 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1927 PLIST is a property list, which is a list of the form
1928 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1929 If PROP is already a property on the list, its value is set to VAL,
1930 otherwise the new PROP VAL pair is added. The new plist is returned;
1931 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1932 The PLIST is modified by side effects. */)
1933 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1935 register Lisp_Object tail
, prev
;
1936 Lisp_Object newcell
;
1938 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1939 tail
= XCDR (XCDR (tail
)))
1941 if (! NILP (Fequal (prop
, XCAR (tail
))))
1943 Fsetcar (XCDR (tail
), val
);
1950 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1954 Fsetcdr (XCDR (prev
), newcell
);
1958 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1959 doc
: /* Return t if the two args are the same Lisp object.
1960 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1961 (Lisp_Object obj1
, Lisp_Object obj2
)
1964 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1966 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1969 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1970 doc
: /* Return t if two Lisp objects have similar structure and contents.
1971 They must have the same data type.
1972 Conses are compared by comparing the cars and the cdrs.
1973 Vectors and strings are compared element by element.
1974 Numbers are compared by value, but integers cannot equal floats.
1975 (Use `=' if you want integers and floats to be able to be equal.)
1976 Symbols must match exactly. */)
1977 (register Lisp_Object o1
, Lisp_Object o2
)
1979 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1982 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1983 doc
: /* Return t if two Lisp objects have similar structure and contents.
1984 This is like `equal' except that it compares the text properties
1985 of strings. (`equal' ignores text properties.) */)
1986 (register Lisp_Object o1
, Lisp_Object o2
)
1988 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
1991 /* DEPTH is current depth of recursion. Signal an error if it
1993 PROPS means compare string text properties too. */
1996 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
)
1999 error ("Stack overflow in equal");
2005 if (XTYPE (o1
) != XTYPE (o2
))
2014 d1
= extract_float (o1
);
2015 d2
= extract_float (o2
);
2016 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2017 though they are not =. */
2018 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2022 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2029 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2033 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2035 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2038 o1
= XOVERLAY (o1
)->plist
;
2039 o2
= XOVERLAY (o2
)->plist
;
2044 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2045 && (XMARKER (o1
)->buffer
== 0
2046 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2050 case Lisp_Vectorlike
:
2053 ptrdiff_t size
= ASIZE (o1
);
2054 /* Pseudovectors have the type encoded in the size field, so this test
2055 actually checks that the objects have the same type as well as the
2057 if (ASIZE (o2
) != size
)
2059 /* Boolvectors are compared much like strings. */
2060 if (BOOL_VECTOR_P (o1
))
2062 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2064 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2065 ((XBOOL_VECTOR (o1
)->size
2066 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2067 / BOOL_VECTOR_BITS_PER_CHAR
)))
2071 if (WINDOW_CONFIGURATIONP (o1
))
2072 return compare_window_configurations (o1
, o2
, 0);
2074 /* Aside from them, only true vectors, char-tables, compiled
2075 functions, and fonts (font-spec, font-entity, font-object)
2076 are sensible to compare, so eliminate the others now. */
2077 if (size
& PSEUDOVECTOR_FLAG
)
2079 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2082 size
&= PSEUDOVECTOR_SIZE_MASK
;
2084 for (i
= 0; i
< size
; i
++)
2089 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2097 if (SCHARS (o1
) != SCHARS (o2
))
2099 if (SBYTES (o1
) != SBYTES (o2
))
2101 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2103 if (props
&& !compare_string_intervals (o1
, o2
))
2115 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2116 doc
: /* Store each element of ARRAY with ITEM.
2117 ARRAY is a vector, string, char-table, or bool-vector. */)
2118 (Lisp_Object array
, Lisp_Object item
)
2120 register ptrdiff_t size
, idx
;
2122 if (VECTORP (array
))
2123 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2124 ASET (array
, idx
, item
);
2125 else if (CHAR_TABLE_P (array
))
2129 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2130 set_char_table_contents (array
, i
, item
);
2131 set_char_table_defalt (array
, item
);
2133 else if (STRINGP (array
))
2135 register unsigned char *p
= SDATA (array
);
2137 CHECK_CHARACTER (item
);
2138 charval
= XFASTINT (item
);
2139 size
= SCHARS (array
);
2140 if (STRING_MULTIBYTE (array
))
2142 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2143 int len
= CHAR_STRING (charval
, str
);
2144 ptrdiff_t size_byte
= SBYTES (array
);
2146 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2147 || SCHARS (array
) * len
!= size_byte
)
2148 error ("Attempt to change byte length of a string");
2149 for (idx
= 0; idx
< size_byte
; idx
++)
2150 *p
++ = str
[idx
% len
];
2153 for (idx
= 0; idx
< size
; idx
++)
2156 else if (BOOL_VECTOR_P (array
))
2158 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2160 ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2161 / BOOL_VECTOR_BITS_PER_CHAR
);
2165 memset (p
, ! NILP (item
) ? -1 : 0, size
);
2167 /* Clear any extraneous bits in the last byte. */
2168 p
[size
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2172 wrong_type_argument (Qarrayp
, array
);
2176 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2178 doc
: /* Clear the contents of STRING.
2179 This makes STRING unibyte and may change its length. */)
2180 (Lisp_Object string
)
2183 CHECK_STRING (string
);
2184 len
= SBYTES (string
);
2185 memset (SDATA (string
), 0, len
);
2186 STRING_SET_CHARS (string
, len
);
2187 STRING_SET_UNIBYTE (string
);
2193 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2195 Lisp_Object args
[2];
2198 return Fnconc (2, args
);
2201 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2202 doc
: /* Concatenate any number of lists by altering them.
2203 Only the last argument is not altered, and need not be a list.
2204 usage: (nconc &rest LISTS) */)
2205 (ptrdiff_t nargs
, Lisp_Object
*args
)
2208 register Lisp_Object tail
, tem
, val
;
2212 for (argnum
= 0; argnum
< nargs
; argnum
++)
2215 if (NILP (tem
)) continue;
2220 if (argnum
+ 1 == nargs
) break;
2222 CHECK_LIST_CONS (tem
, tem
);
2231 tem
= args
[argnum
+ 1];
2232 Fsetcdr (tail
, tem
);
2234 args
[argnum
+ 1] = tail
;
2240 /* This is the guts of all mapping functions.
2241 Apply FN to each element of SEQ, one by one,
2242 storing the results into elements of VALS, a C vector of Lisp_Objects.
2243 LENI is the length of VALS, which should also be the length of SEQ. */
2246 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2248 register Lisp_Object tail
;
2250 register EMACS_INT i
;
2251 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2255 /* Don't let vals contain any garbage when GC happens. */
2256 for (i
= 0; i
< leni
; i
++)
2259 GCPRO3 (dummy
, fn
, seq
);
2261 gcpro1
.nvars
= leni
;
2265 /* We need not explicitly protect `tail' because it is used only on lists, and
2266 1) lists are not relocated and 2) the list is marked via `seq' so will not
2269 if (VECTORP (seq
) || COMPILEDP (seq
))
2271 for (i
= 0; i
< leni
; i
++)
2273 dummy
= call1 (fn
, AREF (seq
, i
));
2278 else if (BOOL_VECTOR_P (seq
))
2280 for (i
= 0; i
< leni
; i
++)
2283 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2284 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2285 dummy
= call1 (fn
, dummy
);
2290 else if (STRINGP (seq
))
2294 for (i
= 0, i_byte
= 0; i
< leni
;)
2297 ptrdiff_t i_before
= i
;
2299 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2300 XSETFASTINT (dummy
, c
);
2301 dummy
= call1 (fn
, dummy
);
2303 vals
[i_before
] = dummy
;
2306 else /* Must be a list, since Flength did not get an error */
2309 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2311 dummy
= call1 (fn
, XCAR (tail
));
2321 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2322 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2323 In between each pair of results, stick in SEPARATOR. Thus, " " as
2324 SEPARATOR results in spaces between the values returned by FUNCTION.
2325 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2326 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2329 register EMACS_INT leni
;
2332 register Lisp_Object
*args
;
2333 struct gcpro gcpro1
;
2337 len
= Flength (sequence
);
2338 if (CHAR_TABLE_P (sequence
))
2339 wrong_type_argument (Qlistp
, sequence
);
2341 nargs
= leni
+ leni
- 1;
2342 if (nargs
< 0) return empty_unibyte_string
;
2344 SAFE_ALLOCA_LISP (args
, nargs
);
2347 mapcar1 (leni
, args
, function
, sequence
);
2350 for (i
= leni
- 1; i
> 0; i
--)
2351 args
[i
+ i
] = args
[i
];
2353 for (i
= 1; i
< nargs
; i
+= 2)
2354 args
[i
] = separator
;
2356 ret
= Fconcat (nargs
, args
);
2362 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2363 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2364 The result is a list just as long as SEQUENCE.
2365 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2366 (Lisp_Object function
, Lisp_Object sequence
)
2368 register Lisp_Object len
;
2369 register EMACS_INT leni
;
2370 register Lisp_Object
*args
;
2374 len
= Flength (sequence
);
2375 if (CHAR_TABLE_P (sequence
))
2376 wrong_type_argument (Qlistp
, sequence
);
2377 leni
= XFASTINT (len
);
2379 SAFE_ALLOCA_LISP (args
, leni
);
2381 mapcar1 (leni
, args
, function
, sequence
);
2383 ret
= Flist (leni
, args
);
2389 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2390 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2391 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2392 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2393 (Lisp_Object function
, Lisp_Object sequence
)
2395 register EMACS_INT leni
;
2397 leni
= XFASTINT (Flength (sequence
));
2398 if (CHAR_TABLE_P (sequence
))
2399 wrong_type_argument (Qlistp
, sequence
);
2400 mapcar1 (leni
, 0, function
, sequence
);
2405 /* This is how C code calls `yes-or-no-p' and allows the user
2408 Anything that calls this function must protect from GC! */
2411 do_yes_or_no_p (Lisp_Object prompt
)
2413 return call1 (intern ("yes-or-no-p"), prompt
);
2416 /* Anything that calls this function must protect from GC! */
2418 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2419 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2420 PROMPT is the string to display to ask the question. It should end in
2421 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2423 The user must confirm the answer with RET, and can edit it until it
2426 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2427 is nil, and `use-dialog-box' is non-nil. */)
2428 (Lisp_Object prompt
)
2430 register Lisp_Object ans
;
2431 Lisp_Object args
[2];
2432 struct gcpro gcpro1
;
2434 CHECK_STRING (prompt
);
2437 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2438 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2442 Lisp_Object pane
, menu
, obj
;
2443 redisplay_preserve_echo_area (4);
2444 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2445 Fcons (Fcons (build_string ("No"), Qnil
),
2448 menu
= Fcons (prompt
, pane
);
2449 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2453 #endif /* HAVE_MENUS */
2456 args
[1] = build_string ("(yes or no) ");
2457 prompt
= Fconcat (2, args
);
2463 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2464 Qyes_or_no_p_history
, Qnil
,
2466 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2471 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2479 message ("Please answer yes or no.");
2480 Fsleep_for (make_number (2), Qnil
);
2484 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2485 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2487 Each of the three load averages is multiplied by 100, then converted
2490 When USE-FLOATS is non-nil, floats will be used instead of integers.
2491 These floats are not multiplied by 100.
2493 If the 5-minute or 15-minute load averages are not available, return a
2494 shortened list, containing only those averages which are available.
2496 An error is thrown if the load average can't be obtained. In some
2497 cases making it work would require Emacs being installed setuid or
2498 setgid so that it can read kernel information, and that usually isn't
2500 (Lisp_Object use_floats
)
2503 int loads
= getloadavg (load_ave
, 3);
2504 Lisp_Object ret
= Qnil
;
2507 error ("load-average not implemented for this operating system");
2511 Lisp_Object load
= (NILP (use_floats
)
2512 ? make_number (100.0 * load_ave
[loads
])
2513 : make_float (load_ave
[loads
]));
2514 ret
= Fcons (load
, ret
);
2520 static Lisp_Object Qsubfeatures
;
2522 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2523 doc
: /* Return t if FEATURE is present in this Emacs.
2525 Use this to conditionalize execution of lisp code based on the
2526 presence or absence of Emacs or environment extensions.
2527 Use `provide' to declare that a feature is available. This function
2528 looks at the value of the variable `features'. The optional argument
2529 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2530 (Lisp_Object feature
, Lisp_Object subfeature
)
2532 register Lisp_Object tem
;
2533 CHECK_SYMBOL (feature
);
2534 tem
= Fmemq (feature
, Vfeatures
);
2535 if (!NILP (tem
) && !NILP (subfeature
))
2536 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2537 return (NILP (tem
)) ? Qnil
: Qt
;
2540 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2541 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2542 The optional argument SUBFEATURES should be a list of symbols listing
2543 particular subfeatures supported in this version of FEATURE. */)
2544 (Lisp_Object feature
, Lisp_Object subfeatures
)
2546 register Lisp_Object tem
;
2547 CHECK_SYMBOL (feature
);
2548 CHECK_LIST (subfeatures
);
2549 if (!NILP (Vautoload_queue
))
2550 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2552 tem
= Fmemq (feature
, Vfeatures
);
2554 Vfeatures
= Fcons (feature
, Vfeatures
);
2555 if (!NILP (subfeatures
))
2556 Fput (feature
, Qsubfeatures
, subfeatures
);
2557 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2559 /* Run any load-hooks for this file. */
2560 tem
= Fassq (feature
, Vafter_load_alist
);
2562 Fprogn (XCDR (tem
));
2567 /* `require' and its subroutines. */
2569 /* List of features currently being require'd, innermost first. */
2571 static Lisp_Object require_nesting_list
;
2574 require_unwind (Lisp_Object old_value
)
2576 return require_nesting_list
= old_value
;
2579 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2580 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2581 If FEATURE is not a member of the list `features', then the feature
2582 is not loaded; so load the file FILENAME.
2583 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2584 and `load' will try to load this name appended with the suffix `.elc' or
2585 `.el', in that order. The name without appended suffix will not be used.
2586 See `get-load-suffixes' for the complete list of suffixes.
2587 If the optional third argument NOERROR is non-nil,
2588 then return nil if the file is not found instead of signaling an error.
2589 Normally the return value is FEATURE.
2590 The normal messages at start and end of loading FILENAME are suppressed. */)
2591 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2594 struct gcpro gcpro1
, gcpro2
;
2595 bool from_file
= load_in_progress
;
2597 CHECK_SYMBOL (feature
);
2599 /* Record the presence of `require' in this file
2600 even if the feature specified is already loaded.
2601 But not more than once in any file,
2602 and not when we aren't loading or reading from a file. */
2604 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2605 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2610 tem
= Fcons (Qrequire
, feature
);
2611 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2612 LOADHIST_ATTACH (tem
);
2614 tem
= Fmemq (feature
, Vfeatures
);
2618 ptrdiff_t count
= SPECPDL_INDEX ();
2621 /* This is to make sure that loadup.el gives a clear picture
2622 of what files are preloaded and when. */
2623 if (! NILP (Vpurify_flag
))
2624 error ("(require %s) while preparing to dump",
2625 SDATA (SYMBOL_NAME (feature
)));
2627 /* A certain amount of recursive `require' is legitimate,
2628 but if we require the same feature recursively 3 times,
2630 tem
= require_nesting_list
;
2631 while (! NILP (tem
))
2633 if (! NILP (Fequal (feature
, XCAR (tem
))))
2638 error ("Recursive `require' for feature `%s'",
2639 SDATA (SYMBOL_NAME (feature
)));
2641 /* Update the list for any nested `require's that occur. */
2642 record_unwind_protect (require_unwind
, require_nesting_list
);
2643 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2645 /* Value saved here is to be restored into Vautoload_queue */
2646 record_unwind_protect (un_autoload
, Vautoload_queue
);
2647 Vautoload_queue
= Qt
;
2649 /* Load the file. */
2650 GCPRO2 (feature
, filename
);
2651 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2652 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2655 /* If load failed entirely, return nil. */
2657 return unbind_to (count
, Qnil
);
2659 tem
= Fmemq (feature
, Vfeatures
);
2661 error ("Required feature `%s' was not provided",
2662 SDATA (SYMBOL_NAME (feature
)));
2664 /* Once loading finishes, don't undo it. */
2665 Vautoload_queue
= Qt
;
2666 feature
= unbind_to (count
, feature
);
2672 /* Primitives for work of the "widget" library.
2673 In an ideal world, this section would not have been necessary.
2674 However, lisp function calls being as slow as they are, it turns
2675 out that some functions in the widget library (wid-edit.el) are the
2676 bottleneck of Widget operation. Here is their translation to C,
2677 for the sole reason of efficiency. */
2679 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2680 doc
: /* Return non-nil if PLIST has the property PROP.
2681 PLIST is a property list, which is a list of the form
2682 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2683 Unlike `plist-get', this allows you to distinguish between a missing
2684 property and a property with the value nil.
2685 The value is actually the tail of PLIST whose car is PROP. */)
2686 (Lisp_Object plist
, Lisp_Object prop
)
2688 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2691 plist
= XCDR (plist
);
2692 plist
= CDR (plist
);
2697 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2698 doc
: /* In WIDGET, set PROPERTY to VALUE.
2699 The value can later be retrieved with `widget-get'. */)
2700 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2702 CHECK_CONS (widget
);
2703 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2707 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2708 doc
: /* In WIDGET, get the value of PROPERTY.
2709 The value could either be specified when the widget was created, or
2710 later with `widget-put'. */)
2711 (Lisp_Object widget
, Lisp_Object property
)
2719 CHECK_CONS (widget
);
2720 tmp
= Fplist_member (XCDR (widget
), property
);
2726 tmp
= XCAR (widget
);
2729 widget
= Fget (tmp
, Qwidget_type
);
2733 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2734 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2735 ARGS are passed as extra arguments to the function.
2736 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2737 (ptrdiff_t nargs
, Lisp_Object
*args
)
2739 /* This function can GC. */
2740 Lisp_Object newargs
[3];
2741 struct gcpro gcpro1
, gcpro2
;
2744 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2745 newargs
[1] = args
[0];
2746 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2747 GCPRO2 (newargs
[0], newargs
[2]);
2748 result
= Fapply (3, newargs
);
2753 #ifdef HAVE_LANGINFO_CODESET
2754 #include <langinfo.h>
2757 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2758 doc
: /* Access locale data ITEM for the current C locale, if available.
2759 ITEM should be one of the following:
2761 `codeset', returning the character set as a string (locale item CODESET);
2763 `days', returning a 7-element vector of day names (locale items DAY_n);
2765 `months', returning a 12-element vector of month names (locale items MON_n);
2767 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2768 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2770 If the system can't provide such information through a call to
2771 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2773 See also Info node `(libc)Locales'.
2775 The data read from the system are decoded using `locale-coding-system'. */)
2779 #ifdef HAVE_LANGINFO_CODESET
2781 if (EQ (item
, Qcodeset
))
2783 str
= nl_langinfo (CODESET
);
2784 return build_string (str
);
2787 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2789 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2790 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2792 struct gcpro gcpro1
;
2794 synchronize_system_time_locale ();
2795 for (i
= 0; i
< 7; i
++)
2797 str
= nl_langinfo (days
[i
]);
2798 val
= build_unibyte_string (str
);
2799 /* Fixme: Is this coding system necessarily right, even if
2800 it is consistent with CODESET? If not, what to do? */
2801 Faset (v
, make_number (i
),
2802 code_convert_string_norecord (val
, Vlocale_coding_system
,
2810 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2812 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2813 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2814 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2816 struct gcpro gcpro1
;
2818 synchronize_system_time_locale ();
2819 for (i
= 0; i
< 12; i
++)
2821 str
= nl_langinfo (months
[i
]);
2822 val
= build_unibyte_string (str
);
2823 Faset (v
, make_number (i
),
2824 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2830 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2831 but is in the locale files. This could be used by ps-print. */
2833 else if (EQ (item
, Qpaper
))
2835 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2836 make_number (nl_langinfo (PAPER_HEIGHT
)));
2838 #endif /* PAPER_WIDTH */
2839 #endif /* HAVE_LANGINFO_CODESET*/
2843 /* base64 encode/decode functions (RFC 2045).
2844 Based on code from GNU recode. */
2846 #define MIME_LINE_LENGTH 76
2848 #define IS_ASCII(Character) \
2850 #define IS_BASE64(Character) \
2851 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2852 #define IS_BASE64_IGNORABLE(Character) \
2853 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2854 || (Character) == '\f' || (Character) == '\r')
2856 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2857 character or return retval if there are no characters left to
2859 #define READ_QUADRUPLET_BYTE(retval) \
2864 if (nchars_return) \
2865 *nchars_return = nchars; \
2870 while (IS_BASE64_IGNORABLE (c))
2872 /* Table of characters coding the 64 values. */
2873 static const char base64_value_to_char
[64] =
2875 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2876 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2877 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2878 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2879 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2880 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2881 '8', '9', '+', '/' /* 60-63 */
2884 /* Table of base64 values for first 128 characters. */
2885 static const short base64_char_to_value
[128] =
2887 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2888 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2889 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2890 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2891 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2892 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2893 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2894 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2895 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2896 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2897 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2898 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2899 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2902 /* The following diagram shows the logical steps by which three octets
2903 get transformed into four base64 characters.
2905 .--------. .--------. .--------.
2906 |aaaaaabb| |bbbbcccc| |ccdddddd|
2907 `--------' `--------' `--------'
2909 .--------+--------+--------+--------.
2910 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2911 `--------+--------+--------+--------'
2913 .--------+--------+--------+--------.
2914 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2915 `--------+--------+--------+--------'
2917 The octets are divided into 6 bit chunks, which are then encoded into
2918 base64 characters. */
2921 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
2922 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
2925 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2927 doc
: /* Base64-encode the region between BEG and END.
2928 Return the length of the encoded text.
2929 Optional third argument NO-LINE-BREAK means do not break long lines
2930 into shorter lines. */)
2931 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2934 ptrdiff_t allength
, length
;
2935 ptrdiff_t ibeg
, iend
, encoded_length
;
2936 ptrdiff_t old_pos
= PT
;
2939 validate_region (&beg
, &end
);
2941 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2942 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2943 move_gap_both (XFASTINT (beg
), ibeg
);
2945 /* We need to allocate enough room for encoding the text.
2946 We need 33 1/3% more space, plus a newline every 76
2947 characters, and then we round up. */
2948 length
= iend
- ibeg
;
2949 allength
= length
+ length
/3 + 1;
2950 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2952 encoded
= SAFE_ALLOCA (allength
);
2953 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2954 encoded
, length
, NILP (no_line_break
),
2955 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2956 if (encoded_length
> allength
)
2959 if (encoded_length
< 0)
2961 /* The encoding wasn't possible. */
2963 error ("Multibyte character in data for base64 encoding");
2966 /* Now we have encoded the region, so we insert the new contents
2967 and delete the old. (Insert first in order to preserve markers.) */
2968 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2969 insert (encoded
, encoded_length
);
2971 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2973 /* If point was outside of the region, restore it exactly; else just
2974 move to the beginning of the region. */
2975 if (old_pos
>= XFASTINT (end
))
2976 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2977 else if (old_pos
> XFASTINT (beg
))
2978 old_pos
= XFASTINT (beg
);
2981 /* We return the length of the encoded text. */
2982 return make_number (encoded_length
);
2985 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2987 doc
: /* Base64-encode STRING and return the result.
2988 Optional second argument NO-LINE-BREAK means do not break long lines
2989 into shorter lines. */)
2990 (Lisp_Object string
, Lisp_Object no_line_break
)
2992 ptrdiff_t allength
, length
, encoded_length
;
2994 Lisp_Object encoded_string
;
2997 CHECK_STRING (string
);
2999 /* We need to allocate enough room for encoding the text.
3000 We need 33 1/3% more space, plus a newline every 76
3001 characters, and then we round up. */
3002 length
= SBYTES (string
);
3003 allength
= length
+ length
/3 + 1;
3004 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3006 /* We need to allocate enough room for decoding the text. */
3007 encoded
= SAFE_ALLOCA (allength
);
3009 encoded_length
= base64_encode_1 (SSDATA (string
),
3010 encoded
, length
, NILP (no_line_break
),
3011 STRING_MULTIBYTE (string
));
3012 if (encoded_length
> allength
)
3015 if (encoded_length
< 0)
3017 /* The encoding wasn't possible. */
3019 error ("Multibyte character in data for base64 encoding");
3022 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3025 return encoded_string
;
3029 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3030 bool line_break
, bool multibyte
)
3043 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3044 if (CHAR_BYTE8_P (c
))
3045 c
= CHAR_TO_BYTE8 (c
);
3053 /* Wrap line every 76 characters. */
3057 if (counter
< MIME_LINE_LENGTH
/ 4)
3066 /* Process first byte of a triplet. */
3068 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3069 value
= (0x03 & c
) << 4;
3071 /* Process second byte of a triplet. */
3075 *e
++ = base64_value_to_char
[value
];
3083 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3084 if (CHAR_BYTE8_P (c
))
3085 c
= CHAR_TO_BYTE8 (c
);
3093 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3094 value
= (0x0f & c
) << 2;
3096 /* Process third byte of a triplet. */
3100 *e
++ = base64_value_to_char
[value
];
3107 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3108 if (CHAR_BYTE8_P (c
))
3109 c
= CHAR_TO_BYTE8 (c
);
3117 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3118 *e
++ = base64_value_to_char
[0x3f & c
];
3125 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3127 doc
: /* Base64-decode the region between BEG and END.
3128 Return the length of the decoded text.
3129 If the region can't be decoded, signal an error and don't modify the buffer. */)
3130 (Lisp_Object beg
, Lisp_Object end
)
3132 ptrdiff_t ibeg
, iend
, length
, allength
;
3134 ptrdiff_t old_pos
= PT
;
3135 ptrdiff_t decoded_length
;
3136 ptrdiff_t inserted_chars
;
3137 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3140 validate_region (&beg
, &end
);
3142 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3143 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3145 length
= iend
- ibeg
;
3147 /* We need to allocate enough room for decoding the text. If we are
3148 working on a multibyte buffer, each decoded code may occupy at
3150 allength
= multibyte
? length
* 2 : length
;
3151 decoded
= SAFE_ALLOCA (allength
);
3153 move_gap_both (XFASTINT (beg
), ibeg
);
3154 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3156 multibyte
, &inserted_chars
);
3157 if (decoded_length
> allength
)
3160 if (decoded_length
< 0)
3162 /* The decoding wasn't possible. */
3164 error ("Invalid base64 data");
3167 /* Now we have decoded the region, so we insert the new contents
3168 and delete the old. (Insert first in order to preserve markers.) */
3169 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3170 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3173 /* Delete the original text. */
3174 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3175 iend
+ decoded_length
, 1);
3177 /* If point was outside of the region, restore it exactly; else just
3178 move to the beginning of the region. */
3179 if (old_pos
>= XFASTINT (end
))
3180 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3181 else if (old_pos
> XFASTINT (beg
))
3182 old_pos
= XFASTINT (beg
);
3183 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3185 return make_number (inserted_chars
);
3188 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3190 doc
: /* Base64-decode STRING and return the result. */)
3191 (Lisp_Object string
)
3194 ptrdiff_t length
, decoded_length
;
3195 Lisp_Object decoded_string
;
3198 CHECK_STRING (string
);
3200 length
= SBYTES (string
);
3201 /* We need to allocate enough room for decoding the text. */
3202 decoded
= SAFE_ALLOCA (length
);
3204 /* The decoded result should be unibyte. */
3205 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3207 if (decoded_length
> length
)
3209 else if (decoded_length
>= 0)
3210 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3212 decoded_string
= Qnil
;
3215 if (!STRINGP (decoded_string
))
3216 error ("Invalid base64 data");
3218 return decoded_string
;
3221 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3222 MULTIBYTE, the decoded result should be in multibyte
3223 form. If NCHARS_RETURN is not NULL, store the number of produced
3224 characters in *NCHARS_RETURN. */
3227 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3228 bool multibyte
, ptrdiff_t *nchars_return
)
3230 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3233 unsigned long value
;
3234 ptrdiff_t nchars
= 0;
3238 /* Process first byte of a quadruplet. */
3240 READ_QUADRUPLET_BYTE (e
-to
);
3244 value
= base64_char_to_value
[c
] << 18;
3246 /* Process second byte of a quadruplet. */
3248 READ_QUADRUPLET_BYTE (-1);
3252 value
|= base64_char_to_value
[c
] << 12;
3254 c
= (unsigned char) (value
>> 16);
3255 if (multibyte
&& c
>= 128)
3256 e
+= BYTE8_STRING (c
, e
);
3261 /* Process third byte of a quadruplet. */
3263 READ_QUADRUPLET_BYTE (-1);
3267 READ_QUADRUPLET_BYTE (-1);
3276 value
|= base64_char_to_value
[c
] << 6;
3278 c
= (unsigned char) (0xff & value
>> 8);
3279 if (multibyte
&& c
>= 128)
3280 e
+= BYTE8_STRING (c
, e
);
3285 /* Process fourth byte of a quadruplet. */
3287 READ_QUADRUPLET_BYTE (-1);
3294 value
|= base64_char_to_value
[c
];
3296 c
= (unsigned char) (0xff & value
);
3297 if (multibyte
&& c
>= 128)
3298 e
+= BYTE8_STRING (c
, e
);
3307 /***********************************************************************
3309 ***** Hash Tables *****
3311 ***********************************************************************/
3313 /* Implemented by gerd@gnu.org. This hash table implementation was
3314 inspired by CMUCL hash tables. */
3318 1. For small tables, association lists are probably faster than
3319 hash tables because they have lower overhead.
3321 For uses of hash tables where the O(1) behavior of table
3322 operations is not a requirement, it might therefore be a good idea
3323 not to hash. Instead, we could just do a linear search in the
3324 key_and_value vector of the hash table. This could be done
3325 if a `:linear-search t' argument is given to make-hash-table. */
3328 /* The list of all weak hash tables. Don't staticpro this one. */
3330 static struct Lisp_Hash_Table
*weak_hash_tables
;
3332 /* Various symbols. */
3334 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
, Qeql
;
3335 Lisp_Object Qeq
, Qequal
;
3336 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3337 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3340 /***********************************************************************
3342 ***********************************************************************/
3344 /* If OBJ is a Lisp hash table, return a pointer to its struct
3345 Lisp_Hash_Table. Otherwise, signal an error. */
3347 static struct Lisp_Hash_Table
*
3348 check_hash_table (Lisp_Object obj
)
3350 CHECK_HASH_TABLE (obj
);
3351 return XHASH_TABLE (obj
);
3355 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3356 number. A number is "almost" a prime number if it is not divisible
3357 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3360 next_almost_prime (EMACS_INT n
)
3362 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3363 for (n
|= 1; ; n
+= 2)
3364 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3369 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3370 which USED[I] is non-zero. If found at index I in ARGS, set
3371 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3372 0. This function is used to extract a keyword/argument pair from
3373 a DEFUN parameter list. */
3376 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3380 for (i
= 1; i
< nargs
; i
++)
3381 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3392 /* Return a Lisp vector which has the same contents as VEC but has
3393 at least INCR_MIN more entries, where INCR_MIN is positive.
3394 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3395 than NITEMS_MAX. Entries in the resulting
3396 vector that are not copied from VEC are set to nil. */
3399 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3401 struct Lisp_Vector
*v
;
3402 ptrdiff_t i
, incr
, incr_max
, old_size
, new_size
;
3403 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3404 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3405 ? nitems_max
: C_language_max
);
3406 eassert (VECTORP (vec
));
3407 eassert (0 < incr_min
&& -1 <= nitems_max
);
3408 old_size
= ASIZE (vec
);
3409 incr_max
= n_max
- old_size
;
3410 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3411 if (incr_max
< incr
)
3412 memory_full (SIZE_MAX
);
3413 new_size
= old_size
+ incr
;
3414 v
= allocate_vector (new_size
);
3415 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3416 for (i
= old_size
; i
< new_size
; ++i
)
3417 v
->contents
[i
] = Qnil
;
3418 XSETVECTOR (vec
, v
);
3423 /***********************************************************************
3425 ***********************************************************************/
3427 static struct hash_table_test hashtest_eq
;
3428 struct hash_table_test hashtest_eql
, hashtest_equal
;
3430 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3431 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3432 KEY2 are the same. */
3435 cmpfn_eql (struct hash_table_test
*ht
,
3439 return (FLOATP (key1
)
3441 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3445 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3446 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3447 KEY2 are the same. */
3450 cmpfn_equal (struct hash_table_test
*ht
,
3454 return !NILP (Fequal (key1
, key2
));
3458 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3459 HASH2 in hash table H using H->user_cmp_function. Value is true
3460 if KEY1 and KEY2 are the same. */
3463 cmpfn_user_defined (struct hash_table_test
*ht
,
3467 Lisp_Object args
[3];
3469 args
[0] = ht
->user_cmp_function
;
3472 return !NILP (Ffuncall (3, args
));
3476 /* Value is a hash code for KEY for use in hash table H which uses
3477 `eq' to compare keys. The hash code returned is guaranteed to fit
3478 in a Lisp integer. */
3481 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3483 EMACS_UINT hash
= XHASH (key
) ^ XTYPE (key
);
3487 /* Value is a hash code for KEY for use in hash table H which uses
3488 `eql' to compare keys. The hash code returned is guaranteed to fit
3489 in a Lisp integer. */
3492 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3496 hash
= sxhash (key
, 0);
3498 hash
= XHASH (key
) ^ XTYPE (key
);
3502 /* Value is a hash code for KEY for use in hash table H which uses
3503 `equal' to compare keys. The hash code returned is guaranteed to fit
3504 in a Lisp integer. */
3507 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3509 EMACS_UINT hash
= sxhash (key
, 0);
3513 /* Value is a hash code for KEY for use in hash table H which uses as
3514 user-defined function to compare keys. The hash code returned is
3515 guaranteed to fit in a Lisp integer. */
3518 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3520 Lisp_Object args
[2], hash
;
3522 args
[0] = ht
->user_hash_function
;
3524 hash
= Ffuncall (2, args
);
3525 if (!INTEGERP (hash
))
3526 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3527 return XUINT (hash
);
3530 /* An upper bound on the size of a hash table index. It must fit in
3531 ptrdiff_t and be a valid Emacs fixnum. */
3532 #define INDEX_SIZE_BOUND \
3533 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3535 /* Create and initialize a new hash table.
3537 TEST specifies the test the hash table will use to compare keys.
3538 It must be either one of the predefined tests `eq', `eql' or
3539 `equal' or a symbol denoting a user-defined test named TEST with
3540 test and hash functions USER_TEST and USER_HASH.
3542 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3544 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3545 new size when it becomes full is computed by adding REHASH_SIZE to
3546 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3547 table's new size is computed by multiplying its old size with
3550 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3551 be resized when the ratio of (number of entries in the table) /
3552 (table size) is >= REHASH_THRESHOLD.
3554 WEAK specifies the weakness of the table. If non-nil, it must be
3555 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3558 make_hash_table (struct hash_table_test test
,
3559 Lisp_Object size
, Lisp_Object rehash_size
,
3560 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3562 struct Lisp_Hash_Table
*h
;
3564 EMACS_INT index_size
, sz
;
3568 /* Preconditions. */
3569 eassert (SYMBOLP (test
.name
));
3570 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3571 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3572 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3573 eassert (FLOATP (rehash_threshold
)
3574 && 0 < XFLOAT_DATA (rehash_threshold
)
3575 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3577 if (XFASTINT (size
) == 0)
3578 size
= make_number (1);
3580 sz
= XFASTINT (size
);
3581 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3582 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3583 ? next_almost_prime (index_float
)
3584 : INDEX_SIZE_BOUND
+ 1);
3585 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3586 error ("Hash table too large");
3588 /* Allocate a table and initialize it. */
3589 h
= allocate_hash_table ();
3591 /* Initialize hash table slots. */
3594 h
->rehash_threshold
= rehash_threshold
;
3595 h
->rehash_size
= rehash_size
;
3597 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3598 h
->hash
= Fmake_vector (size
, Qnil
);
3599 h
->next
= Fmake_vector (size
, Qnil
);
3600 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3602 /* Set up the free list. */
3603 for (i
= 0; i
< sz
- 1; ++i
)
3604 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3605 h
->next_free
= make_number (0);
3607 XSET_HASH_TABLE (table
, h
);
3608 eassert (HASH_TABLE_P (table
));
3609 eassert (XHASH_TABLE (table
) == h
);
3611 /* Maybe add this hash table to the list of all weak hash tables. */
3613 h
->next_weak
= NULL
;
3616 h
->next_weak
= weak_hash_tables
;
3617 weak_hash_tables
= h
;
3624 /* Return a copy of hash table H1. Keys and values are not copied,
3625 only the table itself is. */
3628 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3631 struct Lisp_Hash_Table
*h2
;
3633 h2
= allocate_hash_table ();
3635 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3636 h2
->hash
= Fcopy_sequence (h1
->hash
);
3637 h2
->next
= Fcopy_sequence (h1
->next
);
3638 h2
->index
= Fcopy_sequence (h1
->index
);
3639 XSET_HASH_TABLE (table
, h2
);
3641 /* Maybe add this hash table to the list of all weak hash tables. */
3642 if (!NILP (h2
->weak
))
3644 h2
->next_weak
= weak_hash_tables
;
3645 weak_hash_tables
= h2
;
3652 /* Resize hash table H if it's too full. If H cannot be resized
3653 because it's already too large, throw an error. */
3656 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3658 if (NILP (h
->next_free
))
3660 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3661 EMACS_INT new_size
, index_size
, nsize
;
3665 if (INTEGERP (h
->rehash_size
))
3666 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3669 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3670 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3672 new_size
= float_new_size
;
3673 if (new_size
<= old_size
)
3674 new_size
= old_size
+ 1;
3677 new_size
= INDEX_SIZE_BOUND
+ 1;
3679 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3680 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3681 ? next_almost_prime (index_float
)
3682 : INDEX_SIZE_BOUND
+ 1);
3683 nsize
= max (index_size
, 2 * new_size
);
3684 if (INDEX_SIZE_BOUND
< nsize
)
3685 error ("Hash table too large to resize");
3687 #ifdef ENABLE_CHECKING
3688 if (HASH_TABLE_P (Vpurify_flag
)
3689 && XHASH_TABLE (Vpurify_flag
) == h
)
3691 Lisp_Object args
[2];
3692 args
[0] = build_string ("Growing hash table to: %d");
3693 args
[1] = make_number (new_size
);
3698 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3699 2 * (new_size
- old_size
), -1));
3700 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3701 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3702 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3704 /* Update the free list. Do it so that new entries are added at
3705 the end of the free list. This makes some operations like
3707 for (i
= old_size
; i
< new_size
- 1; ++i
)
3708 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3710 if (!NILP (h
->next_free
))
3712 Lisp_Object last
, next
;
3714 last
= h
->next_free
;
3715 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3719 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3722 XSETFASTINT (h
->next_free
, old_size
);
3725 for (i
= 0; i
< old_size
; ++i
)
3726 if (!NILP (HASH_HASH (h
, i
)))
3728 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3729 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3730 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3731 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3737 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3738 the hash code of KEY. Value is the index of the entry in H
3739 matching KEY, or -1 if not found. */
3742 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3744 EMACS_UINT hash_code
;
3745 ptrdiff_t start_of_bucket
;
3748 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3749 eassert ((hash_code
& ~INTMASK
) == 0);
3753 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3754 idx
= HASH_INDEX (h
, start_of_bucket
);
3756 /* We need not gcpro idx since it's either an integer or nil. */
3759 ptrdiff_t i
= XFASTINT (idx
);
3760 if (EQ (key
, HASH_KEY (h
, i
))
3762 && hash_code
== XUINT (HASH_HASH (h
, i
))
3763 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3765 idx
= HASH_NEXT (h
, i
);
3768 return NILP (idx
) ? -1 : XFASTINT (idx
);
3772 /* Put an entry into hash table H that associates KEY with VALUE.
3773 HASH is a previously computed hash code of KEY.
3774 Value is the index of the entry in H matching KEY. */
3777 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3780 ptrdiff_t start_of_bucket
, i
;
3782 eassert ((hash
& ~INTMASK
) == 0);
3784 /* Increment count after resizing because resizing may fail. */
3785 maybe_resize_hash_table (h
);
3788 /* Store key/value in the key_and_value vector. */
3789 i
= XFASTINT (h
->next_free
);
3790 h
->next_free
= HASH_NEXT (h
, i
);
3791 set_hash_key_slot (h
, i
, key
);
3792 set_hash_value_slot (h
, i
, value
);
3794 /* Remember its hash code. */
3795 set_hash_hash_slot (h
, i
, make_number (hash
));
3797 /* Add new entry to its collision chain. */
3798 start_of_bucket
= hash
% ASIZE (h
->index
);
3799 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3800 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3805 /* Remove the entry matching KEY from hash table H, if there is one. */
3808 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3810 EMACS_UINT hash_code
;
3811 ptrdiff_t start_of_bucket
;
3812 Lisp_Object idx
, prev
;
3814 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3815 eassert ((hash_code
& ~INTMASK
) == 0);
3816 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3817 idx
= HASH_INDEX (h
, start_of_bucket
);
3820 /* We need not gcpro idx, prev since they're either integers or nil. */
3823 ptrdiff_t i
= XFASTINT (idx
);
3825 if (EQ (key
, HASH_KEY (h
, i
))
3827 && hash_code
== XUINT (HASH_HASH (h
, i
))
3828 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3830 /* Take entry out of collision chain. */
3832 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3834 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3836 /* Clear slots in key_and_value and add the slots to
3838 set_hash_key_slot (h
, i
, Qnil
);
3839 set_hash_value_slot (h
, i
, Qnil
);
3840 set_hash_hash_slot (h
, i
, Qnil
);
3841 set_hash_next_slot (h
, i
, h
->next_free
);
3842 h
->next_free
= make_number (i
);
3844 eassert (h
->count
>= 0);
3850 idx
= HASH_NEXT (h
, i
);
3856 /* Clear hash table H. */
3859 hash_clear (struct Lisp_Hash_Table
*h
)
3863 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3865 for (i
= 0; i
< size
; ++i
)
3867 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3868 set_hash_key_slot (h
, i
, Qnil
);
3869 set_hash_value_slot (h
, i
, Qnil
);
3870 set_hash_hash_slot (h
, i
, Qnil
);
3873 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3874 ASET (h
->index
, i
, Qnil
);
3876 h
->next_free
= make_number (0);
3883 /************************************************************************
3885 ************************************************************************/
3887 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3888 entries from the table that don't survive the current GC.
3889 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3890 true if anything was marked. */
3893 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3895 ptrdiff_t bucket
, n
;
3898 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3901 for (bucket
= 0; bucket
< n
; ++bucket
)
3903 Lisp_Object idx
, next
, prev
;
3905 /* Follow collision chain, removing entries that
3906 don't survive this garbage collection. */
3908 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3910 ptrdiff_t i
= XFASTINT (idx
);
3911 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3912 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3915 if (EQ (h
->weak
, Qkey
))
3916 remove_p
= !key_known_to_survive_p
;
3917 else if (EQ (h
->weak
, Qvalue
))
3918 remove_p
= !value_known_to_survive_p
;
3919 else if (EQ (h
->weak
, Qkey_or_value
))
3920 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3921 else if (EQ (h
->weak
, Qkey_and_value
))
3922 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3926 next
= HASH_NEXT (h
, i
);
3928 if (remove_entries_p
)
3932 /* Take out of collision chain. */
3934 set_hash_index_slot (h
, bucket
, next
);
3936 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3938 /* Add to free list. */
3939 set_hash_next_slot (h
, i
, h
->next_free
);
3942 /* Clear key, value, and hash. */
3943 set_hash_key_slot (h
, i
, Qnil
);
3944 set_hash_value_slot (h
, i
, Qnil
);
3945 set_hash_hash_slot (h
, i
, Qnil
);
3958 /* Make sure key and value survive. */
3959 if (!key_known_to_survive_p
)
3961 mark_object (HASH_KEY (h
, i
));
3965 if (!value_known_to_survive_p
)
3967 mark_object (HASH_VALUE (h
, i
));
3978 /* Remove elements from weak hash tables that don't survive the
3979 current garbage collection. Remove weak tables that don't survive
3980 from Vweak_hash_tables. Called from gc_sweep. */
3983 sweep_weak_hash_tables (void)
3985 struct Lisp_Hash_Table
*h
, *used
, *next
;
3988 /* Mark all keys and values that are in use. Keep on marking until
3989 there is no more change. This is necessary for cases like
3990 value-weak table A containing an entry X -> Y, where Y is used in a
3991 key-weak table B, Z -> Y. If B comes after A in the list of weak
3992 tables, X -> Y might be removed from A, although when looking at B
3993 one finds that it shouldn't. */
3997 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
3999 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4000 marked
|= sweep_weak_table (h
, 0);
4005 /* Remove tables and entries that aren't used. */
4006 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4008 next
= h
->next_weak
;
4010 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4012 /* TABLE is marked as used. Sweep its contents. */
4014 sweep_weak_table (h
, 1);
4016 /* Add table to the list of used weak hash tables. */
4017 h
->next_weak
= used
;
4022 weak_hash_tables
= used
;
4027 /***********************************************************************
4028 Hash Code Computation
4029 ***********************************************************************/
4031 /* Maximum depth up to which to dive into Lisp structures. */
4033 #define SXHASH_MAX_DEPTH 3
4035 /* Maximum length up to which to take list and vector elements into
4038 #define SXHASH_MAX_LEN 7
4040 /* Hash X, returning a value that fits into a Lisp integer. */
4041 #define SXHASH_REDUCE(X) \
4042 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4044 /* Return a hash for string PTR which has length LEN. The hash value
4045 can be any EMACS_UINT value. */
4048 hash_string (char const *ptr
, ptrdiff_t len
)
4050 char const *p
= ptr
;
4051 char const *end
= p
+ len
;
4053 EMACS_UINT hash
= 0;
4058 hash
= sxhash_combine (hash
, c
);
4064 /* Return a hash for string PTR which has length LEN. The hash
4065 code returned is guaranteed to fit in a Lisp integer. */
4068 sxhash_string (char const *ptr
, ptrdiff_t len
)
4070 EMACS_UINT hash
= hash_string (ptr
, len
);
4071 return SXHASH_REDUCE (hash
);
4074 /* Return a hash for the floating point value VAL. */
4077 sxhash_float (double val
)
4079 EMACS_UINT hash
= 0;
4081 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4082 + (sizeof val
% sizeof hash
!= 0))
4086 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4090 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4091 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4092 hash
= sxhash_combine (hash
, u
.word
[i
]);
4093 return SXHASH_REDUCE (hash
);
4096 /* Return a hash for list LIST. DEPTH is the current depth in the
4097 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4100 sxhash_list (Lisp_Object list
, int depth
)
4102 EMACS_UINT hash
= 0;
4105 if (depth
< SXHASH_MAX_DEPTH
)
4107 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4108 list
= XCDR (list
), ++i
)
4110 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4111 hash
= sxhash_combine (hash
, hash2
);
4116 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4117 hash
= sxhash_combine (hash
, hash2
);
4120 return SXHASH_REDUCE (hash
);
4124 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4125 the Lisp structure. */
4128 sxhash_vector (Lisp_Object vec
, int depth
)
4130 EMACS_UINT hash
= ASIZE (vec
);
4133 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4134 for (i
= 0; i
< n
; ++i
)
4136 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4137 hash
= sxhash_combine (hash
, hash2
);
4140 return SXHASH_REDUCE (hash
);
4143 /* Return a hash for bool-vector VECTOR. */
4146 sxhash_bool_vector (Lisp_Object vec
)
4148 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4151 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4152 for (i
= 0; i
< n
; ++i
)
4153 hash
= sxhash_combine (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4155 return SXHASH_REDUCE (hash
);
4159 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4160 structure. Value is an unsigned integer clipped to INTMASK. */
4163 sxhash (Lisp_Object obj
, int depth
)
4167 if (depth
> SXHASH_MAX_DEPTH
)
4170 switch (XTYPE (obj
))
4181 obj
= SYMBOL_NAME (obj
);
4185 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4188 /* This can be everything from a vector to an overlay. */
4189 case Lisp_Vectorlike
:
4191 /* According to the CL HyperSpec, two arrays are equal only if
4192 they are `eq', except for strings and bit-vectors. In
4193 Emacs, this works differently. We have to compare element
4195 hash
= sxhash_vector (obj
, depth
);
4196 else if (BOOL_VECTOR_P (obj
))
4197 hash
= sxhash_bool_vector (obj
);
4199 /* Others are `equal' if they are `eq', so let's take their
4205 hash
= sxhash_list (obj
, depth
);
4209 hash
= sxhash_float (XFLOAT_DATA (obj
));
4221 /***********************************************************************
4223 ***********************************************************************/
4226 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4227 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4230 EMACS_UINT hash
= sxhash (obj
, 0);
4231 return make_number (hash
);
4235 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4236 doc
: /* Create and return a new hash table.
4238 Arguments are specified as keyword/argument pairs. The following
4239 arguments are defined:
4241 :test TEST -- TEST must be a symbol that specifies how to compare
4242 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4243 `equal'. User-supplied test and hash functions can be specified via
4244 `define-hash-table-test'.
4246 :size SIZE -- A hint as to how many elements will be put in the table.
4249 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4250 fills up. If REHASH-SIZE is an integer, increase the size by that
4251 amount. If it is a float, it must be > 1.0, and the new size is the
4252 old size multiplied by that factor. Default is 1.5.
4254 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4255 Resize the hash table when the ratio (number of entries / table size)
4256 is greater than or equal to THRESHOLD. Default is 0.8.
4258 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4259 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4260 returned is a weak table. Key/value pairs are removed from a weak
4261 hash table when there are no non-weak references pointing to their
4262 key, value, one of key or value, or both key and value, depending on
4263 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4266 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4267 (ptrdiff_t nargs
, Lisp_Object
*args
)
4269 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4270 struct hash_table_test testdesc
;
4274 /* The vector `used' is used to keep track of arguments that
4275 have been consumed. */
4276 used
= alloca (nargs
* sizeof *used
);
4277 memset (used
, 0, nargs
* sizeof *used
);
4279 /* See if there's a `:test TEST' among the arguments. */
4280 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4281 test
= i
? args
[i
] : Qeql
;
4283 testdesc
= hashtest_eq
;
4284 else if (EQ (test
, Qeql
))
4285 testdesc
= hashtest_eql
;
4286 else if (EQ (test
, Qequal
))
4287 testdesc
= hashtest_equal
;
4290 /* See if it is a user-defined test. */
4293 prop
= Fget (test
, Qhash_table_test
);
4294 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4295 signal_error ("Invalid hash table test", test
);
4296 testdesc
.name
= test
;
4297 testdesc
.user_cmp_function
= XCAR (prop
);
4298 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4299 testdesc
.hashfn
= hashfn_user_defined
;
4300 testdesc
.cmpfn
= cmpfn_user_defined
;
4303 /* See if there's a `:size SIZE' argument. */
4304 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4305 size
= i
? args
[i
] : Qnil
;
4307 size
= make_number (DEFAULT_HASH_SIZE
);
4308 else if (!INTEGERP (size
) || XINT (size
) < 0)
4309 signal_error ("Invalid hash table size", size
);
4311 /* Look for `:rehash-size SIZE'. */
4312 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4313 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4314 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4315 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4316 signal_error ("Invalid hash table rehash size", rehash_size
);
4318 /* Look for `:rehash-threshold THRESHOLD'. */
4319 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4320 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4321 if (! (FLOATP (rehash_threshold
)
4322 && 0 < XFLOAT_DATA (rehash_threshold
)
4323 && XFLOAT_DATA (rehash_threshold
) <= 1))
4324 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4326 /* Look for `:weakness WEAK'. */
4327 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4328 weak
= i
? args
[i
] : Qnil
;
4330 weak
= Qkey_and_value
;
4333 && !EQ (weak
, Qvalue
)
4334 && !EQ (weak
, Qkey_or_value
)
4335 && !EQ (weak
, Qkey_and_value
))
4336 signal_error ("Invalid hash table weakness", weak
);
4338 /* Now, all args should have been used up, or there's a problem. */
4339 for (i
= 0; i
< nargs
; ++i
)
4341 signal_error ("Invalid argument list", args
[i
]);
4343 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4347 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4348 doc
: /* Return a copy of hash table TABLE. */)
4351 return copy_hash_table (check_hash_table (table
));
4355 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4356 doc
: /* Return the number of elements in TABLE. */)
4359 return make_number (check_hash_table (table
)->count
);
4363 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4364 Shash_table_rehash_size
, 1, 1, 0,
4365 doc
: /* Return the current rehash size of TABLE. */)
4368 return check_hash_table (table
)->rehash_size
;
4372 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4373 Shash_table_rehash_threshold
, 1, 1, 0,
4374 doc
: /* Return the current rehash threshold of TABLE. */)
4377 return check_hash_table (table
)->rehash_threshold
;
4381 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4382 doc
: /* Return the size of TABLE.
4383 The size can be used as an argument to `make-hash-table' to create
4384 a hash table than can hold as many elements as TABLE holds
4385 without need for resizing. */)
4388 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4389 return make_number (HASH_TABLE_SIZE (h
));
4393 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4394 doc
: /* Return the test TABLE uses. */)
4397 return check_hash_table (table
)->test
.name
;
4401 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4403 doc
: /* Return the weakness of TABLE. */)
4406 return check_hash_table (table
)->weak
;
4410 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4411 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4414 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4418 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4419 doc
: /* Clear hash table TABLE and return it. */)
4422 hash_clear (check_hash_table (table
));
4423 /* Be compatible with XEmacs. */
4428 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4429 doc
: /* Look up KEY in TABLE and return its associated value.
4430 If KEY is not found, return DFLT which defaults to nil. */)
4431 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4433 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4434 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4435 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4439 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4440 doc
: /* Associate KEY with VALUE in hash table TABLE.
4441 If KEY is already present in table, replace its current value with
4442 VALUE. In any case, return VALUE. */)
4443 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4445 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4449 i
= hash_lookup (h
, key
, &hash
);
4451 set_hash_value_slot (h
, i
, value
);
4453 hash_put (h
, key
, value
, hash
);
4459 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4460 doc
: /* Remove KEY from TABLE. */)
4461 (Lisp_Object key
, Lisp_Object table
)
4463 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4464 hash_remove_from_table (h
, key
);
4469 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4470 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4471 FUNCTION is called with two arguments, KEY and VALUE. */)
4472 (Lisp_Object function
, Lisp_Object table
)
4474 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4475 Lisp_Object args
[3];
4478 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4479 if (!NILP (HASH_HASH (h
, i
)))
4482 args
[1] = HASH_KEY (h
, i
);
4483 args
[2] = HASH_VALUE (h
, i
);
4491 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4492 Sdefine_hash_table_test
, 3, 3, 0,
4493 doc
: /* Define a new hash table test with name NAME, a symbol.
4495 In hash tables created with NAME specified as test, use TEST to
4496 compare keys, and HASH for computing hash codes of keys.
4498 TEST must be a function taking two arguments and returning non-nil if
4499 both arguments are the same. HASH must be a function taking one
4500 argument and return an integer that is the hash code of the argument.
4501 Hash code computation should use the whole value range of integers,
4502 including negative integers. */)
4503 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4505 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4510 /************************************************************************
4511 MD5, SHA-1, and SHA-2
4512 ************************************************************************/
4519 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4522 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4526 EMACS_INT start_char
= 0, end_char
= 0;
4527 ptrdiff_t start_byte
, end_byte
;
4528 register EMACS_INT b
, e
;
4529 register struct buffer
*bp
;
4532 void *(*hash_func
) (const char *, size_t, void *);
4535 CHECK_SYMBOL (algorithm
);
4537 if (STRINGP (object
))
4539 if (NILP (coding_system
))
4541 /* Decide the coding-system to encode the data with. */
4543 if (STRING_MULTIBYTE (object
))
4544 /* use default, we can't guess correct value */
4545 coding_system
= preferred_coding_system ();
4547 coding_system
= Qraw_text
;
4550 if (NILP (Fcoding_system_p (coding_system
)))
4552 /* Invalid coding system. */
4554 if (!NILP (noerror
))
4555 coding_system
= Qraw_text
;
4557 xsignal1 (Qcoding_system_error
, coding_system
);
4560 if (STRING_MULTIBYTE (object
))
4561 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4563 size
= SCHARS (object
);
4567 CHECK_NUMBER (start
);
4569 start_char
= XINT (start
);
4581 end_char
= XINT (end
);
4587 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4588 args_out_of_range_3 (object
, make_number (start_char
),
4589 make_number (end_char
));
4591 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4593 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4597 struct buffer
*prev
= current_buffer
;
4599 record_unwind_current_buffer ();
4601 CHECK_BUFFER (object
);
4603 bp
= XBUFFER (object
);
4604 set_buffer_internal (bp
);
4610 CHECK_NUMBER_COERCE_MARKER (start
);
4618 CHECK_NUMBER_COERCE_MARKER (end
);
4623 temp
= b
, b
= e
, e
= temp
;
4625 if (!(BEGV
<= b
&& e
<= ZV
))
4626 args_out_of_range (start
, end
);
4628 if (NILP (coding_system
))
4630 /* Decide the coding-system to encode the data with.
4631 See fileio.c:Fwrite-region */
4633 if (!NILP (Vcoding_system_for_write
))
4634 coding_system
= Vcoding_system_for_write
;
4637 bool force_raw_text
= 0;
4639 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4640 if (NILP (coding_system
)
4641 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4643 coding_system
= Qnil
;
4644 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4648 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4650 /* Check file-coding-system-alist. */
4651 Lisp_Object args
[4], val
;
4653 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4654 args
[3] = Fbuffer_file_name (object
);
4655 val
= Ffind_operation_coding_system (4, args
);
4656 if (CONSP (val
) && !NILP (XCDR (val
)))
4657 coding_system
= XCDR (val
);
4660 if (NILP (coding_system
)
4661 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4663 /* If we still have not decided a coding system, use the
4664 default value of buffer-file-coding-system. */
4665 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4669 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4670 /* Confirm that VAL can surely encode the current region. */
4671 coding_system
= call4 (Vselect_safe_coding_system_function
,
4672 make_number (b
), make_number (e
),
4673 coding_system
, Qnil
);
4676 coding_system
= Qraw_text
;
4679 if (NILP (Fcoding_system_p (coding_system
)))
4681 /* Invalid coding system. */
4683 if (!NILP (noerror
))
4684 coding_system
= Qraw_text
;
4686 xsignal1 (Qcoding_system_error
, coding_system
);
4690 object
= make_buffer_string (b
, e
, 0);
4691 set_buffer_internal (prev
);
4692 /* Discard the unwind protect for recovering the current
4696 if (STRING_MULTIBYTE (object
))
4697 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4699 end_byte
= SBYTES (object
);
4702 if (EQ (algorithm
, Qmd5
))
4704 digest_size
= MD5_DIGEST_SIZE
;
4705 hash_func
= md5_buffer
;
4707 else if (EQ (algorithm
, Qsha1
))
4709 digest_size
= SHA1_DIGEST_SIZE
;
4710 hash_func
= sha1_buffer
;
4712 else if (EQ (algorithm
, Qsha224
))
4714 digest_size
= SHA224_DIGEST_SIZE
;
4715 hash_func
= sha224_buffer
;
4717 else if (EQ (algorithm
, Qsha256
))
4719 digest_size
= SHA256_DIGEST_SIZE
;
4720 hash_func
= sha256_buffer
;
4722 else if (EQ (algorithm
, Qsha384
))
4724 digest_size
= SHA384_DIGEST_SIZE
;
4725 hash_func
= sha384_buffer
;
4727 else if (EQ (algorithm
, Qsha512
))
4729 digest_size
= SHA512_DIGEST_SIZE
;
4730 hash_func
= sha512_buffer
;
4733 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4735 /* allocate 2 x digest_size so that it can be re-used to hold the
4737 digest
= make_uninit_string (digest_size
* 2);
4739 hash_func (SSDATA (object
) + start_byte
,
4740 end_byte
- start_byte
,
4745 unsigned char *p
= SDATA (digest
);
4746 for (i
= digest_size
- 1; i
>= 0; i
--)
4748 static char const hexdigit
[16] = "0123456789abcdef";
4750 p
[2 * i
] = hexdigit
[p_i
>> 4];
4751 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4756 return make_unibyte_string (SSDATA (digest
), digest_size
);
4759 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4760 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4762 A message digest is a cryptographic checksum of a document, and the
4763 algorithm to calculate it is defined in RFC 1321.
4765 The two optional arguments START and END are character positions
4766 specifying for which part of OBJECT the message digest should be
4767 computed. If nil or omitted, the digest is computed for the whole
4770 The MD5 message digest is computed from the result of encoding the
4771 text in a coding system, not directly from the internal Emacs form of
4772 the text. The optional fourth argument CODING-SYSTEM specifies which
4773 coding system to encode the text with. It should be the same coding
4774 system that you used or will use when actually writing the text into a
4777 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4778 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4779 system would be chosen by default for writing this text into a file.
4781 If OBJECT is a string, the most preferred coding system (see the
4782 command `prefer-coding-system') is used.
4784 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4785 guesswork fails. Normally, an error is signaled in such case. */)
4786 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4788 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4791 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4792 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4793 ALGORITHM is a symbol specifying the hash to use:
4794 md5, sha1, sha224, sha256, sha384 or sha512.
4796 The two optional arguments START and END are positions specifying for
4797 which part of OBJECT to compute the hash. If nil or omitted, uses the
4800 If BINARY is non-nil, returns a string in binary form. */)
4801 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4803 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4809 DEFSYM (Qmd5
, "md5");
4810 DEFSYM (Qsha1
, "sha1");
4811 DEFSYM (Qsha224
, "sha224");
4812 DEFSYM (Qsha256
, "sha256");
4813 DEFSYM (Qsha384
, "sha384");
4814 DEFSYM (Qsha512
, "sha512");
4816 /* Hash table stuff. */
4817 DEFSYM (Qhash_table_p
, "hash-table-p");
4819 DEFSYM (Qeql
, "eql");
4820 DEFSYM (Qequal
, "equal");
4821 DEFSYM (QCtest
, ":test");
4822 DEFSYM (QCsize
, ":size");
4823 DEFSYM (QCrehash_size
, ":rehash-size");
4824 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4825 DEFSYM (QCweakness
, ":weakness");
4826 DEFSYM (Qkey
, "key");
4827 DEFSYM (Qvalue
, "value");
4828 DEFSYM (Qhash_table_test
, "hash-table-test");
4829 DEFSYM (Qkey_or_value
, "key-or-value");
4830 DEFSYM (Qkey_and_value
, "key-and-value");
4833 defsubr (&Smake_hash_table
);
4834 defsubr (&Scopy_hash_table
);
4835 defsubr (&Shash_table_count
);
4836 defsubr (&Shash_table_rehash_size
);
4837 defsubr (&Shash_table_rehash_threshold
);
4838 defsubr (&Shash_table_size
);
4839 defsubr (&Shash_table_test
);
4840 defsubr (&Shash_table_weakness
);
4841 defsubr (&Shash_table_p
);
4842 defsubr (&Sclrhash
);
4843 defsubr (&Sgethash
);
4844 defsubr (&Sputhash
);
4845 defsubr (&Sremhash
);
4846 defsubr (&Smaphash
);
4847 defsubr (&Sdefine_hash_table_test
);
4849 DEFSYM (Qstring_lessp
, "string-lessp");
4850 DEFSYM (Qprovide
, "provide");
4851 DEFSYM (Qrequire
, "require");
4852 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4853 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4854 DEFSYM (Qwidget_type
, "widget-type");
4856 staticpro (&string_char_byte_cache_string
);
4857 string_char_byte_cache_string
= Qnil
;
4859 require_nesting_list
= Qnil
;
4860 staticpro (&require_nesting_list
);
4862 Fset (Qyes_or_no_p_history
, Qnil
);
4864 DEFVAR_LISP ("features", Vfeatures
,
4865 doc
: /* A list of symbols which are the features of the executing Emacs.
4866 Used by `featurep' and `require', and altered by `provide'. */);
4867 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4868 DEFSYM (Qsubfeatures
, "subfeatures");
4870 #ifdef HAVE_LANGINFO_CODESET
4871 DEFSYM (Qcodeset
, "codeset");
4872 DEFSYM (Qdays
, "days");
4873 DEFSYM (Qmonths
, "months");
4874 DEFSYM (Qpaper
, "paper");
4875 #endif /* HAVE_LANGINFO_CODESET */
4877 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4878 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4879 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4880 invoked by mouse clicks and mouse menu items.
4882 On some platforms, file selection dialogs are also enabled if this is
4886 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4887 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4888 This applies to commands from menus and tool bar buttons even when
4889 they are initiated from the keyboard. If `use-dialog-box' is nil,
4890 that disables the use of a file dialog, regardless of the value of
4892 use_file_dialog
= 1;
4894 defsubr (&Sidentity
);
4897 defsubr (&Ssafe_length
);
4898 defsubr (&Sstring_bytes
);
4899 defsubr (&Sstring_equal
);
4900 defsubr (&Scompare_strings
);
4901 defsubr (&Sstring_lessp
);
4904 defsubr (&Svconcat
);
4905 defsubr (&Scopy_sequence
);
4906 defsubr (&Sstring_make_multibyte
);
4907 defsubr (&Sstring_make_unibyte
);
4908 defsubr (&Sstring_as_multibyte
);
4909 defsubr (&Sstring_as_unibyte
);
4910 defsubr (&Sstring_to_multibyte
);
4911 defsubr (&Sstring_to_unibyte
);
4912 defsubr (&Scopy_alist
);
4913 defsubr (&Ssubstring
);
4914 defsubr (&Ssubstring_no_properties
);
4927 defsubr (&Snreverse
);
4928 defsubr (&Sreverse
);
4930 defsubr (&Splist_get
);
4932 defsubr (&Splist_put
);
4934 defsubr (&Slax_plist_get
);
4935 defsubr (&Slax_plist_put
);
4938 defsubr (&Sequal_including_properties
);
4939 defsubr (&Sfillarray
);
4940 defsubr (&Sclear_string
);
4944 defsubr (&Smapconcat
);
4945 defsubr (&Syes_or_no_p
);
4946 defsubr (&Sload_average
);
4947 defsubr (&Sfeaturep
);
4948 defsubr (&Srequire
);
4949 defsubr (&Sprovide
);
4950 defsubr (&Splist_member
);
4951 defsubr (&Swidget_put
);
4952 defsubr (&Swidget_get
);
4953 defsubr (&Swidget_apply
);
4954 defsubr (&Sbase64_encode_region
);
4955 defsubr (&Sbase64_decode_region
);
4956 defsubr (&Sbase64_encode_string
);
4957 defsubr (&Sbase64_decode_string
);
4959 defsubr (&Ssecure_hash
);
4960 defsubr (&Slocale_info
);
4963 struct hash_table_test
4964 eq
= { Qeq
, Qnil
, Qnil
, NULL
, hashfn_eq
},
4965 eql
= { Qeql
, Qnil
, Qnil
, cmpfn_eql
, hashfn_eql
},
4966 equal
= { Qequal
, Qnil
, Qnil
, cmpfn_equal
, hashfn_equal
};
4969 hashtest_equal
= equal
;