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
;
3335 Lisp_Object Qeq
, Qeql
, 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 struct hash_table_test hashtest_eq
, hashtest_eql
, hashtest_equal
;
3429 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3430 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3431 KEY2 are the same. */
3434 cmpfn_eql (struct hash_table_test
*ht
,
3438 return (FLOATP (key1
)
3440 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3444 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3445 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3446 KEY2 are the same. */
3449 cmpfn_equal (struct hash_table_test
*ht
,
3453 return !NILP (Fequal (key1
, key2
));
3457 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3458 HASH2 in hash table H using H->user_cmp_function. Value is true
3459 if KEY1 and KEY2 are the same. */
3462 cmpfn_user_defined (struct hash_table_test
*ht
,
3466 Lisp_Object args
[3];
3468 args
[0] = ht
->user_cmp_function
;
3471 return !NILP (Ffuncall (3, args
));
3475 /* Value is a hash code for KEY for use in hash table H which uses
3476 `eq' to compare keys. The hash code returned is guaranteed to fit
3477 in a Lisp integer. */
3480 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3482 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3486 /* Value is a hash code for KEY for use in hash table H which uses
3487 `eql' to compare keys. The hash code returned is guaranteed to fit
3488 in a Lisp integer. */
3491 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3495 hash
= sxhash (key
, 0);
3497 hash
= XUINT (key
) ^ XTYPE (key
);
3501 /* Value is a hash code for KEY for use in hash table H which uses
3502 `equal' to compare keys. The hash code returned is guaranteed to fit
3503 in a Lisp integer. */
3506 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3508 EMACS_UINT hash
= sxhash (key
, 0);
3512 /* Value is a hash code for KEY for use in hash table H which uses as
3513 user-defined function to compare keys. The hash code returned is
3514 guaranteed to fit in a Lisp integer. */
3517 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3519 Lisp_Object args
[2], hash
;
3521 args
[0] = ht
->user_hash_function
;
3523 hash
= Ffuncall (2, args
);
3524 if (!INTEGERP (hash
))
3525 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3526 return XUINT (hash
);
3529 /* An upper bound on the size of a hash table index. It must fit in
3530 ptrdiff_t and be a valid Emacs fixnum. */
3531 #define INDEX_SIZE_BOUND \
3532 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3534 /* Create and initialize a new hash table.
3536 TEST specifies the test the hash table will use to compare keys.
3537 It must be either one of the predefined tests `eq', `eql' or
3538 `equal' or a symbol denoting a user-defined test named TEST with
3539 test and hash functions USER_TEST and USER_HASH.
3541 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3543 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3544 new size when it becomes full is computed by adding REHASH_SIZE to
3545 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3546 table's new size is computed by multiplying its old size with
3549 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3550 be resized when the ratio of (number of entries in the table) /
3551 (table size) is >= REHASH_THRESHOLD.
3553 WEAK specifies the weakness of the table. If non-nil, it must be
3554 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3557 make_hash_table (struct hash_table_test test
,
3558 Lisp_Object size
, Lisp_Object rehash_size
,
3559 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3561 struct Lisp_Hash_Table
*h
;
3563 EMACS_INT index_size
, sz
;
3567 /* Preconditions. */
3568 eassert (SYMBOLP (test
.name
));
3569 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3570 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3571 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3572 eassert (FLOATP (rehash_threshold
)
3573 && 0 < XFLOAT_DATA (rehash_threshold
)
3574 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3576 if (XFASTINT (size
) == 0)
3577 size
= make_number (1);
3579 sz
= XFASTINT (size
);
3580 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3581 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3582 ? next_almost_prime (index_float
)
3583 : INDEX_SIZE_BOUND
+ 1);
3584 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3585 error ("Hash table too large");
3587 /* Allocate a table and initialize it. */
3588 h
= allocate_hash_table ();
3590 /* Initialize hash table slots. */
3593 h
->rehash_threshold
= rehash_threshold
;
3594 h
->rehash_size
= rehash_size
;
3596 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3597 h
->hash
= Fmake_vector (size
, Qnil
);
3598 h
->next
= Fmake_vector (size
, Qnil
);
3599 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3601 /* Set up the free list. */
3602 for (i
= 0; i
< sz
- 1; ++i
)
3603 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3604 h
->next_free
= make_number (0);
3606 XSET_HASH_TABLE (table
, h
);
3607 eassert (HASH_TABLE_P (table
));
3608 eassert (XHASH_TABLE (table
) == h
);
3610 /* Maybe add this hash table to the list of all weak hash tables. */
3612 h
->next_weak
= NULL
;
3615 h
->next_weak
= weak_hash_tables
;
3616 weak_hash_tables
= h
;
3623 /* Return a copy of hash table H1. Keys and values are not copied,
3624 only the table itself is. */
3627 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3630 struct Lisp_Hash_Table
*h2
;
3632 h2
= allocate_hash_table ();
3634 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3635 h2
->hash
= Fcopy_sequence (h1
->hash
);
3636 h2
->next
= Fcopy_sequence (h1
->next
);
3637 h2
->index
= Fcopy_sequence (h1
->index
);
3638 XSET_HASH_TABLE (table
, h2
);
3640 /* Maybe add this hash table to the list of all weak hash tables. */
3641 if (!NILP (h2
->weak
))
3643 h2
->next_weak
= weak_hash_tables
;
3644 weak_hash_tables
= h2
;
3651 /* Resize hash table H if it's too full. If H cannot be resized
3652 because it's already too large, throw an error. */
3655 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3657 if (NILP (h
->next_free
))
3659 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3660 EMACS_INT new_size
, index_size
, nsize
;
3664 if (INTEGERP (h
->rehash_size
))
3665 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3668 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3669 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3671 new_size
= float_new_size
;
3672 if (new_size
<= old_size
)
3673 new_size
= old_size
+ 1;
3676 new_size
= INDEX_SIZE_BOUND
+ 1;
3678 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3679 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3680 ? next_almost_prime (index_float
)
3681 : INDEX_SIZE_BOUND
+ 1);
3682 nsize
= max (index_size
, 2 * new_size
);
3683 if (INDEX_SIZE_BOUND
< nsize
)
3684 error ("Hash table too large to resize");
3686 #ifdef ENABLE_CHECKING
3687 if (HASH_TABLE_P (Vpurify_flag
)
3688 && XHASH_TABLE (Vpurify_flag
) == h
)
3690 Lisp_Object args
[2];
3691 args
[0] = build_string ("Growing hash table to: %d");
3692 args
[1] = make_number (new_size
);
3697 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3698 2 * (new_size
- old_size
), -1));
3699 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3700 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3701 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3703 /* Update the free list. Do it so that new entries are added at
3704 the end of the free list. This makes some operations like
3706 for (i
= old_size
; i
< new_size
- 1; ++i
)
3707 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3709 if (!NILP (h
->next_free
))
3711 Lisp_Object last
, next
;
3713 last
= h
->next_free
;
3714 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3718 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3721 XSETFASTINT (h
->next_free
, old_size
);
3724 for (i
= 0; i
< old_size
; ++i
)
3725 if (!NILP (HASH_HASH (h
, i
)))
3727 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3728 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3729 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3730 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3736 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3737 the hash code of KEY. Value is the index of the entry in H
3738 matching KEY, or -1 if not found. */
3741 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3743 EMACS_UINT hash_code
;
3744 ptrdiff_t start_of_bucket
;
3747 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3748 eassert ((hash_code
& ~INTMASK
) == 0);
3752 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3753 idx
= HASH_INDEX (h
, start_of_bucket
);
3755 /* We need not gcpro idx since it's either an integer or nil. */
3758 ptrdiff_t i
= XFASTINT (idx
);
3759 if (EQ (key
, HASH_KEY (h
, i
))
3761 && hash_code
== XUINT (HASH_HASH (h
, i
))
3762 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3764 idx
= HASH_NEXT (h
, i
);
3767 return NILP (idx
) ? -1 : XFASTINT (idx
);
3771 /* Put an entry into hash table H that associates KEY with VALUE.
3772 HASH is a previously computed hash code of KEY.
3773 Value is the index of the entry in H matching KEY. */
3776 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3779 ptrdiff_t start_of_bucket
, i
;
3781 eassert ((hash
& ~INTMASK
) == 0);
3783 /* Increment count after resizing because resizing may fail. */
3784 maybe_resize_hash_table (h
);
3787 /* Store key/value in the key_and_value vector. */
3788 i
= XFASTINT (h
->next_free
);
3789 h
->next_free
= HASH_NEXT (h
, i
);
3790 set_hash_key_slot (h
, i
, key
);
3791 set_hash_value_slot (h
, i
, value
);
3793 /* Remember its hash code. */
3794 set_hash_hash_slot (h
, i
, make_number (hash
));
3796 /* Add new entry to its collision chain. */
3797 start_of_bucket
= hash
% ASIZE (h
->index
);
3798 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3799 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3804 /* Remove the entry matching KEY from hash table H, if there is one. */
3807 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3809 EMACS_UINT hash_code
;
3810 ptrdiff_t start_of_bucket
;
3811 Lisp_Object idx
, prev
;
3813 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3814 eassert ((hash_code
& ~INTMASK
) == 0);
3815 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3816 idx
= HASH_INDEX (h
, start_of_bucket
);
3819 /* We need not gcpro idx, prev since they're either integers or nil. */
3822 ptrdiff_t i
= XFASTINT (idx
);
3824 if (EQ (key
, HASH_KEY (h
, i
))
3826 && hash_code
== XUINT (HASH_HASH (h
, i
))
3827 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3829 /* Take entry out of collision chain. */
3831 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3833 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3835 /* Clear slots in key_and_value and add the slots to
3837 set_hash_key_slot (h
, i
, Qnil
);
3838 set_hash_value_slot (h
, i
, Qnil
);
3839 set_hash_hash_slot (h
, i
, Qnil
);
3840 set_hash_next_slot (h
, i
, h
->next_free
);
3841 h
->next_free
= make_number (i
);
3843 eassert (h
->count
>= 0);
3849 idx
= HASH_NEXT (h
, i
);
3855 /* Clear hash table H. */
3858 hash_clear (struct Lisp_Hash_Table
*h
)
3862 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
3864 for (i
= 0; i
< size
; ++i
)
3866 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
3867 set_hash_key_slot (h
, i
, Qnil
);
3868 set_hash_value_slot (h
, i
, Qnil
);
3869 set_hash_hash_slot (h
, i
, Qnil
);
3872 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3873 ASET (h
->index
, i
, Qnil
);
3875 h
->next_free
= make_number (0);
3882 /************************************************************************
3884 ************************************************************************/
3886 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
3887 entries from the table that don't survive the current GC.
3888 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
3889 true if anything was marked. */
3892 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
3894 ptrdiff_t bucket
, n
;
3897 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3900 for (bucket
= 0; bucket
< n
; ++bucket
)
3902 Lisp_Object idx
, next
, prev
;
3904 /* Follow collision chain, removing entries that
3905 don't survive this garbage collection. */
3907 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3909 ptrdiff_t i
= XFASTINT (idx
);
3910 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3911 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3914 if (EQ (h
->weak
, Qkey
))
3915 remove_p
= !key_known_to_survive_p
;
3916 else if (EQ (h
->weak
, Qvalue
))
3917 remove_p
= !value_known_to_survive_p
;
3918 else if (EQ (h
->weak
, Qkey_or_value
))
3919 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3920 else if (EQ (h
->weak
, Qkey_and_value
))
3921 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3925 next
= HASH_NEXT (h
, i
);
3927 if (remove_entries_p
)
3931 /* Take out of collision chain. */
3933 set_hash_index_slot (h
, bucket
, next
);
3935 set_hash_next_slot (h
, XFASTINT (prev
), next
);
3937 /* Add to free list. */
3938 set_hash_next_slot (h
, i
, h
->next_free
);
3941 /* Clear key, value, and hash. */
3942 set_hash_key_slot (h
, i
, Qnil
);
3943 set_hash_value_slot (h
, i
, Qnil
);
3944 set_hash_hash_slot (h
, i
, Qnil
);
3957 /* Make sure key and value survive. */
3958 if (!key_known_to_survive_p
)
3960 mark_object (HASH_KEY (h
, i
));
3964 if (!value_known_to_survive_p
)
3966 mark_object (HASH_VALUE (h
, i
));
3977 /* Remove elements from weak hash tables that don't survive the
3978 current garbage collection. Remove weak tables that don't survive
3979 from Vweak_hash_tables. Called from gc_sweep. */
3982 sweep_weak_hash_tables (void)
3984 struct Lisp_Hash_Table
*h
, *used
, *next
;
3987 /* Mark all keys and values that are in use. Keep on marking until
3988 there is no more change. This is necessary for cases like
3989 value-weak table A containing an entry X -> Y, where Y is used in a
3990 key-weak table B, Z -> Y. If B comes after A in the list of weak
3991 tables, X -> Y might be removed from A, although when looking at B
3992 one finds that it shouldn't. */
3996 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
3998 if (h
->header
.size
& ARRAY_MARK_FLAG
)
3999 marked
|= sweep_weak_table (h
, 0);
4004 /* Remove tables and entries that aren't used. */
4005 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4007 next
= h
->next_weak
;
4009 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4011 /* TABLE is marked as used. Sweep its contents. */
4013 sweep_weak_table (h
, 1);
4015 /* Add table to the list of used weak hash tables. */
4016 h
->next_weak
= used
;
4021 weak_hash_tables
= used
;
4026 /***********************************************************************
4027 Hash Code Computation
4028 ***********************************************************************/
4030 /* Maximum depth up to which to dive into Lisp structures. */
4032 #define SXHASH_MAX_DEPTH 3
4034 /* Maximum length up to which to take list and vector elements into
4037 #define SXHASH_MAX_LEN 7
4039 /* Hash X, returning a value that fits into a Lisp integer. */
4040 #define SXHASH_REDUCE(X) \
4041 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4043 /* Return a hash for string PTR which has length LEN. The hash value
4044 can be any EMACS_UINT value. */
4047 hash_string (char const *ptr
, ptrdiff_t len
)
4049 char const *p
= ptr
;
4050 char const *end
= p
+ len
;
4052 EMACS_UINT hash
= 0;
4057 hash
= sxhash_combine (hash
, c
);
4063 /* Return a hash for string PTR which has length LEN. The hash
4064 code returned is guaranteed to fit in a Lisp integer. */
4067 sxhash_string (char const *ptr
, ptrdiff_t len
)
4069 EMACS_UINT hash
= hash_string (ptr
, len
);
4070 return SXHASH_REDUCE (hash
);
4073 /* Return a hash for the floating point value VAL. */
4076 sxhash_float (double val
)
4078 EMACS_UINT hash
= 0;
4080 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4081 + (sizeof val
% sizeof hash
!= 0))
4085 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4089 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4090 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4091 hash
= sxhash_combine (hash
, u
.word
[i
]);
4092 return SXHASH_REDUCE (hash
);
4095 /* Return a hash for list LIST. DEPTH is the current depth in the
4096 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4099 sxhash_list (Lisp_Object list
, int depth
)
4101 EMACS_UINT hash
= 0;
4104 if (depth
< SXHASH_MAX_DEPTH
)
4106 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4107 list
= XCDR (list
), ++i
)
4109 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4110 hash
= sxhash_combine (hash
, hash2
);
4115 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4116 hash
= sxhash_combine (hash
, hash2
);
4119 return SXHASH_REDUCE (hash
);
4123 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4124 the Lisp structure. */
4127 sxhash_vector (Lisp_Object vec
, int depth
)
4129 EMACS_UINT hash
= ASIZE (vec
);
4132 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4133 for (i
= 0; i
< n
; ++i
)
4135 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4136 hash
= sxhash_combine (hash
, hash2
);
4139 return SXHASH_REDUCE (hash
);
4142 /* Return a hash for bool-vector VECTOR. */
4145 sxhash_bool_vector (Lisp_Object vec
)
4147 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4150 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4151 for (i
= 0; i
< n
; ++i
)
4152 hash
= sxhash_combine (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4154 return SXHASH_REDUCE (hash
);
4158 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4159 structure. Value is an unsigned integer clipped to INTMASK. */
4162 sxhash (Lisp_Object obj
, int depth
)
4166 if (depth
> SXHASH_MAX_DEPTH
)
4169 switch (XTYPE (obj
))
4180 obj
= SYMBOL_NAME (obj
);
4184 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4187 /* This can be everything from a vector to an overlay. */
4188 case Lisp_Vectorlike
:
4190 /* According to the CL HyperSpec, two arrays are equal only if
4191 they are `eq', except for strings and bit-vectors. In
4192 Emacs, this works differently. We have to compare element
4194 hash
= sxhash_vector (obj
, depth
);
4195 else if (BOOL_VECTOR_P (obj
))
4196 hash
= sxhash_bool_vector (obj
);
4198 /* Others are `equal' if they are `eq', so let's take their
4204 hash
= sxhash_list (obj
, depth
);
4208 hash
= sxhash_float (XFLOAT_DATA (obj
));
4220 /***********************************************************************
4222 ***********************************************************************/
4225 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4226 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4229 EMACS_UINT hash
= sxhash (obj
, 0);
4230 return make_number (hash
);
4234 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4235 doc
: /* Create and return a new hash table.
4237 Arguments are specified as keyword/argument pairs. The following
4238 arguments are defined:
4240 :test TEST -- TEST must be a symbol that specifies how to compare
4241 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4242 `equal'. User-supplied test and hash functions can be specified via
4243 `define-hash-table-test'.
4245 :size SIZE -- A hint as to how many elements will be put in the table.
4248 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4249 fills up. If REHASH-SIZE is an integer, increase the size by that
4250 amount. If it is a float, it must be > 1.0, and the new size is the
4251 old size multiplied by that factor. Default is 1.5.
4253 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4254 Resize the hash table when the ratio (number of entries / table size)
4255 is greater than or equal to THRESHOLD. Default is 0.8.
4257 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4258 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4259 returned is a weak table. Key/value pairs are removed from a weak
4260 hash table when there are no non-weak references pointing to their
4261 key, value, one of key or value, or both key and value, depending on
4262 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4265 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4266 (ptrdiff_t nargs
, Lisp_Object
*args
)
4268 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4269 struct hash_table_test testdesc
;
4273 /* The vector `used' is used to keep track of arguments that
4274 have been consumed. */
4275 used
= alloca (nargs
* sizeof *used
);
4276 memset (used
, 0, nargs
* sizeof *used
);
4278 /* See if there's a `:test TEST' among the arguments. */
4279 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4280 test
= i
? args
[i
] : Qeql
;
4282 testdesc
= hashtest_eq
;
4283 else if (EQ (test
, Qeql
))
4284 testdesc
= hashtest_eql
;
4285 else if (EQ (test
, Qequal
))
4286 testdesc
= hashtest_equal
;
4289 /* See if it is a user-defined test. */
4292 prop
= Fget (test
, Qhash_table_test
);
4293 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4294 signal_error ("Invalid hash table test", test
);
4295 testdesc
.name
= test
;
4296 testdesc
.user_cmp_function
= XCAR (prop
);
4297 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4298 testdesc
.hashfn
= hashfn_user_defined
;
4299 testdesc
.cmpfn
= cmpfn_user_defined
;
4302 /* See if there's a `:size SIZE' argument. */
4303 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4304 size
= i
? args
[i
] : Qnil
;
4306 size
= make_number (DEFAULT_HASH_SIZE
);
4307 else if (!INTEGERP (size
) || XINT (size
) < 0)
4308 signal_error ("Invalid hash table size", size
);
4310 /* Look for `:rehash-size SIZE'. */
4311 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4312 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4313 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4314 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4315 signal_error ("Invalid hash table rehash size", rehash_size
);
4317 /* Look for `:rehash-threshold THRESHOLD'. */
4318 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4319 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4320 if (! (FLOATP (rehash_threshold
)
4321 && 0 < XFLOAT_DATA (rehash_threshold
)
4322 && XFLOAT_DATA (rehash_threshold
) <= 1))
4323 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4325 /* Look for `:weakness WEAK'. */
4326 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4327 weak
= i
? args
[i
] : Qnil
;
4329 weak
= Qkey_and_value
;
4332 && !EQ (weak
, Qvalue
)
4333 && !EQ (weak
, Qkey_or_value
)
4334 && !EQ (weak
, Qkey_and_value
))
4335 signal_error ("Invalid hash table weakness", weak
);
4337 /* Now, all args should have been used up, or there's a problem. */
4338 for (i
= 0; i
< nargs
; ++i
)
4340 signal_error ("Invalid argument list", args
[i
]);
4342 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4346 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4347 doc
: /* Return a copy of hash table TABLE. */)
4350 return copy_hash_table (check_hash_table (table
));
4354 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4355 doc
: /* Return the number of elements in TABLE. */)
4358 return make_number (check_hash_table (table
)->count
);
4362 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4363 Shash_table_rehash_size
, 1, 1, 0,
4364 doc
: /* Return the current rehash size of TABLE. */)
4367 return check_hash_table (table
)->rehash_size
;
4371 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4372 Shash_table_rehash_threshold
, 1, 1, 0,
4373 doc
: /* Return the current rehash threshold of TABLE. */)
4376 return check_hash_table (table
)->rehash_threshold
;
4380 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4381 doc
: /* Return the size of TABLE.
4382 The size can be used as an argument to `make-hash-table' to create
4383 a hash table than can hold as many elements as TABLE holds
4384 without need for resizing. */)
4387 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4388 return make_number (HASH_TABLE_SIZE (h
));
4392 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4393 doc
: /* Return the test TABLE uses. */)
4396 return check_hash_table (table
)->test
.name
;
4400 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4402 doc
: /* Return the weakness of TABLE. */)
4405 return check_hash_table (table
)->weak
;
4409 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4410 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4413 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4417 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4418 doc
: /* Clear hash table TABLE and return it. */)
4421 hash_clear (check_hash_table (table
));
4422 /* Be compatible with XEmacs. */
4427 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4428 doc
: /* Look up KEY in TABLE and return its associated value.
4429 If KEY is not found, return DFLT which defaults to nil. */)
4430 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4432 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4433 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4434 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4438 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4439 doc
: /* Associate KEY with VALUE in hash table TABLE.
4440 If KEY is already present in table, replace its current value with
4441 VALUE. In any case, return VALUE. */)
4442 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4444 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4448 i
= hash_lookup (h
, key
, &hash
);
4450 set_hash_value_slot (h
, i
, value
);
4452 hash_put (h
, key
, value
, hash
);
4458 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4459 doc
: /* Remove KEY from TABLE. */)
4460 (Lisp_Object key
, Lisp_Object table
)
4462 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4463 hash_remove_from_table (h
, key
);
4468 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4469 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4470 FUNCTION is called with two arguments, KEY and VALUE. */)
4471 (Lisp_Object function
, Lisp_Object table
)
4473 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4474 Lisp_Object args
[3];
4477 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4478 if (!NILP (HASH_HASH (h
, i
)))
4481 args
[1] = HASH_KEY (h
, i
);
4482 args
[2] = HASH_VALUE (h
, i
);
4490 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4491 Sdefine_hash_table_test
, 3, 3, 0,
4492 doc
: /* Define a new hash table test with name NAME, a symbol.
4494 In hash tables created with NAME specified as test, use TEST to
4495 compare keys, and HASH for computing hash codes of keys.
4497 TEST must be a function taking two arguments and returning non-nil if
4498 both arguments are the same. HASH must be a function taking one
4499 argument and return an integer that is the hash code of the argument.
4500 Hash code computation should use the whole value range of integers,
4501 including negative integers. */)
4502 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4504 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4509 /************************************************************************
4510 MD5, SHA-1, and SHA-2
4511 ************************************************************************/
4518 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4521 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4525 EMACS_INT start_char
= 0, end_char
= 0;
4526 ptrdiff_t start_byte
, end_byte
;
4527 register EMACS_INT b
, e
;
4528 register struct buffer
*bp
;
4531 void *(*hash_func
) (const char *, size_t, void *);
4534 CHECK_SYMBOL (algorithm
);
4536 if (STRINGP (object
))
4538 if (NILP (coding_system
))
4540 /* Decide the coding-system to encode the data with. */
4542 if (STRING_MULTIBYTE (object
))
4543 /* use default, we can't guess correct value */
4544 coding_system
= preferred_coding_system ();
4546 coding_system
= Qraw_text
;
4549 if (NILP (Fcoding_system_p (coding_system
)))
4551 /* Invalid coding system. */
4553 if (!NILP (noerror
))
4554 coding_system
= Qraw_text
;
4556 xsignal1 (Qcoding_system_error
, coding_system
);
4559 if (STRING_MULTIBYTE (object
))
4560 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4562 size
= SCHARS (object
);
4566 CHECK_NUMBER (start
);
4568 start_char
= XINT (start
);
4580 end_char
= XINT (end
);
4586 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4587 args_out_of_range_3 (object
, make_number (start_char
),
4588 make_number (end_char
));
4590 start_byte
= NILP (start
) ? 0 : string_char_to_byte (object
, start_char
);
4592 NILP (end
) ? SBYTES (object
) : string_char_to_byte (object
, end_char
);
4596 struct buffer
*prev
= current_buffer
;
4598 record_unwind_current_buffer ();
4600 CHECK_BUFFER (object
);
4602 bp
= XBUFFER (object
);
4603 set_buffer_internal (bp
);
4609 CHECK_NUMBER_COERCE_MARKER (start
);
4617 CHECK_NUMBER_COERCE_MARKER (end
);
4622 temp
= b
, b
= e
, e
= temp
;
4624 if (!(BEGV
<= b
&& e
<= ZV
))
4625 args_out_of_range (start
, end
);
4627 if (NILP (coding_system
))
4629 /* Decide the coding-system to encode the data with.
4630 See fileio.c:Fwrite-region */
4632 if (!NILP (Vcoding_system_for_write
))
4633 coding_system
= Vcoding_system_for_write
;
4636 bool force_raw_text
= 0;
4638 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4639 if (NILP (coding_system
)
4640 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4642 coding_system
= Qnil
;
4643 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4647 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4649 /* Check file-coding-system-alist. */
4650 Lisp_Object args
[4], val
;
4652 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4653 args
[3] = Fbuffer_file_name (object
);
4654 val
= Ffind_operation_coding_system (4, args
);
4655 if (CONSP (val
) && !NILP (XCDR (val
)))
4656 coding_system
= XCDR (val
);
4659 if (NILP (coding_system
)
4660 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4662 /* If we still have not decided a coding system, use the
4663 default value of buffer-file-coding-system. */
4664 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4668 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4669 /* Confirm that VAL can surely encode the current region. */
4670 coding_system
= call4 (Vselect_safe_coding_system_function
,
4671 make_number (b
), make_number (e
),
4672 coding_system
, Qnil
);
4675 coding_system
= Qraw_text
;
4678 if (NILP (Fcoding_system_p (coding_system
)))
4680 /* Invalid coding system. */
4682 if (!NILP (noerror
))
4683 coding_system
= Qraw_text
;
4685 xsignal1 (Qcoding_system_error
, coding_system
);
4689 object
= make_buffer_string (b
, e
, 0);
4690 set_buffer_internal (prev
);
4691 /* Discard the unwind protect for recovering the current
4695 if (STRING_MULTIBYTE (object
))
4696 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4698 end_byte
= SBYTES (object
);
4701 if (EQ (algorithm
, Qmd5
))
4703 digest_size
= MD5_DIGEST_SIZE
;
4704 hash_func
= md5_buffer
;
4706 else if (EQ (algorithm
, Qsha1
))
4708 digest_size
= SHA1_DIGEST_SIZE
;
4709 hash_func
= sha1_buffer
;
4711 else if (EQ (algorithm
, Qsha224
))
4713 digest_size
= SHA224_DIGEST_SIZE
;
4714 hash_func
= sha224_buffer
;
4716 else if (EQ (algorithm
, Qsha256
))
4718 digest_size
= SHA256_DIGEST_SIZE
;
4719 hash_func
= sha256_buffer
;
4721 else if (EQ (algorithm
, Qsha384
))
4723 digest_size
= SHA384_DIGEST_SIZE
;
4724 hash_func
= sha384_buffer
;
4726 else if (EQ (algorithm
, Qsha512
))
4728 digest_size
= SHA512_DIGEST_SIZE
;
4729 hash_func
= sha512_buffer
;
4732 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4734 /* allocate 2 x digest_size so that it can be re-used to hold the
4736 digest
= make_uninit_string (digest_size
* 2);
4738 hash_func (SSDATA (object
) + start_byte
,
4739 end_byte
- start_byte
,
4744 unsigned char *p
= SDATA (digest
);
4745 for (i
= digest_size
- 1; i
>= 0; i
--)
4747 static char const hexdigit
[16] = "0123456789abcdef";
4749 p
[2 * i
] = hexdigit
[p_i
>> 4];
4750 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4755 return make_unibyte_string (SSDATA (digest
), digest_size
);
4758 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4759 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4761 A message digest is a cryptographic checksum of a document, and the
4762 algorithm to calculate it is defined in RFC 1321.
4764 The two optional arguments START and END are character positions
4765 specifying for which part of OBJECT the message digest should be
4766 computed. If nil or omitted, the digest is computed for the whole
4769 The MD5 message digest is computed from the result of encoding the
4770 text in a coding system, not directly from the internal Emacs form of
4771 the text. The optional fourth argument CODING-SYSTEM specifies which
4772 coding system to encode the text with. It should be the same coding
4773 system that you used or will use when actually writing the text into a
4776 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4777 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4778 system would be chosen by default for writing this text into a file.
4780 If OBJECT is a string, the most preferred coding system (see the
4781 command `prefer-coding-system') is used.
4783 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4784 guesswork fails. Normally, an error is signaled in such case. */)
4785 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4787 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4790 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4791 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4792 ALGORITHM is a symbol specifying the hash to use:
4793 md5, sha1, sha224, sha256, sha384 or sha512.
4795 The two optional arguments START and END are positions specifying for
4796 which part of OBJECT to compute the hash. If nil or omitted, uses the
4799 If BINARY is non-nil, returns a string in binary form. */)
4800 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4802 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4808 DEFSYM (Qmd5
, "md5");
4809 DEFSYM (Qsha1
, "sha1");
4810 DEFSYM (Qsha224
, "sha224");
4811 DEFSYM (Qsha256
, "sha256");
4812 DEFSYM (Qsha384
, "sha384");
4813 DEFSYM (Qsha512
, "sha512");
4815 /* Hash table stuff. */
4816 DEFSYM (Qhash_table_p
, "hash-table-p");
4818 DEFSYM (Qeql
, "eql");
4819 DEFSYM (Qequal
, "equal");
4820 DEFSYM (QCtest
, ":test");
4821 DEFSYM (QCsize
, ":size");
4822 DEFSYM (QCrehash_size
, ":rehash-size");
4823 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
4824 DEFSYM (QCweakness
, ":weakness");
4825 DEFSYM (Qkey
, "key");
4826 DEFSYM (Qvalue
, "value");
4827 DEFSYM (Qhash_table_test
, "hash-table-test");
4828 DEFSYM (Qkey_or_value
, "key-or-value");
4829 DEFSYM (Qkey_and_value
, "key-and-value");
4832 defsubr (&Smake_hash_table
);
4833 defsubr (&Scopy_hash_table
);
4834 defsubr (&Shash_table_count
);
4835 defsubr (&Shash_table_rehash_size
);
4836 defsubr (&Shash_table_rehash_threshold
);
4837 defsubr (&Shash_table_size
);
4838 defsubr (&Shash_table_test
);
4839 defsubr (&Shash_table_weakness
);
4840 defsubr (&Shash_table_p
);
4841 defsubr (&Sclrhash
);
4842 defsubr (&Sgethash
);
4843 defsubr (&Sputhash
);
4844 defsubr (&Sremhash
);
4845 defsubr (&Smaphash
);
4846 defsubr (&Sdefine_hash_table_test
);
4848 DEFSYM (Qstring_lessp
, "string-lessp");
4849 DEFSYM (Qprovide
, "provide");
4850 DEFSYM (Qrequire
, "require");
4851 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
4852 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
4853 DEFSYM (Qwidget_type
, "widget-type");
4855 staticpro (&string_char_byte_cache_string
);
4856 string_char_byte_cache_string
= Qnil
;
4858 require_nesting_list
= Qnil
;
4859 staticpro (&require_nesting_list
);
4861 Fset (Qyes_or_no_p_history
, Qnil
);
4863 DEFVAR_LISP ("features", Vfeatures
,
4864 doc
: /* A list of symbols which are the features of the executing Emacs.
4865 Used by `featurep' and `require', and altered by `provide'. */);
4866 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4867 DEFSYM (Qsubfeatures
, "subfeatures");
4869 #ifdef HAVE_LANGINFO_CODESET
4870 DEFSYM (Qcodeset
, "codeset");
4871 DEFSYM (Qdays
, "days");
4872 DEFSYM (Qmonths
, "months");
4873 DEFSYM (Qpaper
, "paper");
4874 #endif /* HAVE_LANGINFO_CODESET */
4876 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4877 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
4878 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4879 invoked by mouse clicks and mouse menu items.
4881 On some platforms, file selection dialogs are also enabled if this is
4885 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4886 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
4887 This applies to commands from menus and tool bar buttons even when
4888 they are initiated from the keyboard. If `use-dialog-box' is nil,
4889 that disables the use of a file dialog, regardless of the value of
4891 use_file_dialog
= 1;
4893 defsubr (&Sidentity
);
4896 defsubr (&Ssafe_length
);
4897 defsubr (&Sstring_bytes
);
4898 defsubr (&Sstring_equal
);
4899 defsubr (&Scompare_strings
);
4900 defsubr (&Sstring_lessp
);
4903 defsubr (&Svconcat
);
4904 defsubr (&Scopy_sequence
);
4905 defsubr (&Sstring_make_multibyte
);
4906 defsubr (&Sstring_make_unibyte
);
4907 defsubr (&Sstring_as_multibyte
);
4908 defsubr (&Sstring_as_unibyte
);
4909 defsubr (&Sstring_to_multibyte
);
4910 defsubr (&Sstring_to_unibyte
);
4911 defsubr (&Scopy_alist
);
4912 defsubr (&Ssubstring
);
4913 defsubr (&Ssubstring_no_properties
);
4926 defsubr (&Snreverse
);
4927 defsubr (&Sreverse
);
4929 defsubr (&Splist_get
);
4931 defsubr (&Splist_put
);
4933 defsubr (&Slax_plist_get
);
4934 defsubr (&Slax_plist_put
);
4937 defsubr (&Sequal_including_properties
);
4938 defsubr (&Sfillarray
);
4939 defsubr (&Sclear_string
);
4943 defsubr (&Smapconcat
);
4944 defsubr (&Syes_or_no_p
);
4945 defsubr (&Sload_average
);
4946 defsubr (&Sfeaturep
);
4947 defsubr (&Srequire
);
4948 defsubr (&Sprovide
);
4949 defsubr (&Splist_member
);
4950 defsubr (&Swidget_put
);
4951 defsubr (&Swidget_get
);
4952 defsubr (&Swidget_apply
);
4953 defsubr (&Sbase64_encode_region
);
4954 defsubr (&Sbase64_decode_region
);
4955 defsubr (&Sbase64_encode_string
);
4956 defsubr (&Sbase64_decode_string
);
4958 defsubr (&Ssecure_hash
);
4959 defsubr (&Slocale_info
);
4962 struct hash_table_test
4963 eq
= { Qeq
, Qnil
, Qnil
, NULL
, hashfn_eq
},
4964 eql
= { Qeql
, Qnil
, Qnil
, cmpfn_eql
, hashfn_eql
},
4965 equal
= { Qequal
, Qnil
, Qnil
, cmpfn_equal
, hashfn_equal
};
4968 hashtest_equal
= equal
;