1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
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/>. */
28 #include "character.h"
33 #include "intervals.h"
36 #include "blockinput.h"
38 #if defined (HAVE_X_WINDOWS)
41 #endif /* HAVE_MENUS */
44 #define NULL ((POINTER_TYPE *)0)
47 Lisp_Object Qstring_lessp
;
48 static Lisp_Object Qprovide
, Qrequire
;
49 static Lisp_Object Qyes_or_no_p_history
;
50 Lisp_Object Qcursor_in_echo_area
;
51 static Lisp_Object Qwidget_type
;
52 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
54 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
60 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
61 doc
: /* Return the argument unchanged. */)
67 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
68 doc
: /* Return a pseudo-random number.
69 All integers representable in Lisp are equally likely.
70 On most systems, this is 29 bits' worth.
71 With positive integer LIMIT, return random number in interval [0,LIMIT).
72 With argument t, set the random number seed from the current time and pid.
73 Other values of LIMIT are ignored. */)
77 Lisp_Object lispy_val
;
78 EMACS_UINT denominator
;
81 seed_random (getpid () + time (NULL
));
82 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
84 /* Try to take our random number from the higher bits of VAL,
85 not the lower, since (says Gentzel) the low bits of `random'
86 are less random than the higher ones. We do this by using the
87 quotient rather than the remainder. At the high end of the RNG
88 it's possible to get a quotient larger than n; discarding
89 these values eliminates the bias that would otherwise appear
90 when using a large n. */
91 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
93 val
= get_random () / denominator
;
94 while (val
>= XFASTINT (limit
));
98 XSETINT (lispy_val
, val
);
102 /* Heuristic on how many iterations of a tight loop can be safely done
103 before it's time to do a QUIT. This must be a power of 2. */
104 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
106 /* Random data-structure functions */
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
118 if (STRINGP (sequence
))
119 XSETFASTINT (val
, SCHARS (sequence
));
120 else if (VECTORP (sequence
))
121 XSETFASTINT (val
, ASIZE (sequence
));
122 else if (CHAR_TABLE_P (sequence
))
123 XSETFASTINT (val
, MAX_CHAR
);
124 else if (BOOL_VECTOR_P (sequence
))
125 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
126 else if (COMPILEDP (sequence
))
127 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
128 else if (CONSP (sequence
))
135 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
137 if (MOST_POSITIVE_FIXNUM
< i
)
138 error ("List too long");
141 sequence
= XCDR (sequence
);
143 while (CONSP (sequence
));
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 /* This does not check for quits. That is safe since it must terminate. */
159 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
160 doc
: /* Return the length of a list, but avoid error or infinite loop.
161 This function never gets an error. If LIST is not really a list,
162 it returns 0. If LIST is circular, it returns a finite value
163 which is at least the number of distinct elements. */)
166 Lisp_Object tail
, halftail
;
173 /* halftail is used to detect circular lists. */
174 for (tail
= halftail
= list
; ; )
179 if (EQ (tail
, halftail
))
182 if ((lolen
& 1) == 0)
184 halftail
= XCDR (halftail
);
185 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
189 hilen
+= UINTMAX_MAX
+ 1.0;
194 /* If the length does not fit into a fixnum, return a float.
195 On all known practical machines this returns an upper bound on
197 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
200 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
201 doc
: /* Return the number of bytes in STRING.
202 If STRING is multibyte, this may be greater than the length of STRING. */)
205 CHECK_STRING (string
);
206 return make_number (SBYTES (string
));
209 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
210 doc
: /* Return t if two strings have identical contents.
211 Case is significant, but text properties are ignored.
212 Symbols are also allowed; their print names are used instead. */)
213 (register Lisp_Object s1
, Lisp_Object s2
)
216 s1
= SYMBOL_NAME (s1
);
218 s2
= SYMBOL_NAME (s2
);
222 if (SCHARS (s1
) != SCHARS (s2
)
223 || SBYTES (s1
) != SBYTES (s2
)
224 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
229 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
230 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
231 In string STR1, skip the first START1 characters and stop at END1.
232 In string STR2, skip the first START2 characters and stop at END2.
233 END1 and END2 default to the full lengths of the respective strings.
235 Case is significant in this comparison if IGNORE-CASE is nil.
236 Unibyte strings are converted to multibyte for comparison.
238 The value is t if the strings (or specified portions) match.
239 If string STR1 is less, the value is a negative number N;
240 - 1 - N is the number of characters that match at the beginning.
241 If string STR1 is greater, the value is a positive number N;
242 N - 1 is the number of characters that match at the beginning. */)
243 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
245 register EMACS_INT end1_char
, end2_char
;
246 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
251 start1
= make_number (0);
253 start2
= make_number (0);
254 CHECK_NATNUM (start1
);
255 CHECK_NATNUM (start2
);
264 i1_byte
= string_char_to_byte (str1
, i1
);
265 i2_byte
= string_char_to_byte (str2
, i2
);
267 end1_char
= SCHARS (str1
);
268 if (! NILP (end1
) && end1_char
> XINT (end1
))
269 end1_char
= XINT (end1
);
271 end2_char
= SCHARS (str2
);
272 if (! NILP (end2
) && end2_char
> XINT (end2
))
273 end2_char
= XINT (end2
);
275 while (i1
< end1_char
&& i2
< end2_char
)
277 /* When we find a mismatch, we must compare the
278 characters, not just the bytes. */
281 if (STRING_MULTIBYTE (str1
))
282 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
285 c1
= SREF (str1
, i1
++);
286 MAKE_CHAR_MULTIBYTE (c1
);
289 if (STRING_MULTIBYTE (str2
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
293 c2
= SREF (str2
, i2
++);
294 MAKE_CHAR_MULTIBYTE (c2
);
300 if (! NILP (ignore_case
))
304 tem
= Fupcase (make_number (c1
));
306 tem
= Fupcase (make_number (c2
));
313 /* Note that I1 has already been incremented
314 past the character that we are comparing;
315 hence we don't add or subtract 1 here. */
317 return make_number (- i1
+ XINT (start1
));
319 return make_number (i1
- XINT (start1
));
323 return make_number (i1
- XINT (start1
) + 1);
325 return make_number (- i1
+ XINT (start1
) - 1);
330 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
331 doc
: /* Return t if first arg string is less than second in lexicographic order.
333 Symbols are also allowed; their print names are used instead. */)
334 (register Lisp_Object s1
, Lisp_Object s2
)
336 register EMACS_INT end
;
337 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
340 s1
= SYMBOL_NAME (s1
);
342 s2
= SYMBOL_NAME (s2
);
346 i1
= i1_byte
= i2
= i2_byte
= 0;
349 if (end
> SCHARS (s2
))
354 /* When we find a mismatch, we must compare the
355 characters, not just the bytes. */
358 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
359 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
362 return c1
< c2
? Qt
: Qnil
;
364 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
367 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
368 enum Lisp_Type target_type
, int last_special
);
372 concat2 (Lisp_Object s1
, Lisp_Object s2
)
377 return concat (2, args
, Lisp_String
, 0);
382 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
388 return concat (3, args
, Lisp_String
, 0);
391 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
392 doc
: /* Concatenate all the arguments and make the result a list.
393 The result is a list whose elements are the elements of all the arguments.
394 Each argument may be a list, vector or string.
395 The last argument is not copied, just used as the tail of the new list.
396 usage: (append &rest SEQUENCES) */)
397 (ptrdiff_t nargs
, Lisp_Object
*args
)
399 return concat (nargs
, args
, Lisp_Cons
, 1);
402 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
403 doc
: /* Concatenate all the arguments and make the result a string.
404 The result is a string whose elements are the elements of all the arguments.
405 Each argument may be a string or a list or vector of characters (integers).
406 usage: (concat &rest SEQUENCES) */)
407 (ptrdiff_t nargs
, Lisp_Object
*args
)
409 return concat (nargs
, args
, Lisp_String
, 0);
412 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
413 doc
: /* Concatenate all the arguments and make the result a vector.
414 The result is a vector whose elements are the elements of all the arguments.
415 Each argument may be a list, vector or string.
416 usage: (vconcat &rest SEQUENCES) */)
417 (ptrdiff_t nargs
, Lisp_Object
*args
)
419 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
423 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
424 doc
: /* Return a copy of a list, vector, string or char-table.
425 The elements of a list or vector are not copied; they are shared
426 with the original. */)
429 if (NILP (arg
)) return arg
;
431 if (CHAR_TABLE_P (arg
))
433 return copy_char_table (arg
);
436 if (BOOL_VECTOR_P (arg
))
439 ptrdiff_t size_in_chars
440 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
441 / BOOL_VECTOR_BITS_PER_CHAR
);
443 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
444 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
449 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
450 wrong_type_argument (Qsequencep
, arg
);
452 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
455 /* This structure holds information of an argument of `concat' that is
456 a string and has text properties to be copied. */
459 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
460 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
461 EMACS_INT to
; /* refer to VAL (the target string) */
465 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
466 enum Lisp_Type target_type
, int last_special
)
469 register Lisp_Object tail
;
470 register Lisp_Object
this;
472 EMACS_INT toindex_byte
= 0;
473 register EMACS_INT result_len
;
474 register EMACS_INT result_len_byte
;
476 Lisp_Object last_tail
;
479 /* When we make a multibyte string, we can't copy text properties
480 while concatenating each string because the length of resulting
481 string can't be decided until we finish the whole concatenation.
482 So, we record strings that have text properties to be copied
483 here, and copy the text properties after the concatenation. */
484 struct textprop_rec
*textprops
= NULL
;
485 /* Number of elements in textprops. */
486 ptrdiff_t num_textprops
= 0;
491 /* In append, the last arg isn't treated like the others */
492 if (last_special
&& nargs
> 0)
495 last_tail
= args
[nargs
];
500 /* Check each argument. */
501 for (argnum
= 0; argnum
< nargs
; argnum
++)
504 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
505 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
506 wrong_type_argument (Qsequencep
, this);
509 /* Compute total length in chars of arguments in RESULT_LEN.
510 If desired output is a string, also compute length in bytes
511 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
512 whether the result should be a multibyte string. */
516 for (argnum
= 0; argnum
< nargs
; argnum
++)
520 len
= XFASTINT (Flength (this));
521 if (target_type
== Lisp_String
)
523 /* We must count the number of bytes needed in the string
524 as well as the number of characters. */
528 EMACS_INT this_len_byte
;
530 if (VECTORP (this) || COMPILEDP (this))
531 for (i
= 0; i
< len
; i
++)
534 CHECK_CHARACTER (ch
);
536 this_len_byte
= CHAR_BYTES (c
);
537 result_len_byte
+= this_len_byte
;
538 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
541 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
542 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
543 else if (CONSP (this))
544 for (; CONSP (this); this = XCDR (this))
547 CHECK_CHARACTER (ch
);
549 this_len_byte
= CHAR_BYTES (c
);
550 result_len_byte
+= this_len_byte
;
551 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
554 else if (STRINGP (this))
556 if (STRING_MULTIBYTE (this))
559 result_len_byte
+= SBYTES (this);
562 result_len_byte
+= count_size_as_multibyte (SDATA (this),
568 if (STRING_BYTES_BOUND
< result_len
)
572 if (! some_multibyte
)
573 result_len_byte
= result_len
;
575 /* Create the output object. */
576 if (target_type
== Lisp_Cons
)
577 val
= Fmake_list (make_number (result_len
), Qnil
);
578 else if (target_type
== Lisp_Vectorlike
)
579 val
= Fmake_vector (make_number (result_len
), Qnil
);
580 else if (some_multibyte
)
581 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
583 val
= make_uninit_string (result_len
);
585 /* In `append', if all but last arg are nil, return last arg. */
586 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
589 /* Copy the contents of the args into the result. */
591 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
593 toindex
= 0, toindex_byte
= 0;
597 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
599 for (argnum
= 0; argnum
< nargs
; argnum
++)
602 EMACS_INT thisleni
= 0;
603 register EMACS_INT thisindex
= 0;
604 register EMACS_INT thisindex_byte
= 0;
608 thislen
= Flength (this), thisleni
= XINT (thislen
);
610 /* Between strings of the same kind, copy fast. */
611 if (STRINGP (this) && STRINGP (val
)
612 && STRING_MULTIBYTE (this) == some_multibyte
)
614 EMACS_INT thislen_byte
= SBYTES (this);
616 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
617 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
619 textprops
[num_textprops
].argnum
= argnum
;
620 textprops
[num_textprops
].from
= 0;
621 textprops
[num_textprops
++].to
= toindex
;
623 toindex_byte
+= thislen_byte
;
626 /* Copy a single-byte string to a multibyte string. */
627 else if (STRINGP (this) && STRINGP (val
))
629 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
631 textprops
[num_textprops
].argnum
= argnum
;
632 textprops
[num_textprops
].from
= 0;
633 textprops
[num_textprops
++].to
= toindex
;
635 toindex_byte
+= copy_text (SDATA (this),
636 SDATA (val
) + toindex_byte
,
637 SCHARS (this), 0, 1);
641 /* Copy element by element. */
644 register Lisp_Object elt
;
646 /* Fetch next element of `this' arg into `elt', or break if
647 `this' is exhausted. */
648 if (NILP (this)) break;
650 elt
= XCAR (this), this = XCDR (this);
651 else if (thisindex
>= thisleni
)
653 else if (STRINGP (this))
656 if (STRING_MULTIBYTE (this))
657 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
662 c
= SREF (this, thisindex
); thisindex
++;
663 if (some_multibyte
&& !ASCII_CHAR_P (c
))
664 c
= BYTE8_TO_CHAR (c
);
666 XSETFASTINT (elt
, c
);
668 else if (BOOL_VECTOR_P (this))
671 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
672 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
680 elt
= AREF (this, thisindex
);
684 /* Store this element into the result. */
691 else if (VECTORP (val
))
693 ASET (val
, toindex
, elt
);
699 CHECK_CHARACTER (elt
);
702 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
704 SSET (val
, toindex_byte
++, c
);
710 XSETCDR (prev
, last_tail
);
712 if (num_textprops
> 0)
715 EMACS_INT last_to_end
= -1;
717 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
719 this = args
[textprops
[argnum
].argnum
];
720 props
= text_property_list (this,
722 make_number (SCHARS (this)),
724 /* If successive arguments have properties, be sure that the
725 value of `composition' property be the copy. */
726 if (last_to_end
== textprops
[argnum
].to
)
727 make_composition_value_copy (props
);
728 add_text_properties_from_list (val
, props
,
729 make_number (textprops
[argnum
].to
));
730 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
738 static Lisp_Object string_char_byte_cache_string
;
739 static EMACS_INT string_char_byte_cache_charpos
;
740 static EMACS_INT string_char_byte_cache_bytepos
;
743 clear_string_char_byte_cache (void)
745 string_char_byte_cache_string
= Qnil
;
748 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
751 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
754 EMACS_INT best_below
, best_below_byte
;
755 EMACS_INT best_above
, best_above_byte
;
757 best_below
= best_below_byte
= 0;
758 best_above
= SCHARS (string
);
759 best_above_byte
= SBYTES (string
);
760 if (best_above
== best_above_byte
)
763 if (EQ (string
, string_char_byte_cache_string
))
765 if (string_char_byte_cache_charpos
< char_index
)
767 best_below
= string_char_byte_cache_charpos
;
768 best_below_byte
= string_char_byte_cache_bytepos
;
772 best_above
= string_char_byte_cache_charpos
;
773 best_above_byte
= string_char_byte_cache_bytepos
;
777 if (char_index
- best_below
< best_above
- char_index
)
779 unsigned char *p
= SDATA (string
) + best_below_byte
;
781 while (best_below
< char_index
)
783 p
+= BYTES_BY_CHAR_HEAD (*p
);
786 i_byte
= p
- SDATA (string
);
790 unsigned char *p
= SDATA (string
) + best_above_byte
;
792 while (best_above
> char_index
)
795 while (!CHAR_HEAD_P (*p
)) p
--;
798 i_byte
= p
- SDATA (string
);
801 string_char_byte_cache_bytepos
= i_byte
;
802 string_char_byte_cache_charpos
= char_index
;
803 string_char_byte_cache_string
= string
;
808 /* Return the character index corresponding to BYTE_INDEX in STRING. */
811 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
814 EMACS_INT best_below
, best_below_byte
;
815 EMACS_INT best_above
, best_above_byte
;
817 best_below
= best_below_byte
= 0;
818 best_above
= SCHARS (string
);
819 best_above_byte
= SBYTES (string
);
820 if (best_above
== best_above_byte
)
823 if (EQ (string
, string_char_byte_cache_string
))
825 if (string_char_byte_cache_bytepos
< byte_index
)
827 best_below
= string_char_byte_cache_charpos
;
828 best_below_byte
= string_char_byte_cache_bytepos
;
832 best_above
= string_char_byte_cache_charpos
;
833 best_above_byte
= string_char_byte_cache_bytepos
;
837 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
839 unsigned char *p
= SDATA (string
) + best_below_byte
;
840 unsigned char *pend
= SDATA (string
) + byte_index
;
844 p
+= BYTES_BY_CHAR_HEAD (*p
);
848 i_byte
= p
- SDATA (string
);
852 unsigned char *p
= SDATA (string
) + best_above_byte
;
853 unsigned char *pbeg
= SDATA (string
) + byte_index
;
858 while (!CHAR_HEAD_P (*p
)) p
--;
862 i_byte
= p
- SDATA (string
);
865 string_char_byte_cache_bytepos
= i_byte
;
866 string_char_byte_cache_charpos
= i
;
867 string_char_byte_cache_string
= string
;
872 /* Convert STRING to a multibyte string. */
875 string_make_multibyte (Lisp_Object string
)
882 if (STRING_MULTIBYTE (string
))
885 nbytes
= count_size_as_multibyte (SDATA (string
),
887 /* If all the chars are ASCII, they won't need any more bytes
888 once converted. In that case, we can return STRING itself. */
889 if (nbytes
== SBYTES (string
))
892 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
893 copy_text (SDATA (string
), buf
, SBYTES (string
),
896 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
903 /* Convert STRING (if unibyte) to a multibyte string without changing
904 the number of characters. Characters 0200 trough 0237 are
905 converted to eight-bit characters. */
908 string_to_multibyte (Lisp_Object string
)
915 if (STRING_MULTIBYTE (string
))
918 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
919 /* If all the chars are ASCII, they won't need any more bytes once
921 if (nbytes
== SBYTES (string
))
922 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
924 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
925 memcpy (buf
, SDATA (string
), SBYTES (string
));
926 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
928 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
935 /* Convert STRING to a single-byte string. */
938 string_make_unibyte (Lisp_Object string
)
945 if (! STRING_MULTIBYTE (string
))
948 nchars
= SCHARS (string
);
950 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
951 copy_text (SDATA (string
), buf
, SBYTES (string
),
954 ret
= make_unibyte_string ((char *) buf
, nchars
);
960 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
962 doc
: /* Return the multibyte equivalent of STRING.
963 If STRING is unibyte and contains non-ASCII characters, the function
964 `unibyte-char-to-multibyte' is used to convert each unibyte character
965 to a multibyte character. In this case, the returned string is a
966 newly created string with no text properties. If STRING is multibyte
967 or entirely ASCII, it is returned unchanged. In particular, when
968 STRING is unibyte and entirely ASCII, the returned string is unibyte.
969 \(When the characters are all ASCII, Emacs primitives will treat the
970 string the same way whether it is unibyte or multibyte.) */)
973 CHECK_STRING (string
);
975 return string_make_multibyte (string
);
978 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
980 doc
: /* Return the unibyte equivalent of STRING.
981 Multibyte character codes are converted to unibyte according to
982 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
983 If the lookup in the translation table fails, this function takes just
984 the low 8 bits of each character. */)
987 CHECK_STRING (string
);
989 return string_make_unibyte (string
);
992 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
994 doc
: /* Return a unibyte string with the same individual bytes as STRING.
995 If STRING is unibyte, the result is STRING itself.
996 Otherwise it is a newly created string, with no text properties.
997 If STRING is multibyte and contains a character of charset
998 `eight-bit', it is converted to the corresponding single byte. */)
1001 CHECK_STRING (string
);
1003 if (STRING_MULTIBYTE (string
))
1005 EMACS_INT bytes
= SBYTES (string
);
1006 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1008 memcpy (str
, SDATA (string
), bytes
);
1009 bytes
= str_as_unibyte (str
, bytes
);
1010 string
= make_unibyte_string ((char *) str
, bytes
);
1016 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1018 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1019 If STRING is multibyte, the result is STRING itself.
1020 Otherwise it is a newly created string, with no text properties.
1022 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1023 part of a correct utf-8 sequence), it is converted to the corresponding
1024 multibyte character of charset `eight-bit'.
1025 See also `string-to-multibyte'.
1027 Beware, this often doesn't really do what you think it does.
1028 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1029 If you're not sure, whether to use `string-as-multibyte' or
1030 `string-to-multibyte', use `string-to-multibyte'. */)
1031 (Lisp_Object string
)
1033 CHECK_STRING (string
);
1035 if (! STRING_MULTIBYTE (string
))
1037 Lisp_Object new_string
;
1038 EMACS_INT nchars
, nbytes
;
1040 parse_str_as_multibyte (SDATA (string
),
1043 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1044 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1045 if (nbytes
!= SBYTES (string
))
1046 str_as_multibyte (SDATA (new_string
), nbytes
,
1047 SBYTES (string
), NULL
);
1048 string
= new_string
;
1049 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1054 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1056 doc
: /* Return a multibyte string with the same individual chars as STRING.
1057 If STRING is multibyte, the result is STRING itself.
1058 Otherwise it is a newly created string, with no text properties.
1060 If STRING is unibyte and contains an 8-bit byte, it is converted to
1061 the corresponding multibyte character of charset `eight-bit'.
1063 This differs from `string-as-multibyte' by converting each byte of a correct
1064 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1065 correct sequence. */)
1066 (Lisp_Object string
)
1068 CHECK_STRING (string
);
1070 return string_to_multibyte (string
);
1073 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1075 doc
: /* Return a unibyte string with the same individual chars as STRING.
1076 If STRING is unibyte, the result is STRING itself.
1077 Otherwise it is a newly created string, with no text properties,
1078 where each `eight-bit' character is converted to the corresponding byte.
1079 If STRING contains a non-ASCII, non-`eight-bit' character,
1080 an error is signaled. */)
1081 (Lisp_Object string
)
1083 CHECK_STRING (string
);
1085 if (STRING_MULTIBYTE (string
))
1087 EMACS_INT chars
= SCHARS (string
);
1088 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1089 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1091 if (converted
< chars
)
1092 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1093 string
= make_unibyte_string ((char *) str
, chars
);
1100 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1101 doc
: /* Return a copy of ALIST.
1102 This is an alist which represents the same mapping from objects to objects,
1103 but does not share the alist structure with ALIST.
1104 The objects mapped (cars and cdrs of elements of the alist)
1105 are shared, however.
1106 Elements of ALIST that are not conses are also shared. */)
1109 register Lisp_Object tem
;
1114 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1115 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1117 register Lisp_Object car
;
1121 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1126 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1127 doc
: /* Return a new string whose contents are a substring of STRING.
1128 The returned string consists of the characters between index FROM
1129 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1130 zero-indexed: 0 means the first character of STRING. Negative values
1131 are counted from the end of STRING. If TO is nil, the substring runs
1132 to the end of STRING.
1134 The STRING argument may also be a vector. In that case, the return
1135 value is a new vector that contains the elements between index FROM
1136 \(inclusive) and index TO (exclusive) of that vector argument. */)
1137 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1141 EMACS_INT size_byte
= 0;
1142 EMACS_INT from_char
, to_char
;
1143 EMACS_INT from_byte
= 0, to_byte
= 0;
1145 CHECK_VECTOR_OR_STRING (string
);
1146 CHECK_NUMBER (from
);
1148 if (STRINGP (string
))
1150 size
= SCHARS (string
);
1151 size_byte
= SBYTES (string
);
1154 size
= ASIZE (string
);
1159 to_byte
= size_byte
;
1165 to_char
= XINT (to
);
1169 if (STRINGP (string
))
1170 to_byte
= string_char_to_byte (string
, to_char
);
1173 from_char
= XINT (from
);
1176 if (STRINGP (string
))
1177 from_byte
= string_char_to_byte (string
, from_char
);
1179 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1180 args_out_of_range_3 (string
, make_number (from_char
),
1181 make_number (to_char
));
1183 if (STRINGP (string
))
1185 res
= make_specified_string (SSDATA (string
) + from_byte
,
1186 to_char
- from_char
, to_byte
- from_byte
,
1187 STRING_MULTIBYTE (string
));
1188 copy_text_properties (make_number (from_char
), make_number (to_char
),
1189 string
, make_number (0), res
, Qnil
);
1192 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1198 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1199 doc
: /* Return a substring of STRING, without text properties.
1200 It starts at index FROM and ends before TO.
1201 TO may be nil or omitted; then the substring runs to the end of STRING.
1202 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1203 If FROM or TO is negative, it counts from the end.
1205 With one argument, just copy STRING without its properties. */)
1206 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1208 EMACS_INT size
, size_byte
;
1209 EMACS_INT from_char
, to_char
;
1210 EMACS_INT from_byte
, to_byte
;
1212 CHECK_STRING (string
);
1214 size
= SCHARS (string
);
1215 size_byte
= SBYTES (string
);
1218 from_char
= from_byte
= 0;
1221 CHECK_NUMBER (from
);
1222 from_char
= XINT (from
);
1226 from_byte
= string_char_to_byte (string
, from_char
);
1232 to_byte
= size_byte
;
1238 to_char
= XINT (to
);
1242 to_byte
= string_char_to_byte (string
, to_char
);
1245 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1246 args_out_of_range_3 (string
, make_number (from_char
),
1247 make_number (to_char
));
1249 return make_specified_string (SSDATA (string
) + from_byte
,
1250 to_char
- from_char
, to_byte
- from_byte
,
1251 STRING_MULTIBYTE (string
));
1254 /* Extract a substring of STRING, giving start and end positions
1255 both in characters and in bytes. */
1258 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1259 EMACS_INT to
, EMACS_INT to_byte
)
1264 CHECK_VECTOR_OR_STRING (string
);
1266 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1268 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1269 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1271 if (STRINGP (string
))
1273 res
= make_specified_string (SSDATA (string
) + from_byte
,
1274 to
- from
, to_byte
- from_byte
,
1275 STRING_MULTIBYTE (string
));
1276 copy_text_properties (make_number (from
), make_number (to
),
1277 string
, make_number (0), res
, Qnil
);
1280 res
= Fvector (to
- from
, &AREF (string
, from
));
1285 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1286 doc
: /* Take cdr N times on LIST, return the result. */)
1287 (Lisp_Object n
, Lisp_Object list
)
1292 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1295 CHECK_LIST_CONS (list
, list
);
1301 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1302 doc
: /* Return the Nth element of LIST.
1303 N counts from zero. If LIST is not that long, nil is returned. */)
1304 (Lisp_Object n
, Lisp_Object list
)
1306 return Fcar (Fnthcdr (n
, list
));
1309 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1310 doc
: /* Return element of SEQUENCE at index N. */)
1311 (register Lisp_Object sequence
, Lisp_Object n
)
1314 if (CONSP (sequence
) || NILP (sequence
))
1315 return Fcar (Fnthcdr (n
, sequence
));
1317 /* Faref signals a "not array" error, so check here. */
1318 CHECK_ARRAY (sequence
, Qsequencep
);
1319 return Faref (sequence
, n
);
1322 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1323 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1324 The value is actually the tail of LIST whose car is ELT. */)
1325 (register Lisp_Object elt
, Lisp_Object list
)
1327 register Lisp_Object tail
;
1328 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1330 register Lisp_Object tem
;
1331 CHECK_LIST_CONS (tail
, list
);
1333 if (! NILP (Fequal (elt
, tem
)))
1340 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1341 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1342 The value is actually the tail of LIST whose car is ELT. */)
1343 (register Lisp_Object elt
, Lisp_Object list
)
1347 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1351 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1355 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1366 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1367 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1368 The value is actually the tail of LIST whose car is ELT. */)
1369 (register Lisp_Object elt
, Lisp_Object list
)
1371 register Lisp_Object tail
;
1374 return Fmemq (elt
, list
);
1376 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1378 register Lisp_Object tem
;
1379 CHECK_LIST_CONS (tail
, list
);
1381 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1388 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1389 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1390 The value is actually the first element of LIST whose car is KEY.
1391 Elements of LIST that are not conses are ignored. */)
1392 (Lisp_Object key
, Lisp_Object list
)
1397 || (CONSP (XCAR (list
))
1398 && EQ (XCAR (XCAR (list
)), key
)))
1403 || (CONSP (XCAR (list
))
1404 && EQ (XCAR (XCAR (list
)), key
)))
1409 || (CONSP (XCAR (list
))
1410 && EQ (XCAR (XCAR (list
)), key
)))
1420 /* Like Fassq but never report an error and do not allow quits.
1421 Use only on lists known never to be circular. */
1424 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1427 && (!CONSP (XCAR (list
))
1428 || !EQ (XCAR (XCAR (list
)), key
)))
1431 return CAR_SAFE (list
);
1434 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1435 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1436 The value is actually the first element of LIST whose car equals KEY. */)
1437 (Lisp_Object key
, Lisp_Object list
)
1444 || (CONSP (XCAR (list
))
1445 && (car
= XCAR (XCAR (list
)),
1446 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1451 || (CONSP (XCAR (list
))
1452 && (car
= XCAR (XCAR (list
)),
1453 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1458 || (CONSP (XCAR (list
))
1459 && (car
= XCAR (XCAR (list
)),
1460 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1470 /* Like Fassoc but never report an error and do not allow quits.
1471 Use only on lists known never to be circular. */
1474 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1477 && (!CONSP (XCAR (list
))
1478 || (!EQ (XCAR (XCAR (list
)), key
)
1479 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1482 return CONSP (list
) ? XCAR (list
) : Qnil
;
1485 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1486 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1487 The value is actually the first element of LIST whose cdr is KEY. */)
1488 (register Lisp_Object key
, Lisp_Object list
)
1493 || (CONSP (XCAR (list
))
1494 && EQ (XCDR (XCAR (list
)), key
)))
1499 || (CONSP (XCAR (list
))
1500 && EQ (XCDR (XCAR (list
)), key
)))
1505 || (CONSP (XCAR (list
))
1506 && EQ (XCDR (XCAR (list
)), key
)))
1516 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1517 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1518 The value is actually the first element of LIST whose cdr equals KEY. */)
1519 (Lisp_Object key
, Lisp_Object list
)
1526 || (CONSP (XCAR (list
))
1527 && (cdr
= XCDR (XCAR (list
)),
1528 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1533 || (CONSP (XCAR (list
))
1534 && (cdr
= XCDR (XCAR (list
)),
1535 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1540 || (CONSP (XCAR (list
))
1541 && (cdr
= XCDR (XCAR (list
)),
1542 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1552 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1553 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1554 The modified LIST is returned. Comparison is done with `eq'.
1555 If the first member of LIST is ELT, there is no way to remove it by side effect;
1556 therefore, write `(setq foo (delq element foo))'
1557 to be sure of changing the value of `foo'. */)
1558 (register Lisp_Object elt
, Lisp_Object list
)
1560 register Lisp_Object tail
, prev
;
1561 register Lisp_Object tem
;
1565 while (!NILP (tail
))
1567 CHECK_LIST_CONS (tail
, list
);
1574 Fsetcdr (prev
, XCDR (tail
));
1584 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1585 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1586 SEQ must be a list, a vector, or a string.
1587 The modified SEQ is returned. Comparison is done with `equal'.
1588 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1589 is not a side effect; it is simply using a different sequence.
1590 Therefore, write `(setq foo (delete element foo))'
1591 to be sure of changing the value of `foo'. */)
1592 (Lisp_Object elt
, Lisp_Object seq
)
1598 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1599 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1602 if (n
!= ASIZE (seq
))
1604 struct Lisp_Vector
*p
= allocate_vector (n
);
1606 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1607 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1608 p
->contents
[n
++] = AREF (seq
, i
);
1610 XSETVECTOR (seq
, p
);
1613 else if (STRINGP (seq
))
1615 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1618 for (i
= nchars
= nbytes
= ibyte
= 0;
1620 ++i
, ibyte
+= cbytes
)
1622 if (STRING_MULTIBYTE (seq
))
1624 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1625 cbytes
= CHAR_BYTES (c
);
1633 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1640 if (nchars
!= SCHARS (seq
))
1644 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1645 if (!STRING_MULTIBYTE (seq
))
1646 STRING_SET_UNIBYTE (tem
);
1648 for (i
= nchars
= nbytes
= ibyte
= 0;
1650 ++i
, ibyte
+= cbytes
)
1652 if (STRING_MULTIBYTE (seq
))
1654 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1655 cbytes
= CHAR_BYTES (c
);
1663 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1665 unsigned char *from
= SDATA (seq
) + ibyte
;
1666 unsigned char *to
= SDATA (tem
) + nbytes
;
1672 for (n
= cbytes
; n
--; )
1682 Lisp_Object tail
, prev
;
1684 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1686 CHECK_LIST_CONS (tail
, seq
);
1688 if (!NILP (Fequal (elt
, XCAR (tail
))))
1693 Fsetcdr (prev
, XCDR (tail
));
1704 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1705 doc
: /* Reverse LIST by modifying cdr pointers.
1706 Return the reversed list. */)
1709 register Lisp_Object prev
, tail
, next
;
1711 if (NILP (list
)) return list
;
1714 while (!NILP (tail
))
1717 CHECK_LIST_CONS (tail
, list
);
1719 Fsetcdr (tail
, prev
);
1726 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1727 doc
: /* Reverse LIST, copying. Return the reversed list.
1728 See also the function `nreverse', which is used more often. */)
1733 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1736 new = Fcons (XCAR (list
), new);
1738 CHECK_LIST_END (list
, list
);
1742 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1744 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1745 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1746 Returns the sorted list. LIST is modified by side effects.
1747 PREDICATE is called with two elements of LIST, and should return non-nil
1748 if the first element should sort before the second. */)
1749 (Lisp_Object list
, Lisp_Object predicate
)
1751 Lisp_Object front
, back
;
1752 register Lisp_Object len
, tem
;
1753 struct gcpro gcpro1
, gcpro2
;
1757 len
= Flength (list
);
1758 length
= XINT (len
);
1762 XSETINT (len
, (length
/ 2) - 1);
1763 tem
= Fnthcdr (len
, list
);
1765 Fsetcdr (tem
, Qnil
);
1767 GCPRO2 (front
, back
);
1768 front
= Fsort (front
, predicate
);
1769 back
= Fsort (back
, predicate
);
1771 return merge (front
, back
, predicate
);
1775 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1778 register Lisp_Object tail
;
1780 register Lisp_Object l1
, l2
;
1781 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1788 /* It is sufficient to protect org_l1 and org_l2.
1789 When l1 and l2 are updated, we copy the new values
1790 back into the org_ vars. */
1791 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1811 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1827 Fsetcdr (tail
, tem
);
1833 /* This does not check for quits. That is safe since it must terminate. */
1835 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1836 doc
: /* Extract a value from a property list.
1837 PLIST is a property list, which is a list of the form
1838 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1839 corresponding to the given PROP, or nil if PROP is not one of the
1840 properties on the list. This function never signals an error. */)
1841 (Lisp_Object plist
, Lisp_Object prop
)
1843 Lisp_Object tail
, halftail
;
1845 /* halftail is used to detect circular lists. */
1846 tail
= halftail
= plist
;
1847 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1849 if (EQ (prop
, XCAR (tail
)))
1850 return XCAR (XCDR (tail
));
1852 tail
= XCDR (XCDR (tail
));
1853 halftail
= XCDR (halftail
);
1854 if (EQ (tail
, halftail
))
1857 #if 0 /* Unsafe version. */
1858 /* This function can be called asynchronously
1859 (setup_coding_system). Don't QUIT in that case. */
1860 if (!interrupt_input_blocked
)
1868 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1869 doc
: /* Return the value of SYMBOL's PROPNAME property.
1870 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1871 (Lisp_Object symbol
, Lisp_Object propname
)
1873 CHECK_SYMBOL (symbol
);
1874 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1877 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1878 doc
: /* Change value in PLIST of PROP to VAL.
1879 PLIST is a property list, which is a list of the form
1880 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1881 If PROP is already a property on the list, its value is set to VAL,
1882 otherwise the new PROP VAL pair is added. The new plist is returned;
1883 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1884 The PLIST is modified by side effects. */)
1885 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1887 register Lisp_Object tail
, prev
;
1888 Lisp_Object newcell
;
1890 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1891 tail
= XCDR (XCDR (tail
)))
1893 if (EQ (prop
, XCAR (tail
)))
1895 Fsetcar (XCDR (tail
), val
);
1902 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1906 Fsetcdr (XCDR (prev
), newcell
);
1910 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1911 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1912 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1913 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1915 CHECK_SYMBOL (symbol
);
1916 XSYMBOL (symbol
)->plist
1917 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1921 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1922 doc
: /* Extract a value from a property list, comparing with `equal'.
1923 PLIST is a property list, which is a list of the form
1924 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1925 corresponding to the given PROP, or nil if PROP is not
1926 one of the properties on the list. */)
1927 (Lisp_Object plist
, Lisp_Object prop
)
1932 CONSP (tail
) && CONSP (XCDR (tail
));
1933 tail
= XCDR (XCDR (tail
)))
1935 if (! NILP (Fequal (prop
, XCAR (tail
))))
1936 return XCAR (XCDR (tail
));
1941 CHECK_LIST_END (tail
, prop
);
1946 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1947 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1948 PLIST is a property list, which is a list of the form
1949 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1950 If PROP is already a property on the list, its value is set to VAL,
1951 otherwise the new PROP VAL pair is added. The new plist is returned;
1952 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1953 The PLIST is modified by side effects. */)
1954 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1956 register Lisp_Object tail
, prev
;
1957 Lisp_Object newcell
;
1959 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1960 tail
= XCDR (XCDR (tail
)))
1962 if (! NILP (Fequal (prop
, XCAR (tail
))))
1964 Fsetcar (XCDR (tail
), val
);
1971 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1975 Fsetcdr (XCDR (prev
), newcell
);
1979 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1980 doc
: /* Return t if the two args are the same Lisp object.
1981 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1982 (Lisp_Object obj1
, Lisp_Object obj2
)
1985 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1987 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1990 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1991 doc
: /* Return t if two Lisp objects have similar structure and contents.
1992 They must have the same data type.
1993 Conses are compared by comparing the cars and the cdrs.
1994 Vectors and strings are compared element by element.
1995 Numbers are compared by value, but integers cannot equal floats.
1996 (Use `=' if you want integers and floats to be able to be equal.)
1997 Symbols must match exactly. */)
1998 (register Lisp_Object o1
, Lisp_Object o2
)
2000 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2003 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2004 doc
: /* Return t if two Lisp objects have similar structure and contents.
2005 This is like `equal' except that it compares the text properties
2006 of strings. (`equal' ignores text properties.) */)
2007 (register Lisp_Object o1
, Lisp_Object o2
)
2009 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2012 /* DEPTH is current depth of recursion. Signal an error if it
2014 PROPS, if non-nil, means compare string text properties too. */
2017 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2020 error ("Stack overflow in equal");
2026 if (XTYPE (o1
) != XTYPE (o2
))
2035 d1
= extract_float (o1
);
2036 d2
= extract_float (o2
);
2037 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2038 though they are not =. */
2039 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2043 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2050 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2054 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2056 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2059 o1
= XOVERLAY (o1
)->plist
;
2060 o2
= XOVERLAY (o2
)->plist
;
2065 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2066 && (XMARKER (o1
)->buffer
== 0
2067 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2071 case Lisp_Vectorlike
:
2074 EMACS_INT size
= ASIZE (o1
);
2075 /* Pseudovectors have the type encoded in the size field, so this test
2076 actually checks that the objects have the same type as well as the
2078 if (ASIZE (o2
) != size
)
2080 /* Boolvectors are compared much like strings. */
2081 if (BOOL_VECTOR_P (o1
))
2083 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2085 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2086 ((XBOOL_VECTOR (o1
)->size
2087 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2088 / BOOL_VECTOR_BITS_PER_CHAR
)))
2092 if (WINDOW_CONFIGURATIONP (o1
))
2093 return compare_window_configurations (o1
, o2
, 0);
2095 /* Aside from them, only true vectors, char-tables, compiled
2096 functions, and fonts (font-spec, font-entity, font-object)
2097 are sensible to compare, so eliminate the others now. */
2098 if (size
& PSEUDOVECTOR_FLAG
)
2100 if (!(size
& (PVEC_COMPILED
2101 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2103 size
&= PSEUDOVECTOR_SIZE_MASK
;
2105 for (i
= 0; i
< size
; i
++)
2110 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2118 if (SCHARS (o1
) != SCHARS (o2
))
2120 if (SBYTES (o1
) != SBYTES (o2
))
2122 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2124 if (props
&& !compare_string_intervals (o1
, o2
))
2136 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2137 doc
: /* Store each element of ARRAY with ITEM.
2138 ARRAY is a vector, string, char-table, or bool-vector. */)
2139 (Lisp_Object array
, Lisp_Object item
)
2141 register EMACS_INT size
, idx
;
2144 if (VECTORP (array
))
2146 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2147 size
= ASIZE (array
);
2148 for (idx
= 0; idx
< size
; idx
++)
2151 else if (CHAR_TABLE_P (array
))
2155 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2156 XCHAR_TABLE (array
)->contents
[i
] = item
;
2157 XCHAR_TABLE (array
)->defalt
= item
;
2159 else if (STRINGP (array
))
2161 register unsigned char *p
= SDATA (array
);
2162 CHECK_NUMBER (item
);
2163 charval
= XINT (item
);
2164 size
= SCHARS (array
);
2165 if (STRING_MULTIBYTE (array
))
2167 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2168 int len
= CHAR_STRING (charval
, str
);
2169 EMACS_INT size_byte
= SBYTES (array
);
2170 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2173 if (size
!= size_byte
)
2176 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2177 if (len
!= this_len
)
2178 error ("Attempt to change byte length of a string");
2181 for (i
= 0; i
< size_byte
; i
++)
2182 *p
++ = str
[i
% len
];
2185 for (idx
= 0; idx
< size
; idx
++)
2188 else if (BOOL_VECTOR_P (array
))
2190 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2191 EMACS_INT size
= XBOOL_VECTOR (array
)->size
;
2192 EMACS_INT size_in_chars
2193 = ((size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2194 / BOOL_VECTOR_BITS_PER_CHAR
);
2198 memset (p
, ! NILP (item
) ? -1 : 0, size_in_chars
);
2200 /* Clear any extraneous bits in the last byte. */
2201 p
[size_in_chars
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2205 wrong_type_argument (Qarrayp
, array
);
2209 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2211 doc
: /* Clear the contents of STRING.
2212 This makes STRING unibyte and may change its length. */)
2213 (Lisp_Object string
)
2216 CHECK_STRING (string
);
2217 len
= SBYTES (string
);
2218 memset (SDATA (string
), 0, len
);
2219 STRING_SET_CHARS (string
, len
);
2220 STRING_SET_UNIBYTE (string
);
2226 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2228 Lisp_Object args
[2];
2231 return Fnconc (2, args
);
2234 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2235 doc
: /* Concatenate any number of lists by altering them.
2236 Only the last argument is not altered, and need not be a list.
2237 usage: (nconc &rest LISTS) */)
2238 (ptrdiff_t nargs
, Lisp_Object
*args
)
2241 register Lisp_Object tail
, tem
, val
;
2245 for (argnum
= 0; argnum
< nargs
; argnum
++)
2248 if (NILP (tem
)) continue;
2253 if (argnum
+ 1 == nargs
) break;
2255 CHECK_LIST_CONS (tem
, tem
);
2264 tem
= args
[argnum
+ 1];
2265 Fsetcdr (tail
, tem
);
2267 args
[argnum
+ 1] = tail
;
2273 /* This is the guts of all mapping functions.
2274 Apply FN to each element of SEQ, one by one,
2275 storing the results into elements of VALS, a C vector of Lisp_Objects.
2276 LENI is the length of VALS, which should also be the length of SEQ. */
2279 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2281 register Lisp_Object tail
;
2283 register EMACS_INT i
;
2284 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2288 /* Don't let vals contain any garbage when GC happens. */
2289 for (i
= 0; i
< leni
; i
++)
2292 GCPRO3 (dummy
, fn
, seq
);
2294 gcpro1
.nvars
= leni
;
2298 /* We need not explicitly protect `tail' because it is used only on lists, and
2299 1) lists are not relocated and 2) the list is marked via `seq' so will not
2302 if (VECTORP (seq
) || COMPILEDP (seq
))
2304 for (i
= 0; i
< leni
; i
++)
2306 dummy
= call1 (fn
, AREF (seq
, i
));
2311 else if (BOOL_VECTOR_P (seq
))
2313 for (i
= 0; i
< leni
; i
++)
2316 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2317 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2318 dummy
= call1 (fn
, dummy
);
2323 else if (STRINGP (seq
))
2327 for (i
= 0, i_byte
= 0; i
< leni
;)
2330 EMACS_INT i_before
= i
;
2332 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2333 XSETFASTINT (dummy
, c
);
2334 dummy
= call1 (fn
, dummy
);
2336 vals
[i_before
] = dummy
;
2339 else /* Must be a list, since Flength did not get an error */
2342 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2344 dummy
= call1 (fn
, XCAR (tail
));
2354 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2355 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2356 In between each pair of results, stick in SEPARATOR. Thus, " " as
2357 SEPARATOR results in spaces between the values returned by FUNCTION.
2358 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2359 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2362 register EMACS_INT leni
;
2364 register Lisp_Object
*args
;
2365 struct gcpro gcpro1
;
2369 len
= Flength (sequence
);
2370 if (CHAR_TABLE_P (sequence
))
2371 wrong_type_argument (Qlistp
, sequence
);
2373 nargs
= leni
+ leni
- 1;
2374 if (nargs
< 0) return empty_unibyte_string
;
2376 SAFE_ALLOCA_LISP (args
, nargs
);
2379 mapcar1 (leni
, args
, function
, sequence
);
2382 for (i
= leni
- 1; i
> 0; i
--)
2383 args
[i
+ i
] = args
[i
];
2385 for (i
= 1; i
< nargs
; i
+= 2)
2386 args
[i
] = separator
;
2388 ret
= Fconcat (nargs
, args
);
2394 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2395 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2396 The result is a list just as long as SEQUENCE.
2397 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2398 (Lisp_Object function
, Lisp_Object sequence
)
2400 register Lisp_Object len
;
2401 register EMACS_INT leni
;
2402 register Lisp_Object
*args
;
2406 len
= Flength (sequence
);
2407 if (CHAR_TABLE_P (sequence
))
2408 wrong_type_argument (Qlistp
, sequence
);
2409 leni
= XFASTINT (len
);
2411 SAFE_ALLOCA_LISP (args
, leni
);
2413 mapcar1 (leni
, args
, function
, sequence
);
2415 ret
= Flist (leni
, args
);
2421 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2422 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2423 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2424 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2425 (Lisp_Object function
, Lisp_Object sequence
)
2427 register EMACS_INT leni
;
2429 leni
= XFASTINT (Flength (sequence
));
2430 if (CHAR_TABLE_P (sequence
))
2431 wrong_type_argument (Qlistp
, sequence
);
2432 mapcar1 (leni
, 0, function
, sequence
);
2437 /* This is how C code calls `yes-or-no-p' and allows the user
2440 Anything that calls this function must protect from GC! */
2443 do_yes_or_no_p (Lisp_Object prompt
)
2445 return call1 (intern ("yes-or-no-p"), prompt
);
2448 /* Anything that calls this function must protect from GC! */
2450 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2451 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2452 PROMPT is the string to display to ask the question. It should end in
2453 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2455 The user must confirm the answer with RET, and can edit it until it
2458 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2459 is nil, and `use-dialog-box' is non-nil. */)
2460 (Lisp_Object prompt
)
2462 register Lisp_Object ans
;
2463 Lisp_Object args
[2];
2464 struct gcpro gcpro1
;
2466 CHECK_STRING (prompt
);
2469 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2470 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2474 Lisp_Object pane
, menu
, obj
;
2475 redisplay_preserve_echo_area (4);
2476 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2477 Fcons (Fcons (build_string ("No"), Qnil
),
2480 menu
= Fcons (prompt
, pane
);
2481 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2485 #endif /* HAVE_MENUS */
2488 args
[1] = build_string ("(yes or no) ");
2489 prompt
= Fconcat (2, args
);
2495 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2496 Qyes_or_no_p_history
, Qnil
,
2498 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2503 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2511 message ("Please answer yes or no.");
2512 Fsleep_for (make_number (2), Qnil
);
2516 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2517 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2519 Each of the three load averages is multiplied by 100, then converted
2522 When USE-FLOATS is non-nil, floats will be used instead of integers.
2523 These floats are not multiplied by 100.
2525 If the 5-minute or 15-minute load averages are not available, return a
2526 shortened list, containing only those averages which are available.
2528 An error is thrown if the load average can't be obtained. In some
2529 cases making it work would require Emacs being installed setuid or
2530 setgid so that it can read kernel information, and that usually isn't
2532 (Lisp_Object use_floats
)
2535 int loads
= getloadavg (load_ave
, 3);
2536 Lisp_Object ret
= Qnil
;
2539 error ("load-average not implemented for this operating system");
2543 Lisp_Object load
= (NILP (use_floats
)
2544 ? make_number (100.0 * load_ave
[loads
])
2545 : make_float (load_ave
[loads
]));
2546 ret
= Fcons (load
, ret
);
2552 static Lisp_Object Qsubfeatures
;
2554 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2555 doc
: /* Return t if FEATURE is present in this Emacs.
2557 Use this to conditionalize execution of lisp code based on the
2558 presence or absence of Emacs or environment extensions.
2559 Use `provide' to declare that a feature is available. This function
2560 looks at the value of the variable `features'. The optional argument
2561 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2562 (Lisp_Object feature
, Lisp_Object subfeature
)
2564 register Lisp_Object tem
;
2565 CHECK_SYMBOL (feature
);
2566 tem
= Fmemq (feature
, Vfeatures
);
2567 if (!NILP (tem
) && !NILP (subfeature
))
2568 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2569 return (NILP (tem
)) ? Qnil
: Qt
;
2572 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2573 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2574 The optional argument SUBFEATURES should be a list of symbols listing
2575 particular subfeatures supported in this version of FEATURE. */)
2576 (Lisp_Object feature
, Lisp_Object subfeatures
)
2578 register Lisp_Object tem
;
2579 CHECK_SYMBOL (feature
);
2580 CHECK_LIST (subfeatures
);
2581 if (!NILP (Vautoload_queue
))
2582 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2584 tem
= Fmemq (feature
, Vfeatures
);
2586 Vfeatures
= Fcons (feature
, Vfeatures
);
2587 if (!NILP (subfeatures
))
2588 Fput (feature
, Qsubfeatures
, subfeatures
);
2589 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2591 /* Run any load-hooks for this file. */
2592 tem
= Fassq (feature
, Vafter_load_alist
);
2594 Fprogn (XCDR (tem
));
2599 /* `require' and its subroutines. */
2601 /* List of features currently being require'd, innermost first. */
2603 static Lisp_Object require_nesting_list
;
2606 require_unwind (Lisp_Object old_value
)
2608 return require_nesting_list
= old_value
;
2611 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2612 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2613 If FEATURE is not a member of the list `features', then the feature
2614 is not loaded; so load the file FILENAME.
2615 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2616 and `load' will try to load this name appended with the suffix `.elc' or
2617 `.el', in that order. The name without appended suffix will not be used.
2618 If the optional third argument NOERROR is non-nil,
2619 then return nil if the file is not found instead of signaling an error.
2620 Normally the return value is FEATURE.
2621 The normal messages at start and end of loading FILENAME are suppressed. */)
2622 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2624 register Lisp_Object tem
;
2625 struct gcpro gcpro1
, gcpro2
;
2626 int from_file
= load_in_progress
;
2628 CHECK_SYMBOL (feature
);
2630 /* Record the presence of `require' in this file
2631 even if the feature specified is already loaded.
2632 But not more than once in any file,
2633 and not when we aren't loading or reading from a file. */
2635 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2636 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2641 tem
= Fcons (Qrequire
, feature
);
2642 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2643 LOADHIST_ATTACH (tem
);
2645 tem
= Fmemq (feature
, Vfeatures
);
2649 int count
= SPECPDL_INDEX ();
2652 /* This is to make sure that loadup.el gives a clear picture
2653 of what files are preloaded and when. */
2654 if (! NILP (Vpurify_flag
))
2655 error ("(require %s) while preparing to dump",
2656 SDATA (SYMBOL_NAME (feature
)));
2658 /* A certain amount of recursive `require' is legitimate,
2659 but if we require the same feature recursively 3 times,
2661 tem
= require_nesting_list
;
2662 while (! NILP (tem
))
2664 if (! NILP (Fequal (feature
, XCAR (tem
))))
2669 error ("Recursive `require' for feature `%s'",
2670 SDATA (SYMBOL_NAME (feature
)));
2672 /* Update the list for any nested `require's that occur. */
2673 record_unwind_protect (require_unwind
, require_nesting_list
);
2674 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2676 /* Value saved here is to be restored into Vautoload_queue */
2677 record_unwind_protect (un_autoload
, Vautoload_queue
);
2678 Vautoload_queue
= Qt
;
2680 /* Load the file. */
2681 GCPRO2 (feature
, filename
);
2682 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2683 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2686 /* If load failed entirely, return nil. */
2688 return unbind_to (count
, Qnil
);
2690 tem
= Fmemq (feature
, Vfeatures
);
2692 error ("Required feature `%s' was not provided",
2693 SDATA (SYMBOL_NAME (feature
)));
2695 /* Once loading finishes, don't undo it. */
2696 Vautoload_queue
= Qt
;
2697 feature
= unbind_to (count
, feature
);
2703 /* Primitives for work of the "widget" library.
2704 In an ideal world, this section would not have been necessary.
2705 However, lisp function calls being as slow as they are, it turns
2706 out that some functions in the widget library (wid-edit.el) are the
2707 bottleneck of Widget operation. Here is their translation to C,
2708 for the sole reason of efficiency. */
2710 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2711 doc
: /* Return non-nil if PLIST has the property PROP.
2712 PLIST is a property list, which is a list of the form
2713 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2714 Unlike `plist-get', this allows you to distinguish between a missing
2715 property and a property with the value nil.
2716 The value is actually the tail of PLIST whose car is PROP. */)
2717 (Lisp_Object plist
, Lisp_Object prop
)
2719 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2722 plist
= XCDR (plist
);
2723 plist
= CDR (plist
);
2728 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2729 doc
: /* In WIDGET, set PROPERTY to VALUE.
2730 The value can later be retrieved with `widget-get'. */)
2731 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2733 CHECK_CONS (widget
);
2734 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2738 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2739 doc
: /* In WIDGET, get the value of PROPERTY.
2740 The value could either be specified when the widget was created, or
2741 later with `widget-put'. */)
2742 (Lisp_Object widget
, Lisp_Object property
)
2750 CHECK_CONS (widget
);
2751 tmp
= Fplist_member (XCDR (widget
), property
);
2757 tmp
= XCAR (widget
);
2760 widget
= Fget (tmp
, Qwidget_type
);
2764 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2765 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2766 ARGS are passed as extra arguments to the function.
2767 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2768 (ptrdiff_t nargs
, Lisp_Object
*args
)
2770 /* This function can GC. */
2771 Lisp_Object newargs
[3];
2772 struct gcpro gcpro1
, gcpro2
;
2775 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2776 newargs
[1] = args
[0];
2777 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2778 GCPRO2 (newargs
[0], newargs
[2]);
2779 result
= Fapply (3, newargs
);
2784 #ifdef HAVE_LANGINFO_CODESET
2785 #include <langinfo.h>
2788 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2789 doc
: /* Access locale data ITEM for the current C locale, if available.
2790 ITEM should be one of the following:
2792 `codeset', returning the character set as a string (locale item CODESET);
2794 `days', returning a 7-element vector of day names (locale items DAY_n);
2796 `months', returning a 12-element vector of month names (locale items MON_n);
2798 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2799 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2801 If the system can't provide such information through a call to
2802 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2804 See also Info node `(libc)Locales'.
2806 The data read from the system are decoded using `locale-coding-system'. */)
2810 #ifdef HAVE_LANGINFO_CODESET
2812 if (EQ (item
, Qcodeset
))
2814 str
= nl_langinfo (CODESET
);
2815 return build_string (str
);
2818 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2820 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2821 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2823 struct gcpro gcpro1
;
2825 synchronize_system_time_locale ();
2826 for (i
= 0; i
< 7; i
++)
2828 str
= nl_langinfo (days
[i
]);
2829 val
= make_unibyte_string (str
, strlen (str
));
2830 /* Fixme: Is this coding system necessarily right, even if
2831 it is consistent with CODESET? If not, what to do? */
2832 Faset (v
, make_number (i
),
2833 code_convert_string_norecord (val
, Vlocale_coding_system
,
2841 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2843 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2844 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2845 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2847 struct gcpro gcpro1
;
2849 synchronize_system_time_locale ();
2850 for (i
= 0; i
< 12; i
++)
2852 str
= nl_langinfo (months
[i
]);
2853 val
= make_unibyte_string (str
, strlen (str
));
2854 Faset (v
, make_number (i
),
2855 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2861 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2862 but is in the locale files. This could be used by ps-print. */
2864 else if (EQ (item
, Qpaper
))
2866 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2867 make_number (nl_langinfo (PAPER_HEIGHT
)));
2869 #endif /* PAPER_WIDTH */
2870 #endif /* HAVE_LANGINFO_CODESET*/
2874 /* base64 encode/decode functions (RFC 2045).
2875 Based on code from GNU recode. */
2877 #define MIME_LINE_LENGTH 76
2879 #define IS_ASCII(Character) \
2881 #define IS_BASE64(Character) \
2882 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2883 #define IS_BASE64_IGNORABLE(Character) \
2884 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2885 || (Character) == '\f' || (Character) == '\r')
2887 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2888 character or return retval if there are no characters left to
2890 #define READ_QUADRUPLET_BYTE(retval) \
2895 if (nchars_return) \
2896 *nchars_return = nchars; \
2901 while (IS_BASE64_IGNORABLE (c))
2903 /* Table of characters coding the 64 values. */
2904 static const char base64_value_to_char
[64] =
2906 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2907 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2908 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2909 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2910 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2911 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2912 '8', '9', '+', '/' /* 60-63 */
2915 /* Table of base64 values for first 128 characters. */
2916 static const short base64_char_to_value
[128] =
2918 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2920 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2921 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2922 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2923 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2924 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2925 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2926 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2927 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2928 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2929 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2930 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2933 /* The following diagram shows the logical steps by which three octets
2934 get transformed into four base64 characters.
2936 .--------. .--------. .--------.
2937 |aaaaaabb| |bbbbcccc| |ccdddddd|
2938 `--------' `--------' `--------'
2940 .--------+--------+--------+--------.
2941 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2942 `--------+--------+--------+--------'
2944 .--------+--------+--------+--------.
2945 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2946 `--------+--------+--------+--------'
2948 The octets are divided into 6 bit chunks, which are then encoded into
2949 base64 characters. */
2952 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2953 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2956 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2958 doc
: /* Base64-encode the region between BEG and END.
2959 Return the length of the encoded text.
2960 Optional third argument NO-LINE-BREAK means do not break long lines
2961 into shorter lines. */)
2962 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2965 EMACS_INT allength
, length
;
2966 EMACS_INT ibeg
, iend
, encoded_length
;
2967 EMACS_INT old_pos
= PT
;
2970 validate_region (&beg
, &end
);
2972 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2973 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2974 move_gap_both (XFASTINT (beg
), ibeg
);
2976 /* We need to allocate enough room for encoding the text.
2977 We need 33 1/3% more space, plus a newline every 76
2978 characters, and then we round up. */
2979 length
= iend
- ibeg
;
2980 allength
= length
+ length
/3 + 1;
2981 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2983 SAFE_ALLOCA (encoded
, char *, allength
);
2984 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2985 encoded
, length
, NILP (no_line_break
),
2986 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2987 if (encoded_length
> allength
)
2990 if (encoded_length
< 0)
2992 /* The encoding wasn't possible. */
2994 error ("Multibyte character in data for base64 encoding");
2997 /* Now we have encoded the region, so we insert the new contents
2998 and delete the old. (Insert first in order to preserve markers.) */
2999 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3000 insert (encoded
, encoded_length
);
3002 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3004 /* If point was outside of the region, restore it exactly; else just
3005 move to the beginning of the region. */
3006 if (old_pos
>= XFASTINT (end
))
3007 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3008 else if (old_pos
> XFASTINT (beg
))
3009 old_pos
= XFASTINT (beg
);
3012 /* We return the length of the encoded text. */
3013 return make_number (encoded_length
);
3016 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3018 doc
: /* Base64-encode STRING and return the result.
3019 Optional second argument NO-LINE-BREAK means do not break long lines
3020 into shorter lines. */)
3021 (Lisp_Object string
, Lisp_Object no_line_break
)
3023 EMACS_INT allength
, length
, encoded_length
;
3025 Lisp_Object encoded_string
;
3028 CHECK_STRING (string
);
3030 /* We need to allocate enough room for encoding the text.
3031 We need 33 1/3% more space, plus a newline every 76
3032 characters, and then we round up. */
3033 length
= SBYTES (string
);
3034 allength
= length
+ length
/3 + 1;
3035 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3037 /* We need to allocate enough room for decoding the text. */
3038 SAFE_ALLOCA (encoded
, char *, allength
);
3040 encoded_length
= base64_encode_1 (SSDATA (string
),
3041 encoded
, length
, NILP (no_line_break
),
3042 STRING_MULTIBYTE (string
));
3043 if (encoded_length
> allength
)
3046 if (encoded_length
< 0)
3048 /* The encoding wasn't possible. */
3050 error ("Multibyte character in data for base64 encoding");
3053 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3056 return encoded_string
;
3060 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3061 int line_break
, int multibyte
)
3074 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3075 if (CHAR_BYTE8_P (c
))
3076 c
= CHAR_TO_BYTE8 (c
);
3084 /* Wrap line every 76 characters. */
3088 if (counter
< MIME_LINE_LENGTH
/ 4)
3097 /* Process first byte of a triplet. */
3099 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3100 value
= (0x03 & c
) << 4;
3102 /* Process second byte of a triplet. */
3106 *e
++ = base64_value_to_char
[value
];
3114 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3115 if (CHAR_BYTE8_P (c
))
3116 c
= CHAR_TO_BYTE8 (c
);
3124 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3125 value
= (0x0f & c
) << 2;
3127 /* Process third byte of a triplet. */
3131 *e
++ = base64_value_to_char
[value
];
3138 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3139 if (CHAR_BYTE8_P (c
))
3140 c
= CHAR_TO_BYTE8 (c
);
3148 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3149 *e
++ = base64_value_to_char
[0x3f & c
];
3156 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3158 doc
: /* Base64-decode the region between BEG and END.
3159 Return the length of the decoded text.
3160 If the region can't be decoded, signal an error and don't modify the buffer. */)
3161 (Lisp_Object beg
, Lisp_Object end
)
3163 EMACS_INT ibeg
, iend
, length
, allength
;
3165 EMACS_INT old_pos
= PT
;
3166 EMACS_INT decoded_length
;
3167 EMACS_INT inserted_chars
;
3168 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3171 validate_region (&beg
, &end
);
3173 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3174 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3176 length
= iend
- ibeg
;
3178 /* We need to allocate enough room for decoding the text. If we are
3179 working on a multibyte buffer, each decoded code may occupy at
3181 allength
= multibyte
? length
* 2 : length
;
3182 SAFE_ALLOCA (decoded
, char *, allength
);
3184 move_gap_both (XFASTINT (beg
), ibeg
);
3185 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3187 multibyte
, &inserted_chars
);
3188 if (decoded_length
> allength
)
3191 if (decoded_length
< 0)
3193 /* The decoding wasn't possible. */
3195 error ("Invalid base64 data");
3198 /* Now we have decoded the region, so we insert the new contents
3199 and delete the old. (Insert first in order to preserve markers.) */
3200 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3201 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3204 /* Delete the original text. */
3205 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3206 iend
+ decoded_length
, 1);
3208 /* If point was outside of the region, restore it exactly; else just
3209 move to the beginning of the region. */
3210 if (old_pos
>= XFASTINT (end
))
3211 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3212 else if (old_pos
> XFASTINT (beg
))
3213 old_pos
= XFASTINT (beg
);
3214 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3216 return make_number (inserted_chars
);
3219 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3221 doc
: /* Base64-decode STRING and return the result. */)
3222 (Lisp_Object string
)
3225 EMACS_INT length
, decoded_length
;
3226 Lisp_Object decoded_string
;
3229 CHECK_STRING (string
);
3231 length
= SBYTES (string
);
3232 /* We need to allocate enough room for decoding the text. */
3233 SAFE_ALLOCA (decoded
, char *, length
);
3235 /* The decoded result should be unibyte. */
3236 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3238 if (decoded_length
> length
)
3240 else if (decoded_length
>= 0)
3241 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3243 decoded_string
= Qnil
;
3246 if (!STRINGP (decoded_string
))
3247 error ("Invalid base64 data");
3249 return decoded_string
;
3252 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3253 MULTIBYTE is nonzero, the decoded result should be in multibyte
3254 form. If NCHARS_RETRUN is not NULL, store the number of produced
3255 characters in *NCHARS_RETURN. */
3258 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3259 int multibyte
, EMACS_INT
*nchars_return
)
3261 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3264 unsigned long value
;
3265 EMACS_INT nchars
= 0;
3269 /* Process first byte of a quadruplet. */
3271 READ_QUADRUPLET_BYTE (e
-to
);
3275 value
= base64_char_to_value
[c
] << 18;
3277 /* Process second byte of a quadruplet. */
3279 READ_QUADRUPLET_BYTE (-1);
3283 value
|= base64_char_to_value
[c
] << 12;
3285 c
= (unsigned char) (value
>> 16);
3286 if (multibyte
&& c
>= 128)
3287 e
+= BYTE8_STRING (c
, e
);
3292 /* Process third byte of a quadruplet. */
3294 READ_QUADRUPLET_BYTE (-1);
3298 READ_QUADRUPLET_BYTE (-1);
3307 value
|= base64_char_to_value
[c
] << 6;
3309 c
= (unsigned char) (0xff & value
>> 8);
3310 if (multibyte
&& c
>= 128)
3311 e
+= BYTE8_STRING (c
, e
);
3316 /* Process fourth byte of a quadruplet. */
3318 READ_QUADRUPLET_BYTE (-1);
3325 value
|= base64_char_to_value
[c
];
3327 c
= (unsigned char) (0xff & value
);
3328 if (multibyte
&& c
>= 128)
3329 e
+= BYTE8_STRING (c
, e
);
3338 /***********************************************************************
3340 ***** Hash Tables *****
3342 ***********************************************************************/
3344 /* Implemented by gerd@gnu.org. This hash table implementation was
3345 inspired by CMUCL hash tables. */
3349 1. For small tables, association lists are probably faster than
3350 hash tables because they have lower overhead.
3352 For uses of hash tables where the O(1) behavior of table
3353 operations is not a requirement, it might therefore be a good idea
3354 not to hash. Instead, we could just do a linear search in the
3355 key_and_value vector of the hash table. This could be done
3356 if a `:linear-search t' argument is given to make-hash-table. */
3359 /* The list of all weak hash tables. Don't staticpro this one. */
3361 static struct Lisp_Hash_Table
*weak_hash_tables
;
3363 /* Various symbols. */
3365 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3366 Lisp_Object Qeq
, Qeql
, Qequal
;
3367 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3368 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3370 /* Function prototypes. */
3372 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3373 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3374 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3375 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3379 /***********************************************************************
3381 ***********************************************************************/
3383 /* If OBJ is a Lisp hash table, return a pointer to its struct
3384 Lisp_Hash_Table. Otherwise, signal an error. */
3386 static struct Lisp_Hash_Table
*
3387 check_hash_table (Lisp_Object obj
)
3389 CHECK_HASH_TABLE (obj
);
3390 return XHASH_TABLE (obj
);
3394 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3398 next_almost_prime (EMACS_INT n
)
3400 for (n
|= 1; ; n
+= 2)
3401 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3406 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3407 which USED[I] is non-zero. If found at index I in ARGS, set
3408 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3409 0. This function is used to extract a keyword/argument pair from
3410 a DEFUN parameter list. */
3413 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3417 for (i
= 1; i
< nargs
; i
++)
3418 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3429 /* Return a Lisp vector which has the same contents as VEC but has
3430 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3431 vector that are not copied from VEC are set to INIT. */
3434 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3436 struct Lisp_Vector
*v
;
3437 EMACS_INT i
, old_size
;
3439 xassert (VECTORP (vec
));
3440 old_size
= ASIZE (vec
);
3441 xassert (new_size
>= old_size
);
3443 v
= allocate_vector (new_size
);
3444 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3445 for (i
= old_size
; i
< new_size
; ++i
)
3446 v
->contents
[i
] = init
;
3447 XSETVECTOR (vec
, v
);
3452 /***********************************************************************
3454 ***********************************************************************/
3456 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3457 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3458 KEY2 are the same. */
3461 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3462 Lisp_Object key1
, EMACS_UINT hash1
,
3463 Lisp_Object key2
, EMACS_UINT hash2
)
3465 return (FLOATP (key1
)
3467 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3471 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3472 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3473 KEY2 are the same. */
3476 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3477 Lisp_Object key1
, EMACS_UINT hash1
,
3478 Lisp_Object key2
, EMACS_UINT hash2
)
3480 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3484 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3485 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3486 if KEY1 and KEY2 are the same. */
3489 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3490 Lisp_Object key1
, EMACS_UINT hash1
,
3491 Lisp_Object key2
, EMACS_UINT hash2
)
3495 Lisp_Object args
[3];
3497 args
[0] = h
->user_cmp_function
;
3500 return !NILP (Ffuncall (3, args
));
3507 /* Value is a hash code for KEY for use in hash table H which uses
3508 `eq' to compare keys. The hash code returned is guaranteed to fit
3509 in a Lisp integer. */
3512 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3514 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3515 xassert ((hash
& ~INTMASK
) == 0);
3520 /* Value is a hash code for KEY for use in hash table H which uses
3521 `eql' to compare keys. The hash code returned is guaranteed to fit
3522 in a Lisp integer. */
3525 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3529 hash
= sxhash (key
, 0);
3531 hash
= XUINT (key
) ^ XTYPE (key
);
3532 xassert ((hash
& ~INTMASK
) == 0);
3537 /* Value is a hash code for KEY for use in hash table H which uses
3538 `equal' to compare keys. The hash code returned is guaranteed to fit
3539 in a Lisp integer. */
3542 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3544 EMACS_UINT hash
= sxhash (key
, 0);
3545 xassert ((hash
& ~INTMASK
) == 0);
3550 /* Value is a hash code for KEY for use in hash table H which uses as
3551 user-defined function to compare keys. The hash code returned is
3552 guaranteed to fit in a Lisp integer. */
3555 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3557 Lisp_Object args
[2], hash
;
3559 args
[0] = h
->user_hash_function
;
3561 hash
= Ffuncall (2, args
);
3562 if (!INTEGERP (hash
))
3563 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3564 return XUINT (hash
);
3568 /* Create and initialize a new hash table.
3570 TEST specifies the test the hash table will use to compare keys.
3571 It must be either one of the predefined tests `eq', `eql' or
3572 `equal' or a symbol denoting a user-defined test named TEST with
3573 test and hash functions USER_TEST and USER_HASH.
3575 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3577 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3578 new size when it becomes full is computed by adding REHASH_SIZE to
3579 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3580 table's new size is computed by multiplying its old size with
3583 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3584 be resized when the ratio of (number of entries in the table) /
3585 (table size) is >= REHASH_THRESHOLD.
3587 WEAK specifies the weakness of the table. If non-nil, it must be
3588 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3591 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3592 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3593 Lisp_Object user_test
, Lisp_Object user_hash
)
3595 struct Lisp_Hash_Table
*h
;
3597 EMACS_INT index_size
, i
, sz
;
3600 /* Preconditions. */
3601 xassert (SYMBOLP (test
));
3602 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3603 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3604 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3605 xassert (FLOATP (rehash_threshold
)
3606 && 0 < XFLOAT_DATA (rehash_threshold
)
3607 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3609 if (XFASTINT (size
) == 0)
3610 size
= make_number (1);
3612 sz
= XFASTINT (size
);
3613 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3614 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3615 ? next_almost_prime (index_float
)
3616 : MOST_POSITIVE_FIXNUM
+ 1);
3617 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3618 error ("Hash table too large");
3620 /* Allocate a table and initialize it. */
3621 h
= allocate_hash_table ();
3623 /* Initialize hash table slots. */
3625 if (EQ (test
, Qeql
))
3627 h
->cmpfn
= cmpfn_eql
;
3628 h
->hashfn
= hashfn_eql
;
3630 else if (EQ (test
, Qeq
))
3633 h
->hashfn
= hashfn_eq
;
3635 else if (EQ (test
, Qequal
))
3637 h
->cmpfn
= cmpfn_equal
;
3638 h
->hashfn
= hashfn_equal
;
3642 h
->user_cmp_function
= user_test
;
3643 h
->user_hash_function
= user_hash
;
3644 h
->cmpfn
= cmpfn_user_defined
;
3645 h
->hashfn
= hashfn_user_defined
;
3649 h
->rehash_threshold
= rehash_threshold
;
3650 h
->rehash_size
= rehash_size
;
3652 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3653 h
->hash
= Fmake_vector (size
, Qnil
);
3654 h
->next
= Fmake_vector (size
, Qnil
);
3655 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3657 /* Set up the free list. */
3658 for (i
= 0; i
< sz
- 1; ++i
)
3659 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3660 h
->next_free
= make_number (0);
3662 XSET_HASH_TABLE (table
, h
);
3663 xassert (HASH_TABLE_P (table
));
3664 xassert (XHASH_TABLE (table
) == h
);
3666 /* Maybe add this hash table to the list of all weak hash tables. */
3668 h
->next_weak
= NULL
;
3671 h
->next_weak
= weak_hash_tables
;
3672 weak_hash_tables
= h
;
3679 /* Return a copy of hash table H1. Keys and values are not copied,
3680 only the table itself is. */
3683 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3686 struct Lisp_Hash_Table
*h2
;
3687 struct Lisp_Vector
*next
;
3689 h2
= allocate_hash_table ();
3690 next
= h2
->header
.next
.vector
;
3691 memcpy (h2
, h1
, sizeof *h2
);
3692 h2
->header
.next
.vector
= next
;
3693 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3694 h2
->hash
= Fcopy_sequence (h1
->hash
);
3695 h2
->next
= Fcopy_sequence (h1
->next
);
3696 h2
->index
= Fcopy_sequence (h1
->index
);
3697 XSET_HASH_TABLE (table
, h2
);
3699 /* Maybe add this hash table to the list of all weak hash tables. */
3700 if (!NILP (h2
->weak
))
3702 h2
->next_weak
= weak_hash_tables
;
3703 weak_hash_tables
= h2
;
3710 /* Resize hash table H if it's too full. If H cannot be resized
3711 because it's already too large, throw an error. */
3714 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3716 if (NILP (h
->next_free
))
3718 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3719 EMACS_INT i
, new_size
, index_size
;
3723 if (INTEGERP (h
->rehash_size
))
3724 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3727 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3728 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3730 new_size
= float_new_size
;
3731 if (new_size
<= old_size
)
3732 new_size
= old_size
+ 1;
3735 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3737 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3738 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3739 ? next_almost_prime (index_float
)
3740 : MOST_POSITIVE_FIXNUM
+ 1);
3741 nsize
= max (index_size
, 2 * new_size
);
3742 if (nsize
> MOST_POSITIVE_FIXNUM
)
3743 error ("Hash table too large to resize");
3745 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3746 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3747 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3748 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3750 /* Update the free list. Do it so that new entries are added at
3751 the end of the free list. This makes some operations like
3753 for (i
= old_size
; i
< new_size
- 1; ++i
)
3754 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3756 if (!NILP (h
->next_free
))
3758 Lisp_Object last
, next
;
3760 last
= h
->next_free
;
3761 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3765 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3768 XSETFASTINT (h
->next_free
, old_size
);
3771 for (i
= 0; i
< old_size
; ++i
)
3772 if (!NILP (HASH_HASH (h
, i
)))
3774 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3775 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3776 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3777 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3783 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3784 the hash code of KEY. Value is the index of the entry in H
3785 matching KEY, or -1 if not found. */
3788 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3790 EMACS_UINT hash_code
;
3791 EMACS_INT start_of_bucket
;
3794 hash_code
= h
->hashfn (h
, key
);
3798 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3799 idx
= HASH_INDEX (h
, start_of_bucket
);
3801 /* We need not gcpro idx since it's either an integer or nil. */
3804 EMACS_INT i
= XFASTINT (idx
);
3805 if (EQ (key
, HASH_KEY (h
, i
))
3807 && h
->cmpfn (h
, key
, hash_code
,
3808 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3810 idx
= HASH_NEXT (h
, i
);
3813 return NILP (idx
) ? -1 : XFASTINT (idx
);
3817 /* Put an entry into hash table H that associates KEY with VALUE.
3818 HASH is a previously computed hash code of KEY.
3819 Value is the index of the entry in H matching KEY. */
3822 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3825 EMACS_INT start_of_bucket
, i
;
3827 xassert ((hash
& ~INTMASK
) == 0);
3829 /* Increment count after resizing because resizing may fail. */
3830 maybe_resize_hash_table (h
);
3833 /* Store key/value in the key_and_value vector. */
3834 i
= XFASTINT (h
->next_free
);
3835 h
->next_free
= HASH_NEXT (h
, i
);
3836 HASH_KEY (h
, i
) = key
;
3837 HASH_VALUE (h
, i
) = value
;
3839 /* Remember its hash code. */
3840 HASH_HASH (h
, i
) = make_number (hash
);
3842 /* Add new entry to its collision chain. */
3843 start_of_bucket
= hash
% ASIZE (h
->index
);
3844 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3845 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3850 /* Remove the entry matching KEY from hash table H, if there is one. */
3853 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3855 EMACS_UINT hash_code
;
3856 EMACS_INT start_of_bucket
;
3857 Lisp_Object idx
, prev
;
3859 hash_code
= h
->hashfn (h
, key
);
3860 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3861 idx
= HASH_INDEX (h
, start_of_bucket
);
3864 /* We need not gcpro idx, prev since they're either integers or nil. */
3867 EMACS_INT i
= XFASTINT (idx
);
3869 if (EQ (key
, HASH_KEY (h
, i
))
3871 && h
->cmpfn (h
, key
, hash_code
,
3872 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3874 /* Take entry out of collision chain. */
3876 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3878 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3880 /* Clear slots in key_and_value and add the slots to
3882 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3883 HASH_NEXT (h
, i
) = h
->next_free
;
3884 h
->next_free
= make_number (i
);
3886 xassert (h
->count
>= 0);
3892 idx
= HASH_NEXT (h
, i
);
3898 /* Clear hash table H. */
3901 hash_clear (struct Lisp_Hash_Table
*h
)
3905 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3907 for (i
= 0; i
< size
; ++i
)
3909 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3910 HASH_KEY (h
, i
) = Qnil
;
3911 HASH_VALUE (h
, i
) = Qnil
;
3912 HASH_HASH (h
, i
) = Qnil
;
3915 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3916 ASET (h
->index
, i
, Qnil
);
3918 h
->next_free
= make_number (0);
3925 /************************************************************************
3927 ************************************************************************/
3930 init_weak_hash_tables (void)
3932 weak_hash_tables
= NULL
;
3935 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3936 entries from the table that don't survive the current GC.
3937 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3938 non-zero if anything was marked. */
3941 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3943 EMACS_INT bucket
, n
;
3946 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3949 for (bucket
= 0; bucket
< n
; ++bucket
)
3951 Lisp_Object idx
, next
, prev
;
3953 /* Follow collision chain, removing entries that
3954 don't survive this garbage collection. */
3956 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3958 EMACS_INT i
= XFASTINT (idx
);
3959 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3960 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3963 if (EQ (h
->weak
, Qkey
))
3964 remove_p
= !key_known_to_survive_p
;
3965 else if (EQ (h
->weak
, Qvalue
))
3966 remove_p
= !value_known_to_survive_p
;
3967 else if (EQ (h
->weak
, Qkey_or_value
))
3968 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3969 else if (EQ (h
->weak
, Qkey_and_value
))
3970 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3974 next
= HASH_NEXT (h
, i
);
3976 if (remove_entries_p
)
3980 /* Take out of collision chain. */
3982 HASH_INDEX (h
, bucket
) = next
;
3984 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3986 /* Add to free list. */
3987 HASH_NEXT (h
, i
) = h
->next_free
;
3990 /* Clear key, value, and hash. */
3991 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3992 HASH_HASH (h
, i
) = Qnil
;
4005 /* Make sure key and value survive. */
4006 if (!key_known_to_survive_p
)
4008 mark_object (HASH_KEY (h
, i
));
4012 if (!value_known_to_survive_p
)
4014 mark_object (HASH_VALUE (h
, i
));
4025 /* Remove elements from weak hash tables that don't survive the
4026 current garbage collection. Remove weak tables that don't survive
4027 from Vweak_hash_tables. Called from gc_sweep. */
4030 sweep_weak_hash_tables (void)
4032 struct Lisp_Hash_Table
*h
, *used
, *next
;
4035 /* Mark all keys and values that are in use. Keep on marking until
4036 there is no more change. This is necessary for cases like
4037 value-weak table A containing an entry X -> Y, where Y is used in a
4038 key-weak table B, Z -> Y. If B comes after A in the list of weak
4039 tables, X -> Y might be removed from A, although when looking at B
4040 one finds that it shouldn't. */
4044 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4046 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4047 marked
|= sweep_weak_table (h
, 0);
4052 /* Remove tables and entries that aren't used. */
4053 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4055 next
= h
->next_weak
;
4057 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4059 /* TABLE is marked as used. Sweep its contents. */
4061 sweep_weak_table (h
, 1);
4063 /* Add table to the list of used weak hash tables. */
4064 h
->next_weak
= used
;
4069 weak_hash_tables
= used
;
4074 /***********************************************************************
4075 Hash Code Computation
4076 ***********************************************************************/
4078 /* Maximum depth up to which to dive into Lisp structures. */
4080 #define SXHASH_MAX_DEPTH 3
4082 /* Maximum length up to which to take list and vector elements into
4085 #define SXHASH_MAX_LEN 7
4087 /* Combine two integers X and Y for hashing. The result might not fit
4088 into a Lisp integer. */
4090 #define SXHASH_COMBINE(X, Y) \
4091 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4094 /* Hash X, returning a value that fits into a Lisp integer. */
4095 #define SXHASH_REDUCE(X) \
4096 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4098 /* Return a hash for string PTR which has length LEN. The hash
4099 code returned is guaranteed to fit in a Lisp integer. */
4102 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4104 unsigned char *p
= ptr
;
4105 unsigned char *end
= p
+ len
;
4107 EMACS_UINT hash
= 0;
4114 hash
= SXHASH_COMBINE (hash
, c
);
4117 return SXHASH_REDUCE (hash
);
4120 /* Return a hash for the floating point value VAL. */
4123 sxhash_float (double val
)
4125 EMACS_UINT hash
= 0;
4127 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4128 + (sizeof val
% sizeof hash
!= 0))
4132 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4136 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4137 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4138 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4139 return SXHASH_REDUCE (hash
);
4142 /* Return a hash for list LIST. DEPTH is the current depth in the
4143 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4146 sxhash_list (Lisp_Object list
, int depth
)
4148 EMACS_UINT hash
= 0;
4151 if (depth
< SXHASH_MAX_DEPTH
)
4153 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4154 list
= XCDR (list
), ++i
)
4156 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4157 hash
= SXHASH_COMBINE (hash
, hash2
);
4162 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4163 hash
= SXHASH_COMBINE (hash
, hash2
);
4166 return SXHASH_REDUCE (hash
);
4170 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4171 the Lisp structure. */
4174 sxhash_vector (Lisp_Object vec
, int depth
)
4176 EMACS_UINT hash
= ASIZE (vec
);
4179 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4180 for (i
= 0; i
< n
; ++i
)
4182 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4183 hash
= SXHASH_COMBINE (hash
, hash2
);
4186 return SXHASH_REDUCE (hash
);
4189 /* Return a hash for bool-vector VECTOR. */
4192 sxhash_bool_vector (Lisp_Object vec
)
4194 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4197 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4198 for (i
= 0; i
< n
; ++i
)
4199 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4201 return SXHASH_REDUCE (hash
);
4205 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4206 structure. Value is an unsigned integer clipped to INTMASK. */
4209 sxhash (Lisp_Object obj
, int depth
)
4213 if (depth
> SXHASH_MAX_DEPTH
)
4216 switch (XTYPE (obj
))
4227 obj
= SYMBOL_NAME (obj
);
4231 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4234 /* This can be everything from a vector to an overlay. */
4235 case Lisp_Vectorlike
:
4237 /* According to the CL HyperSpec, two arrays are equal only if
4238 they are `eq', except for strings and bit-vectors. In
4239 Emacs, this works differently. We have to compare element
4241 hash
= sxhash_vector (obj
, depth
);
4242 else if (BOOL_VECTOR_P (obj
))
4243 hash
= sxhash_bool_vector (obj
);
4245 /* Others are `equal' if they are `eq', so let's take their
4251 hash
= sxhash_list (obj
, depth
);
4255 hash
= sxhash_float (XFLOAT_DATA (obj
));
4267 /***********************************************************************
4269 ***********************************************************************/
4272 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4273 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4276 EMACS_UINT hash
= sxhash (obj
, 0);
4277 return make_number (hash
);
4281 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4282 doc
: /* Create and return a new hash table.
4284 Arguments are specified as keyword/argument pairs. The following
4285 arguments are defined:
4287 :test TEST -- TEST must be a symbol that specifies how to compare
4288 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4289 `equal'. User-supplied test and hash functions can be specified via
4290 `define-hash-table-test'.
4292 :size SIZE -- A hint as to how many elements will be put in the table.
4295 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4296 fills up. If REHASH-SIZE is an integer, increase the size by that
4297 amount. If it is a float, it must be > 1.0, and the new size is the
4298 old size multiplied by that factor. Default is 1.5.
4300 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4301 Resize the hash table when the ratio (number of entries / table size)
4302 is greater than or equal to THRESHOLD. Default is 0.8.
4304 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4305 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4306 returned is a weak table. Key/value pairs are removed from a weak
4307 hash table when there are no non-weak references pointing to their
4308 key, value, one of key or value, or both key and value, depending on
4309 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4312 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4313 (ptrdiff_t nargs
, Lisp_Object
*args
)
4315 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4316 Lisp_Object user_test
, user_hash
;
4320 /* The vector `used' is used to keep track of arguments that
4321 have been consumed. */
4322 used
= (char *) alloca (nargs
* sizeof *used
);
4323 memset (used
, 0, nargs
* sizeof *used
);
4325 /* See if there's a `:test TEST' among the arguments. */
4326 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4327 test
= i
? args
[i
] : Qeql
;
4328 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4330 /* See if it is a user-defined test. */
4333 prop
= Fget (test
, Qhash_table_test
);
4334 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4335 signal_error ("Invalid hash table test", test
);
4336 user_test
= XCAR (prop
);
4337 user_hash
= XCAR (XCDR (prop
));
4340 user_test
= user_hash
= Qnil
;
4342 /* See if there's a `:size SIZE' argument. */
4343 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4344 size
= i
? args
[i
] : Qnil
;
4346 size
= make_number (DEFAULT_HASH_SIZE
);
4347 else if (!INTEGERP (size
) || XINT (size
) < 0)
4348 signal_error ("Invalid hash table size", size
);
4350 /* Look for `:rehash-size SIZE'. */
4351 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4352 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4353 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4354 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4355 signal_error ("Invalid hash table rehash size", rehash_size
);
4357 /* Look for `:rehash-threshold THRESHOLD'. */
4358 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4359 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4360 if (! (FLOATP (rehash_threshold
)
4361 && 0 < XFLOAT_DATA (rehash_threshold
)
4362 && XFLOAT_DATA (rehash_threshold
) <= 1))
4363 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4365 /* Look for `:weakness WEAK'. */
4366 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4367 weak
= i
? args
[i
] : Qnil
;
4369 weak
= Qkey_and_value
;
4372 && !EQ (weak
, Qvalue
)
4373 && !EQ (weak
, Qkey_or_value
)
4374 && !EQ (weak
, Qkey_and_value
))
4375 signal_error ("Invalid hash table weakness", weak
);
4377 /* Now, all args should have been used up, or there's a problem. */
4378 for (i
= 0; i
< nargs
; ++i
)
4380 signal_error ("Invalid argument list", args
[i
]);
4382 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4383 user_test
, user_hash
);
4387 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4388 doc
: /* Return a copy of hash table TABLE. */)
4391 return copy_hash_table (check_hash_table (table
));
4395 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4396 doc
: /* Return the number of elements in TABLE. */)
4399 return make_number (check_hash_table (table
)->count
);
4403 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4404 Shash_table_rehash_size
, 1, 1, 0,
4405 doc
: /* Return the current rehash size of TABLE. */)
4408 return check_hash_table (table
)->rehash_size
;
4412 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4413 Shash_table_rehash_threshold
, 1, 1, 0,
4414 doc
: /* Return the current rehash threshold of TABLE. */)
4417 return check_hash_table (table
)->rehash_threshold
;
4421 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4422 doc
: /* Return the size of TABLE.
4423 The size can be used as an argument to `make-hash-table' to create
4424 a hash table than can hold as many elements as TABLE holds
4425 without need for resizing. */)
4428 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4429 return make_number (HASH_TABLE_SIZE (h
));
4433 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4434 doc
: /* Return the test TABLE uses. */)
4437 return check_hash_table (table
)->test
;
4441 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4443 doc
: /* Return the weakness of TABLE. */)
4446 return check_hash_table (table
)->weak
;
4450 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4451 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4454 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4458 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4459 doc
: /* Clear hash table TABLE and return it. */)
4462 hash_clear (check_hash_table (table
));
4463 /* Be compatible with XEmacs. */
4468 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4469 doc
: /* Look up KEY in TABLE and return its associated value.
4470 If KEY is not found, return DFLT which defaults to nil. */)
4471 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4473 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4474 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4475 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4479 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4480 doc
: /* Associate KEY with VALUE in hash table TABLE.
4481 If KEY is already present in table, replace its current value with
4482 VALUE. In any case, return VALUE. */)
4483 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4485 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4489 i
= hash_lookup (h
, key
, &hash
);
4491 HASH_VALUE (h
, i
) = value
;
4493 hash_put (h
, key
, value
, hash
);
4499 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4500 doc
: /* Remove KEY from TABLE. */)
4501 (Lisp_Object key
, Lisp_Object table
)
4503 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4504 hash_remove_from_table (h
, key
);
4509 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4510 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4511 FUNCTION is called with two arguments, KEY and VALUE. */)
4512 (Lisp_Object function
, Lisp_Object table
)
4514 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4515 Lisp_Object args
[3];
4518 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4519 if (!NILP (HASH_HASH (h
, i
)))
4522 args
[1] = HASH_KEY (h
, i
);
4523 args
[2] = HASH_VALUE (h
, i
);
4531 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4532 Sdefine_hash_table_test
, 3, 3, 0,
4533 doc
: /* Define a new hash table test with name NAME, a symbol.
4535 In hash tables created with NAME specified as test, use TEST to
4536 compare keys, and HASH for computing hash codes of keys.
4538 TEST must be a function taking two arguments and returning non-nil if
4539 both arguments are the same. HASH must be a function taking one
4540 argument and return an integer that is the hash code of the argument.
4541 Hash code computation should use the whole value range of integers,
4542 including negative integers. */)
4543 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4545 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4550 /************************************************************************
4552 ************************************************************************/
4557 /* Convert a possibly-signed character to an unsigned character. This is
4558 a bit safer than casting to unsigned char, since it catches some type
4559 errors that the cast doesn't. */
4560 static inline unsigned char to_uchar (char ch
) { return ch
; }
4562 /* TYPE: 0 for md5, 1 for sha1. */
4565 crypto_hash_function (int type
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4569 EMACS_INT size_byte
= 0;
4570 EMACS_INT start_char
= 0, end_char
= 0;
4571 EMACS_INT start_byte
= 0, end_byte
= 0;
4572 register EMACS_INT b
, e
;
4573 register struct buffer
*bp
;
4575 Lisp_Object res
=Qnil
;
4577 if (STRINGP (object
))
4579 if (NILP (coding_system
))
4581 /* Decide the coding-system to encode the data with. */
4583 if (STRING_MULTIBYTE (object
))
4584 /* use default, we can't guess correct value */
4585 coding_system
= preferred_coding_system ();
4587 coding_system
= Qraw_text
;
4590 if (NILP (Fcoding_system_p (coding_system
)))
4592 /* Invalid coding system. */
4594 if (!NILP (noerror
))
4595 coding_system
= Qraw_text
;
4597 xsignal1 (Qcoding_system_error
, coding_system
);
4600 if (STRING_MULTIBYTE (object
))
4601 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4603 size
= SCHARS (object
);
4604 size_byte
= SBYTES (object
);
4608 CHECK_NUMBER (start
);
4610 start_char
= XINT (start
);
4615 start_byte
= string_char_to_byte (object
, start_char
);
4621 end_byte
= size_byte
;
4627 end_char
= XINT (end
);
4632 end_byte
= string_char_to_byte (object
, end_char
);
4635 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4636 args_out_of_range_3 (object
, make_number (start_char
),
4637 make_number (end_char
));
4641 struct buffer
*prev
= current_buffer
;
4643 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4645 CHECK_BUFFER (object
);
4647 bp
= XBUFFER (object
);
4648 if (bp
!= current_buffer
)
4649 set_buffer_internal (bp
);
4655 CHECK_NUMBER_COERCE_MARKER (start
);
4663 CHECK_NUMBER_COERCE_MARKER (end
);
4668 temp
= b
, b
= e
, e
= temp
;
4670 if (!(BEGV
<= b
&& e
<= ZV
))
4671 args_out_of_range (start
, end
);
4673 if (NILP (coding_system
))
4675 /* Decide the coding-system to encode the data with.
4676 See fileio.c:Fwrite-region */
4678 if (!NILP (Vcoding_system_for_write
))
4679 coding_system
= Vcoding_system_for_write
;
4682 int force_raw_text
= 0;
4684 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4685 if (NILP (coding_system
)
4686 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4688 coding_system
= Qnil
;
4689 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4693 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4695 /* Check file-coding-system-alist. */
4696 Lisp_Object args
[4], val
;
4698 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4699 args
[3] = Fbuffer_file_name(object
);
4700 val
= Ffind_operation_coding_system (4, args
);
4701 if (CONSP (val
) && !NILP (XCDR (val
)))
4702 coding_system
= XCDR (val
);
4705 if (NILP (coding_system
)
4706 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4708 /* If we still have not decided a coding system, use the
4709 default value of buffer-file-coding-system. */
4710 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4714 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4715 /* Confirm that VAL can surely encode the current region. */
4716 coding_system
= call4 (Vselect_safe_coding_system_function
,
4717 make_number (b
), make_number (e
),
4718 coding_system
, Qnil
);
4721 coding_system
= Qraw_text
;
4724 if (NILP (Fcoding_system_p (coding_system
)))
4726 /* Invalid coding system. */
4728 if (!NILP (noerror
))
4729 coding_system
= Qraw_text
;
4731 xsignal1 (Qcoding_system_error
, coding_system
);
4735 object
= make_buffer_string (b
, e
, 0);
4736 if (prev
!= current_buffer
)
4737 set_buffer_internal (prev
);
4738 /* Discard the unwind protect for recovering the current
4742 if (STRING_MULTIBYTE (object
))
4743 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4751 md5_buffer (SSDATA (object
) + start_byte
,
4752 SBYTES (object
) - (size_byte
- end_byte
),
4758 for (i
= 0; i
< 16; i
++)
4759 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4760 res
= make_string (value
, 32);
4763 res
= make_string (digest
, 16);
4770 sha1_buffer (SSDATA (object
) + start_byte
,
4771 SBYTES (object
) - (size_byte
- end_byte
),
4776 for (i
= 0; i
< 20; i
++)
4777 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4778 res
= make_string (value
, 40);
4781 res
= make_string (digest
, 20);
4789 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4790 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4792 A message digest is a cryptographic checksum of a document, and the
4793 algorithm to calculate it is defined in RFC 1321.
4795 The two optional arguments START and END are character positions
4796 specifying for which part of OBJECT the message digest should be
4797 computed. If nil or omitted, the digest is computed for the whole
4800 The MD5 message digest is computed from the result of encoding the
4801 text in a coding system, not directly from the internal Emacs form of
4802 the text. The optional fourth argument CODING-SYSTEM specifies which
4803 coding system to encode the text with. It should be the same coding
4804 system that you used or will use when actually writing the text into a
4807 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4808 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4809 system would be chosen by default for writing this text into a file.
4811 If OBJECT is a string, the most preferred coding system (see the
4812 command `prefer-coding-system') is used.
4814 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4815 guesswork fails. Normally, an error is signaled in such case. */)
4816 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4818 return crypto_hash_function (0, object
, start
, end
, coding_system
, noerror
, Qnil
);
4821 DEFUN ("sha1", Fsha1
, Ssha1
, 1, 4, 0,
4822 doc
: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
4824 OBJECT is either a string or a buffer. Optional arguments START and
4825 END are character positions specifying which portion of OBJECT for
4826 computing the hash. If BINARY is non-nil, return a string in binary
4828 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4830 return crypto_hash_function (1, object
, start
, end
, Qnil
, Qnil
, binary
);
4837 /* Hash table stuff. */
4838 Qhash_table_p
= intern_c_string ("hash-table-p");
4839 staticpro (&Qhash_table_p
);
4840 Qeq
= intern_c_string ("eq");
4842 Qeql
= intern_c_string ("eql");
4844 Qequal
= intern_c_string ("equal");
4845 staticpro (&Qequal
);
4846 QCtest
= intern_c_string (":test");
4847 staticpro (&QCtest
);
4848 QCsize
= intern_c_string (":size");
4849 staticpro (&QCsize
);
4850 QCrehash_size
= intern_c_string (":rehash-size");
4851 staticpro (&QCrehash_size
);
4852 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4853 staticpro (&QCrehash_threshold
);
4854 QCweakness
= intern_c_string (":weakness");
4855 staticpro (&QCweakness
);
4856 Qkey
= intern_c_string ("key");
4858 Qvalue
= intern_c_string ("value");
4859 staticpro (&Qvalue
);
4860 Qhash_table_test
= intern_c_string ("hash-table-test");
4861 staticpro (&Qhash_table_test
);
4862 Qkey_or_value
= intern_c_string ("key-or-value");
4863 staticpro (&Qkey_or_value
);
4864 Qkey_and_value
= intern_c_string ("key-and-value");
4865 staticpro (&Qkey_and_value
);
4868 defsubr (&Smake_hash_table
);
4869 defsubr (&Scopy_hash_table
);
4870 defsubr (&Shash_table_count
);
4871 defsubr (&Shash_table_rehash_size
);
4872 defsubr (&Shash_table_rehash_threshold
);
4873 defsubr (&Shash_table_size
);
4874 defsubr (&Shash_table_test
);
4875 defsubr (&Shash_table_weakness
);
4876 defsubr (&Shash_table_p
);
4877 defsubr (&Sclrhash
);
4878 defsubr (&Sgethash
);
4879 defsubr (&Sputhash
);
4880 defsubr (&Sremhash
);
4881 defsubr (&Smaphash
);
4882 defsubr (&Sdefine_hash_table_test
);
4884 Qstring_lessp
= intern_c_string ("string-lessp");
4885 staticpro (&Qstring_lessp
);
4886 Qprovide
= intern_c_string ("provide");
4887 staticpro (&Qprovide
);
4888 Qrequire
= intern_c_string ("require");
4889 staticpro (&Qrequire
);
4890 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4891 staticpro (&Qyes_or_no_p_history
);
4892 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4893 staticpro (&Qcursor_in_echo_area
);
4894 Qwidget_type
= intern_c_string ("widget-type");
4895 staticpro (&Qwidget_type
);
4897 staticpro (&string_char_byte_cache_string
);
4898 string_char_byte_cache_string
= Qnil
;
4900 require_nesting_list
= Qnil
;
4901 staticpro (&require_nesting_list
);
4903 Fset (Qyes_or_no_p_history
, Qnil
);
4905 DEFVAR_LISP ("features", Vfeatures
,
4906 doc
: /* A list of symbols which are the features of the executing Emacs.
4907 Used by `featurep' and `require', and altered by `provide'. */);
4908 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4909 Qsubfeatures
= intern_c_string ("subfeatures");
4910 staticpro (&Qsubfeatures
);
4912 #ifdef HAVE_LANGINFO_CODESET
4913 Qcodeset
= intern_c_string ("codeset");
4914 staticpro (&Qcodeset
);
4915 Qdays
= intern_c_string ("days");
4917 Qmonths
= intern_c_string ("months");
4918 staticpro (&Qmonths
);
4919 Qpaper
= intern_c_string ("paper");
4920 staticpro (&Qpaper
);
4921 #endif /* HAVE_LANGINFO_CODESET */
4923 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4924 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4925 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4926 invoked by mouse clicks and mouse menu items.
4928 On some platforms, file selection dialogs are also enabled if this is
4932 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4933 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4934 This applies to commands from menus and tool bar buttons even when
4935 they are initiated from the keyboard. If `use-dialog-box' is nil,
4936 that disables the use of a file dialog, regardless of the value of
4938 use_file_dialog
= 1;
4940 defsubr (&Sidentity
);
4943 defsubr (&Ssafe_length
);
4944 defsubr (&Sstring_bytes
);
4945 defsubr (&Sstring_equal
);
4946 defsubr (&Scompare_strings
);
4947 defsubr (&Sstring_lessp
);
4950 defsubr (&Svconcat
);
4951 defsubr (&Scopy_sequence
);
4952 defsubr (&Sstring_make_multibyte
);
4953 defsubr (&Sstring_make_unibyte
);
4954 defsubr (&Sstring_as_multibyte
);
4955 defsubr (&Sstring_as_unibyte
);
4956 defsubr (&Sstring_to_multibyte
);
4957 defsubr (&Sstring_to_unibyte
);
4958 defsubr (&Scopy_alist
);
4959 defsubr (&Ssubstring
);
4960 defsubr (&Ssubstring_no_properties
);
4973 defsubr (&Snreverse
);
4974 defsubr (&Sreverse
);
4976 defsubr (&Splist_get
);
4978 defsubr (&Splist_put
);
4980 defsubr (&Slax_plist_get
);
4981 defsubr (&Slax_plist_put
);
4984 defsubr (&Sequal_including_properties
);
4985 defsubr (&Sfillarray
);
4986 defsubr (&Sclear_string
);
4990 defsubr (&Smapconcat
);
4991 defsubr (&Syes_or_no_p
);
4992 defsubr (&Sload_average
);
4993 defsubr (&Sfeaturep
);
4994 defsubr (&Srequire
);
4995 defsubr (&Sprovide
);
4996 defsubr (&Splist_member
);
4997 defsubr (&Swidget_put
);
4998 defsubr (&Swidget_get
);
4999 defsubr (&Swidget_apply
);
5000 defsubr (&Sbase64_encode_region
);
5001 defsubr (&Sbase64_decode_region
);
5002 defsubr (&Sbase64_encode_string
);
5003 defsubr (&Sbase64_decode_string
);
5006 defsubr (&Slocale_info
);