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/>. */
30 #include "character.h"
35 #include "intervals.h"
38 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
43 #endif /* HAVE_MENUS */
46 #define NULL ((POINTER_TYPE *)0)
49 Lisp_Object Qstring_lessp
;
50 static Lisp_Object Qprovide
, Qrequire
;
51 static Lisp_Object Qyes_or_no_p_history
;
52 Lisp_Object Qcursor_in_echo_area
;
53 static Lisp_Object Qwidget_type
;
54 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
56 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
62 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
63 doc
: /* Return the argument unchanged. */)
69 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
70 doc
: /* Return a pseudo-random number.
71 All integers representable in Lisp are equally likely.
72 On most systems, this is 29 bits' worth.
73 With positive integer LIMIT, return random number in interval [0,LIMIT).
74 With argument t, set the random number seed from the current time and pid.
75 Other values of LIMIT are ignored. */)
79 Lisp_Object lispy_val
;
80 EMACS_UINT denominator
;
83 seed_random (getpid () + time (NULL
));
84 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
86 /* Try to take our random number from the higher bits of VAL,
87 not the lower, since (says Gentzel) the low bits of `random'
88 are less random than the higher ones. We do this by using the
89 quotient rather than the remainder. At the high end of the RNG
90 it's possible to get a quotient larger than n; discarding
91 these values eliminates the bias that would otherwise appear
92 when using a large n. */
93 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
95 val
= get_random () / denominator
;
96 while (val
>= XFASTINT (limit
));
100 XSETINT (lispy_val
, val
);
104 /* Heuristic on how many iterations of a tight loop can be safely done
105 before it's time to do a QUIT. This must be a power of 2. */
106 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
108 /* Random data-structure functions */
110 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
111 doc
: /* Return the length of vector, list or string SEQUENCE.
112 A byte-code function object is also allowed.
113 If the string contains multibyte characters, this is not necessarily
114 the number of bytes in the string; it is the number of characters.
115 To get the number of bytes, use `string-bytes'. */)
116 (register Lisp_Object sequence
)
118 register Lisp_Object val
;
120 if (STRINGP (sequence
))
121 XSETFASTINT (val
, SCHARS (sequence
));
122 else if (VECTORP (sequence
))
123 XSETFASTINT (val
, ASIZE (sequence
));
124 else if (CHAR_TABLE_P (sequence
))
125 XSETFASTINT (val
, MAX_CHAR
);
126 else if (BOOL_VECTOR_P (sequence
))
127 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
128 else if (COMPILEDP (sequence
))
129 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
130 else if (CONSP (sequence
))
137 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
139 if (MOST_POSITIVE_FIXNUM
< i
)
140 error ("List too long");
143 sequence
= XCDR (sequence
);
145 while (CONSP (sequence
));
147 CHECK_LIST_END (sequence
, sequence
);
149 val
= make_number (i
);
151 else if (NILP (sequence
))
152 XSETFASTINT (val
, 0);
154 wrong_type_argument (Qsequencep
, sequence
);
159 /* This does not check for quits. That is safe since it must terminate. */
161 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
162 doc
: /* Return the length of a list, but avoid error or infinite loop.
163 This function never gets an error. If LIST is not really a list,
164 it returns 0. If LIST is circular, it returns a finite value
165 which is at least the number of distinct elements. */)
168 Lisp_Object tail
, halftail
;
175 /* halftail is used to detect circular lists. */
176 for (tail
= halftail
= list
; ; )
181 if (EQ (tail
, halftail
))
184 if ((lolen
& 1) == 0)
186 halftail
= XCDR (halftail
);
187 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
191 hilen
+= UINTMAX_MAX
+ 1.0;
196 /* If the length does not fit into a fixnum, return a float.
197 On all known practical machines this returns an upper bound on
199 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
202 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
203 doc
: /* Return the number of bytes in STRING.
204 If STRING is multibyte, this may be greater than the length of STRING. */)
207 CHECK_STRING (string
);
208 return make_number (SBYTES (string
));
211 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
212 doc
: /* Return t if two strings have identical contents.
213 Case is significant, but text properties are ignored.
214 Symbols are also allowed; their print names are used instead. */)
215 (register Lisp_Object s1
, Lisp_Object s2
)
218 s1
= SYMBOL_NAME (s1
);
220 s2
= SYMBOL_NAME (s2
);
224 if (SCHARS (s1
) != SCHARS (s2
)
225 || SBYTES (s1
) != SBYTES (s2
)
226 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
231 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
232 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
233 In string STR1, skip the first START1 characters and stop at END1.
234 In string STR2, skip the first START2 characters and stop at END2.
235 END1 and END2 default to the full lengths of the respective strings.
237 Case is significant in this comparison if IGNORE-CASE is nil.
238 Unibyte strings are converted to multibyte for comparison.
240 The value is t if the strings (or specified portions) match.
241 If string STR1 is less, the value is a negative number N;
242 - 1 - N is the number of characters that match at the beginning.
243 If string STR1 is greater, the value is a positive number N;
244 N - 1 is the number of characters that match at the beginning. */)
245 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
247 register EMACS_INT end1_char
, end2_char
;
248 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
253 start1
= make_number (0);
255 start2
= make_number (0);
256 CHECK_NATNUM (start1
);
257 CHECK_NATNUM (start2
);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 end1_char
= SCHARS (str1
);
270 if (! NILP (end1
) && end1_char
> XINT (end1
))
271 end1_char
= XINT (end1
);
273 end2_char
= SCHARS (str2
);
274 if (! NILP (end2
) && end2_char
> XINT (end2
))
275 end2_char
= XINT (end2
);
277 while (i1
< end1_char
&& i2
< end2_char
)
279 /* When we find a mismatch, we must compare the
280 characters, not just the bytes. */
283 if (STRING_MULTIBYTE (str1
))
284 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
287 c1
= SREF (str1
, i1
++);
288 MAKE_CHAR_MULTIBYTE (c1
);
291 if (STRING_MULTIBYTE (str2
))
292 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
295 c2
= SREF (str2
, i2
++);
296 MAKE_CHAR_MULTIBYTE (c2
);
302 if (! NILP (ignore_case
))
306 tem
= Fupcase (make_number (c1
));
308 tem
= Fupcase (make_number (c2
));
315 /* Note that I1 has already been incremented
316 past the character that we are comparing;
317 hence we don't add or subtract 1 here. */
319 return make_number (- i1
+ XINT (start1
));
321 return make_number (i1
- XINT (start1
));
325 return make_number (i1
- XINT (start1
) + 1);
327 return make_number (- i1
+ XINT (start1
) - 1);
332 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
333 doc
: /* Return t if first arg string is less than second in lexicographic order.
335 Symbols are also allowed; their print names are used instead. */)
336 (register Lisp_Object s1
, Lisp_Object s2
)
338 register EMACS_INT end
;
339 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
342 s1
= SYMBOL_NAME (s1
);
344 s2
= SYMBOL_NAME (s2
);
348 i1
= i1_byte
= i2
= i2_byte
= 0;
351 if (end
> SCHARS (s2
))
356 /* When we find a mismatch, we must compare the
357 characters, not just the bytes. */
360 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
361 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
364 return c1
< c2
? Qt
: Qnil
;
366 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
369 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
370 enum Lisp_Type target_type
, int last_special
);
374 concat2 (Lisp_Object s1
, Lisp_Object s2
)
379 return concat (2, args
, Lisp_String
, 0);
384 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
390 return concat (3, args
, Lisp_String
, 0);
393 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
394 doc
: /* Concatenate all the arguments and make the result a list.
395 The result is a list whose elements are the elements of all the arguments.
396 Each argument may be a list, vector or string.
397 The last argument is not copied, just used as the tail of the new list.
398 usage: (append &rest SEQUENCES) */)
399 (ptrdiff_t nargs
, Lisp_Object
*args
)
401 return concat (nargs
, args
, Lisp_Cons
, 1);
404 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
405 doc
: /* Concatenate all the arguments and make the result a string.
406 The result is a string whose elements are the elements of all the arguments.
407 Each argument may be a string or a list or vector of characters (integers).
408 usage: (concat &rest SEQUENCES) */)
409 (ptrdiff_t nargs
, Lisp_Object
*args
)
411 return concat (nargs
, args
, Lisp_String
, 0);
414 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
415 doc
: /* Concatenate all the arguments and make the result a vector.
416 The result is a vector whose elements are the elements of all the arguments.
417 Each argument may be a list, vector or string.
418 usage: (vconcat &rest SEQUENCES) */)
419 (ptrdiff_t nargs
, Lisp_Object
*args
)
421 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
425 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
426 doc
: /* Return a copy of a list, vector, string or char-table.
427 The elements of a list or vector are not copied; they are shared
428 with the original. */)
431 if (NILP (arg
)) return arg
;
433 if (CHAR_TABLE_P (arg
))
435 return copy_char_table (arg
);
438 if (BOOL_VECTOR_P (arg
))
441 ptrdiff_t size_in_chars
442 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
443 / BOOL_VECTOR_BITS_PER_CHAR
);
445 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
446 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
451 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
452 wrong_type_argument (Qsequencep
, arg
);
454 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
457 /* This structure holds information of an argument of `concat' that is
458 a string and has text properties to be copied. */
461 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
462 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
463 EMACS_INT to
; /* refer to VAL (the target string) */
467 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
468 enum Lisp_Type target_type
, int last_special
)
471 register Lisp_Object tail
;
472 register Lisp_Object
this;
474 EMACS_INT toindex_byte
= 0;
475 register EMACS_INT result_len
;
476 register EMACS_INT result_len_byte
;
478 Lisp_Object last_tail
;
481 /* When we make a multibyte string, we can't copy text properties
482 while concatenating each string because the length of resulting
483 string can't be decided until we finish the whole concatenation.
484 So, we record strings that have text properties to be copied
485 here, and copy the text properties after the concatenation. */
486 struct textprop_rec
*textprops
= NULL
;
487 /* Number of elements in textprops. */
488 ptrdiff_t num_textprops
= 0;
493 /* In append, the last arg isn't treated like the others */
494 if (last_special
&& nargs
> 0)
497 last_tail
= args
[nargs
];
502 /* Check each argument. */
503 for (argnum
= 0; argnum
< nargs
; argnum
++)
506 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
507 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
508 wrong_type_argument (Qsequencep
, this);
511 /* Compute total length in chars of arguments in RESULT_LEN.
512 If desired output is a string, also compute length in bytes
513 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
514 whether the result should be a multibyte string. */
518 for (argnum
= 0; argnum
< nargs
; argnum
++)
522 len
= XFASTINT (Flength (this));
523 if (target_type
== Lisp_String
)
525 /* We must count the number of bytes needed in the string
526 as well as the number of characters. */
530 EMACS_INT this_len_byte
;
532 if (VECTORP (this) || COMPILEDP (this))
533 for (i
= 0; i
< len
; i
++)
536 CHECK_CHARACTER (ch
);
538 this_len_byte
= CHAR_BYTES (c
);
539 result_len_byte
+= this_len_byte
;
540 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
543 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
544 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
545 else if (CONSP (this))
546 for (; CONSP (this); this = XCDR (this))
549 CHECK_CHARACTER (ch
);
551 this_len_byte
= CHAR_BYTES (c
);
552 result_len_byte
+= this_len_byte
;
553 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
556 else if (STRINGP (this))
558 if (STRING_MULTIBYTE (this))
561 result_len_byte
+= SBYTES (this);
564 result_len_byte
+= count_size_as_multibyte (SDATA (this),
570 if (STRING_BYTES_BOUND
< result_len
)
574 if (! some_multibyte
)
575 result_len_byte
= result_len
;
577 /* Create the output object. */
578 if (target_type
== Lisp_Cons
)
579 val
= Fmake_list (make_number (result_len
), Qnil
);
580 else if (target_type
== Lisp_Vectorlike
)
581 val
= Fmake_vector (make_number (result_len
), Qnil
);
582 else if (some_multibyte
)
583 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
585 val
= make_uninit_string (result_len
);
587 /* In `append', if all but last arg are nil, return last arg. */
588 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
591 /* Copy the contents of the args into the result. */
593 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
595 toindex
= 0, toindex_byte
= 0;
599 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
601 for (argnum
= 0; argnum
< nargs
; argnum
++)
604 EMACS_INT thisleni
= 0;
605 register EMACS_INT thisindex
= 0;
606 register EMACS_INT thisindex_byte
= 0;
610 thislen
= Flength (this), thisleni
= XINT (thislen
);
612 /* Between strings of the same kind, copy fast. */
613 if (STRINGP (this) && STRINGP (val
)
614 && STRING_MULTIBYTE (this) == some_multibyte
)
616 EMACS_INT thislen_byte
= SBYTES (this);
618 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
619 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
621 textprops
[num_textprops
].argnum
= argnum
;
622 textprops
[num_textprops
].from
= 0;
623 textprops
[num_textprops
++].to
= toindex
;
625 toindex_byte
+= thislen_byte
;
628 /* Copy a single-byte string to a multibyte string. */
629 else if (STRINGP (this) && STRINGP (val
))
631 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
633 textprops
[num_textprops
].argnum
= argnum
;
634 textprops
[num_textprops
].from
= 0;
635 textprops
[num_textprops
++].to
= toindex
;
637 toindex_byte
+= copy_text (SDATA (this),
638 SDATA (val
) + toindex_byte
,
639 SCHARS (this), 0, 1);
643 /* Copy element by element. */
646 register Lisp_Object elt
;
648 /* Fetch next element of `this' arg into `elt', or break if
649 `this' is exhausted. */
650 if (NILP (this)) break;
652 elt
= XCAR (this), this = XCDR (this);
653 else if (thisindex
>= thisleni
)
655 else if (STRINGP (this))
658 if (STRING_MULTIBYTE (this))
659 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
664 c
= SREF (this, thisindex
); thisindex
++;
665 if (some_multibyte
&& !ASCII_CHAR_P (c
))
666 c
= BYTE8_TO_CHAR (c
);
668 XSETFASTINT (elt
, c
);
670 else if (BOOL_VECTOR_P (this))
673 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
674 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
682 elt
= AREF (this, thisindex
);
686 /* Store this element into the result. */
693 else if (VECTORP (val
))
695 ASET (val
, toindex
, elt
);
701 CHECK_CHARACTER (elt
);
704 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
706 SSET (val
, toindex_byte
++, c
);
712 XSETCDR (prev
, last_tail
);
714 if (num_textprops
> 0)
717 EMACS_INT last_to_end
= -1;
719 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
721 this = args
[textprops
[argnum
].argnum
];
722 props
= text_property_list (this,
724 make_number (SCHARS (this)),
726 /* If successive arguments have properties, be sure that the
727 value of `composition' property be the copy. */
728 if (last_to_end
== textprops
[argnum
].to
)
729 make_composition_value_copy (props
);
730 add_text_properties_from_list (val
, props
,
731 make_number (textprops
[argnum
].to
));
732 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
740 static Lisp_Object string_char_byte_cache_string
;
741 static EMACS_INT string_char_byte_cache_charpos
;
742 static EMACS_INT string_char_byte_cache_bytepos
;
745 clear_string_char_byte_cache (void)
747 string_char_byte_cache_string
= Qnil
;
750 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
753 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
756 EMACS_INT best_below
, best_below_byte
;
757 EMACS_INT best_above
, best_above_byte
;
759 best_below
= best_below_byte
= 0;
760 best_above
= SCHARS (string
);
761 best_above_byte
= SBYTES (string
);
762 if (best_above
== best_above_byte
)
765 if (EQ (string
, string_char_byte_cache_string
))
767 if (string_char_byte_cache_charpos
< char_index
)
769 best_below
= string_char_byte_cache_charpos
;
770 best_below_byte
= string_char_byte_cache_bytepos
;
774 best_above
= string_char_byte_cache_charpos
;
775 best_above_byte
= string_char_byte_cache_bytepos
;
779 if (char_index
- best_below
< best_above
- char_index
)
781 unsigned char *p
= SDATA (string
) + best_below_byte
;
783 while (best_below
< char_index
)
785 p
+= BYTES_BY_CHAR_HEAD (*p
);
788 i_byte
= p
- SDATA (string
);
792 unsigned char *p
= SDATA (string
) + best_above_byte
;
794 while (best_above
> char_index
)
797 while (!CHAR_HEAD_P (*p
)) p
--;
800 i_byte
= p
- SDATA (string
);
803 string_char_byte_cache_bytepos
= i_byte
;
804 string_char_byte_cache_charpos
= char_index
;
805 string_char_byte_cache_string
= string
;
810 /* Return the character index corresponding to BYTE_INDEX in STRING. */
813 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
816 EMACS_INT best_below
, best_below_byte
;
817 EMACS_INT best_above
, best_above_byte
;
819 best_below
= best_below_byte
= 0;
820 best_above
= SCHARS (string
);
821 best_above_byte
= SBYTES (string
);
822 if (best_above
== best_above_byte
)
825 if (EQ (string
, string_char_byte_cache_string
))
827 if (string_char_byte_cache_bytepos
< byte_index
)
829 best_below
= string_char_byte_cache_charpos
;
830 best_below_byte
= string_char_byte_cache_bytepos
;
834 best_above
= string_char_byte_cache_charpos
;
835 best_above_byte
= string_char_byte_cache_bytepos
;
839 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
841 unsigned char *p
= SDATA (string
) + best_below_byte
;
842 unsigned char *pend
= SDATA (string
) + byte_index
;
846 p
+= BYTES_BY_CHAR_HEAD (*p
);
850 i_byte
= p
- SDATA (string
);
854 unsigned char *p
= SDATA (string
) + best_above_byte
;
855 unsigned char *pbeg
= SDATA (string
) + byte_index
;
860 while (!CHAR_HEAD_P (*p
)) p
--;
864 i_byte
= p
- SDATA (string
);
867 string_char_byte_cache_bytepos
= i_byte
;
868 string_char_byte_cache_charpos
= i
;
869 string_char_byte_cache_string
= string
;
874 /* Convert STRING to a multibyte string. */
877 string_make_multibyte (Lisp_Object string
)
884 if (STRING_MULTIBYTE (string
))
887 nbytes
= count_size_as_multibyte (SDATA (string
),
889 /* If all the chars are ASCII, they won't need any more bytes
890 once converted. In that case, we can return STRING itself. */
891 if (nbytes
== SBYTES (string
))
894 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
895 copy_text (SDATA (string
), buf
, SBYTES (string
),
898 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
905 /* Convert STRING (if unibyte) to a multibyte string without changing
906 the number of characters. Characters 0200 trough 0237 are
907 converted to eight-bit characters. */
910 string_to_multibyte (Lisp_Object string
)
917 if (STRING_MULTIBYTE (string
))
920 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
921 /* If all the chars are ASCII, they won't need any more bytes once
923 if (nbytes
== SBYTES (string
))
924 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
926 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
927 memcpy (buf
, SDATA (string
), SBYTES (string
));
928 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
930 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
937 /* Convert STRING to a single-byte string. */
940 string_make_unibyte (Lisp_Object string
)
947 if (! STRING_MULTIBYTE (string
))
950 nchars
= SCHARS (string
);
952 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
953 copy_text (SDATA (string
), buf
, SBYTES (string
),
956 ret
= make_unibyte_string ((char *) buf
, nchars
);
962 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
964 doc
: /* Return the multibyte equivalent of STRING.
965 If STRING is unibyte and contains non-ASCII characters, the function
966 `unibyte-char-to-multibyte' is used to convert each unibyte character
967 to a multibyte character. In this case, the returned string is a
968 newly created string with no text properties. If STRING is multibyte
969 or entirely ASCII, it is returned unchanged. In particular, when
970 STRING is unibyte and entirely ASCII, the returned string is unibyte.
971 \(When the characters are all ASCII, Emacs primitives will treat the
972 string the same way whether it is unibyte or multibyte.) */)
975 CHECK_STRING (string
);
977 return string_make_multibyte (string
);
980 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
982 doc
: /* Return the unibyte equivalent of STRING.
983 Multibyte character codes are converted to unibyte according to
984 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
985 If the lookup in the translation table fails, this function takes just
986 the low 8 bits of each character. */)
989 CHECK_STRING (string
);
991 return string_make_unibyte (string
);
994 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
996 doc
: /* Return a unibyte string with the same individual bytes as STRING.
997 If STRING is unibyte, the result is STRING itself.
998 Otherwise it is a newly created string, with no text properties.
999 If STRING is multibyte and contains a character of charset
1000 `eight-bit', it is converted to the corresponding single byte. */)
1001 (Lisp_Object string
)
1003 CHECK_STRING (string
);
1005 if (STRING_MULTIBYTE (string
))
1007 EMACS_INT bytes
= SBYTES (string
);
1008 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1010 memcpy (str
, SDATA (string
), bytes
);
1011 bytes
= str_as_unibyte (str
, bytes
);
1012 string
= make_unibyte_string ((char *) str
, bytes
);
1018 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1020 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1021 If STRING is multibyte, the result is STRING itself.
1022 Otherwise it is a newly created string, with no text properties.
1024 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1025 part of a correct utf-8 sequence), it is converted to the corresponding
1026 multibyte character of charset `eight-bit'.
1027 See also `string-to-multibyte'.
1029 Beware, this often doesn't really do what you think it does.
1030 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1031 If you're not sure, whether to use `string-as-multibyte' or
1032 `string-to-multibyte', use `string-to-multibyte'. */)
1033 (Lisp_Object string
)
1035 CHECK_STRING (string
);
1037 if (! STRING_MULTIBYTE (string
))
1039 Lisp_Object new_string
;
1040 EMACS_INT nchars
, nbytes
;
1042 parse_str_as_multibyte (SDATA (string
),
1045 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1046 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1047 if (nbytes
!= SBYTES (string
))
1048 str_as_multibyte (SDATA (new_string
), nbytes
,
1049 SBYTES (string
), NULL
);
1050 string
= new_string
;
1051 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1056 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1058 doc
: /* Return a multibyte string with the same individual chars as STRING.
1059 If STRING is multibyte, the result is STRING itself.
1060 Otherwise it is a newly created string, with no text properties.
1062 If STRING is unibyte and contains an 8-bit byte, it is converted to
1063 the corresponding multibyte character of charset `eight-bit'.
1065 This differs from `string-as-multibyte' by converting each byte of a correct
1066 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1067 correct sequence. */)
1068 (Lisp_Object string
)
1070 CHECK_STRING (string
);
1072 return string_to_multibyte (string
);
1075 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1077 doc
: /* Return a unibyte string with the same individual chars as STRING.
1078 If STRING is unibyte, the result is STRING itself.
1079 Otherwise it is a newly created string, with no text properties,
1080 where each `eight-bit' character is converted to the corresponding byte.
1081 If STRING contains a non-ASCII, non-`eight-bit' character,
1082 an error is signaled. */)
1083 (Lisp_Object string
)
1085 CHECK_STRING (string
);
1087 if (STRING_MULTIBYTE (string
))
1089 EMACS_INT chars
= SCHARS (string
);
1090 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1091 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1093 if (converted
< chars
)
1094 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1095 string
= make_unibyte_string ((char *) str
, chars
);
1102 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1103 doc
: /* Return a copy of ALIST.
1104 This is an alist which represents the same mapping from objects to objects,
1105 but does not share the alist structure with ALIST.
1106 The objects mapped (cars and cdrs of elements of the alist)
1107 are shared, however.
1108 Elements of ALIST that are not conses are also shared. */)
1111 register Lisp_Object tem
;
1116 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1117 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1119 register Lisp_Object car
;
1123 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1128 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1129 doc
: /* Return a new string whose contents are a substring of STRING.
1130 The returned string consists of the characters between index FROM
1131 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1132 zero-indexed: 0 means the first character of STRING. Negative values
1133 are counted from the end of STRING. If TO is nil, the substring runs
1134 to the end of STRING.
1136 The STRING argument may also be a vector. In that case, the return
1137 value is a new vector that contains the elements between index FROM
1138 \(inclusive) and index TO (exclusive) of that vector argument. */)
1139 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1143 EMACS_INT size_byte
= 0;
1144 EMACS_INT from_char
, to_char
;
1145 EMACS_INT from_byte
= 0, to_byte
= 0;
1147 CHECK_VECTOR_OR_STRING (string
);
1148 CHECK_NUMBER (from
);
1150 if (STRINGP (string
))
1152 size
= SCHARS (string
);
1153 size_byte
= SBYTES (string
);
1156 size
= ASIZE (string
);
1161 to_byte
= size_byte
;
1167 to_char
= XINT (to
);
1171 if (STRINGP (string
))
1172 to_byte
= string_char_to_byte (string
, to_char
);
1175 from_char
= XINT (from
);
1178 if (STRINGP (string
))
1179 from_byte
= string_char_to_byte (string
, from_char
);
1181 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1182 args_out_of_range_3 (string
, make_number (from_char
),
1183 make_number (to_char
));
1185 if (STRINGP (string
))
1187 res
= make_specified_string (SSDATA (string
) + from_byte
,
1188 to_char
- from_char
, to_byte
- from_byte
,
1189 STRING_MULTIBYTE (string
));
1190 copy_text_properties (make_number (from_char
), make_number (to_char
),
1191 string
, make_number (0), res
, Qnil
);
1194 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1200 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1201 doc
: /* Return a substring of STRING, without text properties.
1202 It starts at index FROM and ends before TO.
1203 TO may be nil or omitted; then the substring runs to the end of STRING.
1204 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1205 If FROM or TO is negative, it counts from the end.
1207 With one argument, just copy STRING without its properties. */)
1208 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1210 EMACS_INT size
, size_byte
;
1211 EMACS_INT from_char
, to_char
;
1212 EMACS_INT from_byte
, to_byte
;
1214 CHECK_STRING (string
);
1216 size
= SCHARS (string
);
1217 size_byte
= SBYTES (string
);
1220 from_char
= from_byte
= 0;
1223 CHECK_NUMBER (from
);
1224 from_char
= XINT (from
);
1228 from_byte
= string_char_to_byte (string
, from_char
);
1234 to_byte
= size_byte
;
1240 to_char
= XINT (to
);
1244 to_byte
= string_char_to_byte (string
, to_char
);
1247 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1248 args_out_of_range_3 (string
, make_number (from_char
),
1249 make_number (to_char
));
1251 return make_specified_string (SSDATA (string
) + from_byte
,
1252 to_char
- from_char
, to_byte
- from_byte
,
1253 STRING_MULTIBYTE (string
));
1256 /* Extract a substring of STRING, giving start and end positions
1257 both in characters and in bytes. */
1260 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1261 EMACS_INT to
, EMACS_INT to_byte
)
1266 CHECK_VECTOR_OR_STRING (string
);
1268 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1270 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1271 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1273 if (STRINGP (string
))
1275 res
= make_specified_string (SSDATA (string
) + from_byte
,
1276 to
- from
, to_byte
- from_byte
,
1277 STRING_MULTIBYTE (string
));
1278 copy_text_properties (make_number (from
), make_number (to
),
1279 string
, make_number (0), res
, Qnil
);
1282 res
= Fvector (to
- from
, &AREF (string
, from
));
1287 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1288 doc
: /* Take cdr N times on LIST, return the result. */)
1289 (Lisp_Object n
, Lisp_Object list
)
1294 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1297 CHECK_LIST_CONS (list
, list
);
1303 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1304 doc
: /* Return the Nth element of LIST.
1305 N counts from zero. If LIST is not that long, nil is returned. */)
1306 (Lisp_Object n
, Lisp_Object list
)
1308 return Fcar (Fnthcdr (n
, list
));
1311 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1312 doc
: /* Return element of SEQUENCE at index N. */)
1313 (register Lisp_Object sequence
, Lisp_Object n
)
1316 if (CONSP (sequence
) || NILP (sequence
))
1317 return Fcar (Fnthcdr (n
, sequence
));
1319 /* Faref signals a "not array" error, so check here. */
1320 CHECK_ARRAY (sequence
, Qsequencep
);
1321 return Faref (sequence
, n
);
1324 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1325 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1326 The value is actually the tail of LIST whose car is ELT. */)
1327 (register Lisp_Object elt
, Lisp_Object list
)
1329 register Lisp_Object tail
;
1330 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1332 register Lisp_Object tem
;
1333 CHECK_LIST_CONS (tail
, list
);
1335 if (! NILP (Fequal (elt
, tem
)))
1342 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1343 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1344 The value is actually the tail of LIST whose car is ELT. */)
1345 (register Lisp_Object elt
, Lisp_Object list
)
1349 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1353 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1368 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1369 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1370 The value is actually the tail of LIST whose car is ELT. */)
1371 (register Lisp_Object elt
, Lisp_Object list
)
1373 register Lisp_Object tail
;
1376 return Fmemq (elt
, list
);
1378 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1380 register Lisp_Object tem
;
1381 CHECK_LIST_CONS (tail
, list
);
1383 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1390 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1391 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1392 The value is actually the first element of LIST whose car is KEY.
1393 Elements of LIST that are not conses are ignored. */)
1394 (Lisp_Object key
, Lisp_Object list
)
1399 || (CONSP (XCAR (list
))
1400 && EQ (XCAR (XCAR (list
)), key
)))
1405 || (CONSP (XCAR (list
))
1406 && EQ (XCAR (XCAR (list
)), key
)))
1411 || (CONSP (XCAR (list
))
1412 && EQ (XCAR (XCAR (list
)), key
)))
1422 /* Like Fassq but never report an error and do not allow quits.
1423 Use only on lists known never to be circular. */
1426 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1429 && (!CONSP (XCAR (list
))
1430 || !EQ (XCAR (XCAR (list
)), key
)))
1433 return CAR_SAFE (list
);
1436 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1437 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1438 The value is actually the first element of LIST whose car equals KEY. */)
1439 (Lisp_Object key
, Lisp_Object list
)
1446 || (CONSP (XCAR (list
))
1447 && (car
= XCAR (XCAR (list
)),
1448 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1453 || (CONSP (XCAR (list
))
1454 && (car
= XCAR (XCAR (list
)),
1455 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1460 || (CONSP (XCAR (list
))
1461 && (car
= XCAR (XCAR (list
)),
1462 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1472 /* Like Fassoc but never report an error and do not allow quits.
1473 Use only on lists known never to be circular. */
1476 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1479 && (!CONSP (XCAR (list
))
1480 || (!EQ (XCAR (XCAR (list
)), key
)
1481 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1484 return CONSP (list
) ? XCAR (list
) : Qnil
;
1487 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1488 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1489 The value is actually the first element of LIST whose cdr is KEY. */)
1490 (register Lisp_Object key
, Lisp_Object list
)
1495 || (CONSP (XCAR (list
))
1496 && EQ (XCDR (XCAR (list
)), key
)))
1501 || (CONSP (XCAR (list
))
1502 && EQ (XCDR (XCAR (list
)), key
)))
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCDR (XCAR (list
)), key
)))
1518 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1519 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1520 The value is actually the first element of LIST whose cdr equals KEY. */)
1521 (Lisp_Object key
, Lisp_Object list
)
1528 || (CONSP (XCAR (list
))
1529 && (cdr
= XCDR (XCAR (list
)),
1530 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1535 || (CONSP (XCAR (list
))
1536 && (cdr
= XCDR (XCAR (list
)),
1537 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1542 || (CONSP (XCAR (list
))
1543 && (cdr
= XCDR (XCAR (list
)),
1544 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1554 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1555 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1556 The modified LIST is returned. Comparison is done with `eq'.
1557 If the first member of LIST is ELT, there is no way to remove it by side effect;
1558 therefore, write `(setq foo (delq element foo))'
1559 to be sure of changing the value of `foo'. */)
1560 (register Lisp_Object elt
, Lisp_Object list
)
1562 register Lisp_Object tail
, prev
;
1563 register Lisp_Object tem
;
1567 while (!NILP (tail
))
1569 CHECK_LIST_CONS (tail
, list
);
1576 Fsetcdr (prev
, XCDR (tail
));
1586 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1587 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1588 SEQ must be a list, a vector, or a string.
1589 The modified SEQ is returned. Comparison is done with `equal'.
1590 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1591 is not a side effect; it is simply using a different sequence.
1592 Therefore, write `(setq foo (delete element foo))'
1593 to be sure of changing the value of `foo'. */)
1594 (Lisp_Object elt
, Lisp_Object seq
)
1600 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1601 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1604 if (n
!= ASIZE (seq
))
1606 struct Lisp_Vector
*p
= allocate_vector (n
);
1608 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1609 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1610 p
->contents
[n
++] = AREF (seq
, i
);
1612 XSETVECTOR (seq
, p
);
1615 else if (STRINGP (seq
))
1617 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1620 for (i
= nchars
= nbytes
= ibyte
= 0;
1622 ++i
, ibyte
+= cbytes
)
1624 if (STRING_MULTIBYTE (seq
))
1626 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1627 cbytes
= CHAR_BYTES (c
);
1635 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1642 if (nchars
!= SCHARS (seq
))
1646 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1647 if (!STRING_MULTIBYTE (seq
))
1648 STRING_SET_UNIBYTE (tem
);
1650 for (i
= nchars
= nbytes
= ibyte
= 0;
1652 ++i
, ibyte
+= cbytes
)
1654 if (STRING_MULTIBYTE (seq
))
1656 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1657 cbytes
= CHAR_BYTES (c
);
1665 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1667 unsigned char *from
= SDATA (seq
) + ibyte
;
1668 unsigned char *to
= SDATA (tem
) + nbytes
;
1674 for (n
= cbytes
; n
--; )
1684 Lisp_Object tail
, prev
;
1686 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1688 CHECK_LIST_CONS (tail
, seq
);
1690 if (!NILP (Fequal (elt
, XCAR (tail
))))
1695 Fsetcdr (prev
, XCDR (tail
));
1706 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1707 doc
: /* Reverse LIST by modifying cdr pointers.
1708 Return the reversed list. */)
1711 register Lisp_Object prev
, tail
, next
;
1713 if (NILP (list
)) return list
;
1716 while (!NILP (tail
))
1719 CHECK_LIST_CONS (tail
, list
);
1721 Fsetcdr (tail
, prev
);
1728 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1729 doc
: /* Reverse LIST, copying. Return the reversed list.
1730 See also the function `nreverse', which is used more often. */)
1735 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1738 new = Fcons (XCAR (list
), new);
1740 CHECK_LIST_END (list
, list
);
1744 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1746 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1747 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1748 Returns the sorted list. LIST is modified by side effects.
1749 PREDICATE is called with two elements of LIST, and should return non-nil
1750 if the first element should sort before the second. */)
1751 (Lisp_Object list
, Lisp_Object predicate
)
1753 Lisp_Object front
, back
;
1754 register Lisp_Object len
, tem
;
1755 struct gcpro gcpro1
, gcpro2
;
1759 len
= Flength (list
);
1760 length
= XINT (len
);
1764 XSETINT (len
, (length
/ 2) - 1);
1765 tem
= Fnthcdr (len
, list
);
1767 Fsetcdr (tem
, Qnil
);
1769 GCPRO2 (front
, back
);
1770 front
= Fsort (front
, predicate
);
1771 back
= Fsort (back
, predicate
);
1773 return merge (front
, back
, predicate
);
1777 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1780 register Lisp_Object tail
;
1782 register Lisp_Object l1
, l2
;
1783 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1790 /* It is sufficient to protect org_l1 and org_l2.
1791 When l1 and l2 are updated, we copy the new values
1792 back into the org_ vars. */
1793 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1813 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1829 Fsetcdr (tail
, tem
);
1835 /* This does not check for quits. That is safe since it must terminate. */
1837 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1838 doc
: /* Extract a value from a property list.
1839 PLIST is a property list, which is a list of the form
1840 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1841 corresponding to the given PROP, or nil if PROP is not one of the
1842 properties on the list. This function never signals an error. */)
1843 (Lisp_Object plist
, Lisp_Object prop
)
1845 Lisp_Object tail
, halftail
;
1847 /* halftail is used to detect circular lists. */
1848 tail
= halftail
= plist
;
1849 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1851 if (EQ (prop
, XCAR (tail
)))
1852 return XCAR (XCDR (tail
));
1854 tail
= XCDR (XCDR (tail
));
1855 halftail
= XCDR (halftail
);
1856 if (EQ (tail
, halftail
))
1859 #if 0 /* Unsafe version. */
1860 /* This function can be called asynchronously
1861 (setup_coding_system). Don't QUIT in that case. */
1862 if (!interrupt_input_blocked
)
1870 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1871 doc
: /* Return the value of SYMBOL's PROPNAME property.
1872 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1873 (Lisp_Object symbol
, Lisp_Object propname
)
1875 CHECK_SYMBOL (symbol
);
1876 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1879 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1880 doc
: /* Change value in PLIST of PROP to VAL.
1881 PLIST is a property list, which is a list of the form
1882 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1883 If PROP is already a property on the list, its value is set to VAL,
1884 otherwise the new PROP VAL pair is added. The new plist is returned;
1885 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1886 The PLIST is modified by side effects. */)
1887 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1889 register Lisp_Object tail
, prev
;
1890 Lisp_Object newcell
;
1892 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1893 tail
= XCDR (XCDR (tail
)))
1895 if (EQ (prop
, XCAR (tail
)))
1897 Fsetcar (XCDR (tail
), val
);
1904 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1908 Fsetcdr (XCDR (prev
), newcell
);
1912 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1913 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1914 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1915 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1917 CHECK_SYMBOL (symbol
);
1918 XSYMBOL (symbol
)->plist
1919 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1923 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1924 doc
: /* Extract a value from a property list, comparing with `equal'.
1925 PLIST is a property list, which is a list of the form
1926 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1927 corresponding to the given PROP, or nil if PROP is not
1928 one of the properties on the list. */)
1929 (Lisp_Object plist
, Lisp_Object prop
)
1934 CONSP (tail
) && CONSP (XCDR (tail
));
1935 tail
= XCDR (XCDR (tail
)))
1937 if (! NILP (Fequal (prop
, XCAR (tail
))))
1938 return XCAR (XCDR (tail
));
1943 CHECK_LIST_END (tail
, prop
);
1948 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1949 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1950 PLIST is a property list, which is a list of the form
1951 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1952 If PROP is already a property on the list, its value is set to VAL,
1953 otherwise the new PROP VAL pair is added. The new plist is returned;
1954 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1955 The PLIST is modified by side effects. */)
1956 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1958 register Lisp_Object tail
, prev
;
1959 Lisp_Object newcell
;
1961 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1962 tail
= XCDR (XCDR (tail
)))
1964 if (! NILP (Fequal (prop
, XCAR (tail
))))
1966 Fsetcar (XCDR (tail
), val
);
1973 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1977 Fsetcdr (XCDR (prev
), newcell
);
1981 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1982 doc
: /* Return t if the two args are the same Lisp object.
1983 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1984 (Lisp_Object obj1
, Lisp_Object obj2
)
1987 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1989 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1992 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1993 doc
: /* Return t if two Lisp objects have similar structure and contents.
1994 They must have the same data type.
1995 Conses are compared by comparing the cars and the cdrs.
1996 Vectors and strings are compared element by element.
1997 Numbers are compared by value, but integers cannot equal floats.
1998 (Use `=' if you want integers and floats to be able to be equal.)
1999 Symbols must match exactly. */)
2000 (register Lisp_Object o1
, Lisp_Object o2
)
2002 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2005 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2006 doc
: /* Return t if two Lisp objects have similar structure and contents.
2007 This is like `equal' except that it compares the text properties
2008 of strings. (`equal' ignores text properties.) */)
2009 (register Lisp_Object o1
, Lisp_Object o2
)
2011 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2014 /* DEPTH is current depth of recursion. Signal an error if it
2016 PROPS, if non-nil, means compare string text properties too. */
2019 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2022 error ("Stack overflow in equal");
2028 if (XTYPE (o1
) != XTYPE (o2
))
2037 d1
= extract_float (o1
);
2038 d2
= extract_float (o2
);
2039 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2040 though they are not =. */
2041 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2045 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2052 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2056 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2058 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2061 o1
= XOVERLAY (o1
)->plist
;
2062 o2
= XOVERLAY (o2
)->plist
;
2067 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2068 && (XMARKER (o1
)->buffer
== 0
2069 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2073 case Lisp_Vectorlike
:
2076 EMACS_INT size
= ASIZE (o1
);
2077 /* Pseudovectors have the type encoded in the size field, so this test
2078 actually checks that the objects have the same type as well as the
2080 if (ASIZE (o2
) != size
)
2082 /* Boolvectors are compared much like strings. */
2083 if (BOOL_VECTOR_P (o1
))
2085 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2087 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2088 ((XBOOL_VECTOR (o1
)->size
2089 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2090 / BOOL_VECTOR_BITS_PER_CHAR
)))
2094 if (WINDOW_CONFIGURATIONP (o1
))
2095 return compare_window_configurations (o1
, o2
, 0);
2097 /* Aside from them, only true vectors, char-tables, compiled
2098 functions, and fonts (font-spec, font-entity, font-object)
2099 are sensible to compare, so eliminate the others now. */
2100 if (size
& PSEUDOVECTOR_FLAG
)
2102 if (!(size
& (PVEC_COMPILED
2103 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2105 size
&= PSEUDOVECTOR_SIZE_MASK
;
2107 for (i
= 0; i
< size
; i
++)
2112 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2120 if (SCHARS (o1
) != SCHARS (o2
))
2122 if (SBYTES (o1
) != SBYTES (o2
))
2124 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2126 if (props
&& !compare_string_intervals (o1
, o2
))
2138 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2139 doc
: /* Store each element of ARRAY with ITEM.
2140 ARRAY is a vector, string, char-table, or bool-vector. */)
2141 (Lisp_Object array
, Lisp_Object item
)
2143 register EMACS_INT size
, idx
;
2145 if (VECTORP (array
))
2147 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2148 size
= ASIZE (array
);
2149 for (idx
= 0; idx
< size
; idx
++)
2152 else if (CHAR_TABLE_P (array
))
2156 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2157 XCHAR_TABLE (array
)->contents
[i
] = item
;
2158 XCHAR_TABLE (array
)->defalt
= item
;
2160 else if (STRINGP (array
))
2162 register unsigned char *p
= SDATA (array
);
2164 CHECK_CHARACTER (item
);
2165 charval
= XFASTINT (item
);
2166 size
= SCHARS (array
);
2167 if (STRING_MULTIBYTE (array
))
2169 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2170 int len
= CHAR_STRING (charval
, str
);
2171 EMACS_INT size_byte
= SBYTES (array
);
2173 if (INT_MULTIPLY_OVERFLOW (SCHARS (array
), len
)
2174 || SCHARS (array
) * len
!= size_byte
)
2175 error ("Attempt to change byte length of a string");
2176 for (idx
= 0; idx
< size_byte
; idx
++)
2177 *p
++ = str
[idx
% len
];
2180 for (idx
= 0; idx
< size
; idx
++)
2183 else if (BOOL_VECTOR_P (array
))
2185 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2186 EMACS_INT size
= XBOOL_VECTOR (array
)->size
;
2187 EMACS_INT size_in_chars
2188 = ((size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2189 / BOOL_VECTOR_BITS_PER_CHAR
);
2193 memset (p
, ! NILP (item
) ? -1 : 0, size_in_chars
);
2195 /* Clear any extraneous bits in the last byte. */
2196 p
[size_in_chars
- 1] &= (1 << (size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2200 wrong_type_argument (Qarrayp
, array
);
2204 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2206 doc
: /* Clear the contents of STRING.
2207 This makes STRING unibyte and may change its length. */)
2208 (Lisp_Object string
)
2211 CHECK_STRING (string
);
2212 len
= SBYTES (string
);
2213 memset (SDATA (string
), 0, len
);
2214 STRING_SET_CHARS (string
, len
);
2215 STRING_SET_UNIBYTE (string
);
2221 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2223 Lisp_Object args
[2];
2226 return Fnconc (2, args
);
2229 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2230 doc
: /* Concatenate any number of lists by altering them.
2231 Only the last argument is not altered, and need not be a list.
2232 usage: (nconc &rest LISTS) */)
2233 (ptrdiff_t nargs
, Lisp_Object
*args
)
2236 register Lisp_Object tail
, tem
, val
;
2240 for (argnum
= 0; argnum
< nargs
; argnum
++)
2243 if (NILP (tem
)) continue;
2248 if (argnum
+ 1 == nargs
) break;
2250 CHECK_LIST_CONS (tem
, tem
);
2259 tem
= args
[argnum
+ 1];
2260 Fsetcdr (tail
, tem
);
2262 args
[argnum
+ 1] = tail
;
2268 /* This is the guts of all mapping functions.
2269 Apply FN to each element of SEQ, one by one,
2270 storing the results into elements of VALS, a C vector of Lisp_Objects.
2271 LENI is the length of VALS, which should also be the length of SEQ. */
2274 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2276 register Lisp_Object tail
;
2278 register EMACS_INT i
;
2279 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2283 /* Don't let vals contain any garbage when GC happens. */
2284 for (i
= 0; i
< leni
; i
++)
2287 GCPRO3 (dummy
, fn
, seq
);
2289 gcpro1
.nvars
= leni
;
2293 /* We need not explicitly protect `tail' because it is used only on lists, and
2294 1) lists are not relocated and 2) the list is marked via `seq' so will not
2297 if (VECTORP (seq
) || COMPILEDP (seq
))
2299 for (i
= 0; i
< leni
; i
++)
2301 dummy
= call1 (fn
, AREF (seq
, i
));
2306 else if (BOOL_VECTOR_P (seq
))
2308 for (i
= 0; i
< leni
; i
++)
2311 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2312 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2313 dummy
= call1 (fn
, dummy
);
2318 else if (STRINGP (seq
))
2322 for (i
= 0, i_byte
= 0; i
< leni
;)
2325 EMACS_INT i_before
= i
;
2327 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2328 XSETFASTINT (dummy
, c
);
2329 dummy
= call1 (fn
, dummy
);
2331 vals
[i_before
] = dummy
;
2334 else /* Must be a list, since Flength did not get an error */
2337 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2339 dummy
= call1 (fn
, XCAR (tail
));
2349 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2350 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2351 In between each pair of results, stick in SEPARATOR. Thus, " " as
2352 SEPARATOR results in spaces between the values returned by FUNCTION.
2353 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2354 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2357 register EMACS_INT leni
;
2359 register Lisp_Object
*args
;
2360 struct gcpro gcpro1
;
2364 len
= Flength (sequence
);
2365 if (CHAR_TABLE_P (sequence
))
2366 wrong_type_argument (Qlistp
, sequence
);
2368 nargs
= leni
+ leni
- 1;
2369 if (nargs
< 0) return empty_unibyte_string
;
2371 SAFE_ALLOCA_LISP (args
, nargs
);
2374 mapcar1 (leni
, args
, function
, sequence
);
2377 for (i
= leni
- 1; i
> 0; i
--)
2378 args
[i
+ i
] = args
[i
];
2380 for (i
= 1; i
< nargs
; i
+= 2)
2381 args
[i
] = separator
;
2383 ret
= Fconcat (nargs
, args
);
2389 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2390 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2391 The result is a list just as long as SEQUENCE.
2392 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2393 (Lisp_Object function
, Lisp_Object sequence
)
2395 register Lisp_Object len
;
2396 register EMACS_INT leni
;
2397 register Lisp_Object
*args
;
2401 len
= Flength (sequence
);
2402 if (CHAR_TABLE_P (sequence
))
2403 wrong_type_argument (Qlistp
, sequence
);
2404 leni
= XFASTINT (len
);
2406 SAFE_ALLOCA_LISP (args
, leni
);
2408 mapcar1 (leni
, args
, function
, sequence
);
2410 ret
= Flist (leni
, args
);
2416 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2417 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2418 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2419 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2420 (Lisp_Object function
, Lisp_Object sequence
)
2422 register EMACS_INT leni
;
2424 leni
= XFASTINT (Flength (sequence
));
2425 if (CHAR_TABLE_P (sequence
))
2426 wrong_type_argument (Qlistp
, sequence
);
2427 mapcar1 (leni
, 0, function
, sequence
);
2432 /* This is how C code calls `yes-or-no-p' and allows the user
2435 Anything that calls this function must protect from GC! */
2438 do_yes_or_no_p (Lisp_Object prompt
)
2440 return call1 (intern ("yes-or-no-p"), prompt
);
2443 /* Anything that calls this function must protect from GC! */
2445 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2446 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2447 PROMPT is the string to display to ask the question. It should end in
2448 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2450 The user must confirm the answer with RET, and can edit it until it
2453 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2454 is nil, and `use-dialog-box' is non-nil. */)
2455 (Lisp_Object prompt
)
2457 register Lisp_Object ans
;
2458 Lisp_Object args
[2];
2459 struct gcpro gcpro1
;
2461 CHECK_STRING (prompt
);
2464 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2465 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2469 Lisp_Object pane
, menu
, obj
;
2470 redisplay_preserve_echo_area (4);
2471 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2472 Fcons (Fcons (build_string ("No"), Qnil
),
2475 menu
= Fcons (prompt
, pane
);
2476 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2480 #endif /* HAVE_MENUS */
2483 args
[1] = build_string ("(yes or no) ");
2484 prompt
= Fconcat (2, args
);
2490 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2491 Qyes_or_no_p_history
, Qnil
,
2493 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2498 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2506 message ("Please answer yes or no.");
2507 Fsleep_for (make_number (2), Qnil
);
2511 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2512 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2514 Each of the three load averages is multiplied by 100, then converted
2517 When USE-FLOATS is non-nil, floats will be used instead of integers.
2518 These floats are not multiplied by 100.
2520 If the 5-minute or 15-minute load averages are not available, return a
2521 shortened list, containing only those averages which are available.
2523 An error is thrown if the load average can't be obtained. In some
2524 cases making it work would require Emacs being installed setuid or
2525 setgid so that it can read kernel information, and that usually isn't
2527 (Lisp_Object use_floats
)
2530 int loads
= getloadavg (load_ave
, 3);
2531 Lisp_Object ret
= Qnil
;
2534 error ("load-average not implemented for this operating system");
2538 Lisp_Object load
= (NILP (use_floats
)
2539 ? make_number (100.0 * load_ave
[loads
])
2540 : make_float (load_ave
[loads
]));
2541 ret
= Fcons (load
, ret
);
2547 static Lisp_Object Qsubfeatures
;
2549 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2550 doc
: /* Return t if FEATURE is present in this Emacs.
2552 Use this to conditionalize execution of lisp code based on the
2553 presence or absence of Emacs or environment extensions.
2554 Use `provide' to declare that a feature is available. This function
2555 looks at the value of the variable `features'. The optional argument
2556 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2557 (Lisp_Object feature
, Lisp_Object subfeature
)
2559 register Lisp_Object tem
;
2560 CHECK_SYMBOL (feature
);
2561 tem
= Fmemq (feature
, Vfeatures
);
2562 if (!NILP (tem
) && !NILP (subfeature
))
2563 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2564 return (NILP (tem
)) ? Qnil
: Qt
;
2567 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2568 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2569 The optional argument SUBFEATURES should be a list of symbols listing
2570 particular subfeatures supported in this version of FEATURE. */)
2571 (Lisp_Object feature
, Lisp_Object subfeatures
)
2573 register Lisp_Object tem
;
2574 CHECK_SYMBOL (feature
);
2575 CHECK_LIST (subfeatures
);
2576 if (!NILP (Vautoload_queue
))
2577 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2579 tem
= Fmemq (feature
, Vfeatures
);
2581 Vfeatures
= Fcons (feature
, Vfeatures
);
2582 if (!NILP (subfeatures
))
2583 Fput (feature
, Qsubfeatures
, subfeatures
);
2584 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2586 /* Run any load-hooks for this file. */
2587 tem
= Fassq (feature
, Vafter_load_alist
);
2589 Fprogn (XCDR (tem
));
2594 /* `require' and its subroutines. */
2596 /* List of features currently being require'd, innermost first. */
2598 static Lisp_Object require_nesting_list
;
2601 require_unwind (Lisp_Object old_value
)
2603 return require_nesting_list
= old_value
;
2606 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2607 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2608 If FEATURE is not a member of the list `features', then the feature
2609 is not loaded; so load the file FILENAME.
2610 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2611 and `load' will try to load this name appended with the suffix `.elc' or
2612 `.el', in that order. The name without appended suffix will not be used.
2613 If the optional third argument NOERROR is non-nil,
2614 then return nil if the file is not found instead of signaling an error.
2615 Normally the return value is FEATURE.
2616 The normal messages at start and end of loading FILENAME are suppressed. */)
2617 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2619 register Lisp_Object tem
;
2620 struct gcpro gcpro1
, gcpro2
;
2621 int from_file
= load_in_progress
;
2623 CHECK_SYMBOL (feature
);
2625 /* Record the presence of `require' in this file
2626 even if the feature specified is already loaded.
2627 But not more than once in any file,
2628 and not when we aren't loading or reading from a file. */
2630 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2631 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2636 tem
= Fcons (Qrequire
, feature
);
2637 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2638 LOADHIST_ATTACH (tem
);
2640 tem
= Fmemq (feature
, Vfeatures
);
2644 int count
= SPECPDL_INDEX ();
2647 /* This is to make sure that loadup.el gives a clear picture
2648 of what files are preloaded and when. */
2649 if (! NILP (Vpurify_flag
))
2650 error ("(require %s) while preparing to dump",
2651 SDATA (SYMBOL_NAME (feature
)));
2653 /* A certain amount of recursive `require' is legitimate,
2654 but if we require the same feature recursively 3 times,
2656 tem
= require_nesting_list
;
2657 while (! NILP (tem
))
2659 if (! NILP (Fequal (feature
, XCAR (tem
))))
2664 error ("Recursive `require' for feature `%s'",
2665 SDATA (SYMBOL_NAME (feature
)));
2667 /* Update the list for any nested `require's that occur. */
2668 record_unwind_protect (require_unwind
, require_nesting_list
);
2669 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2671 /* Value saved here is to be restored into Vautoload_queue */
2672 record_unwind_protect (un_autoload
, Vautoload_queue
);
2673 Vautoload_queue
= Qt
;
2675 /* Load the file. */
2676 GCPRO2 (feature
, filename
);
2677 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2678 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2681 /* If load failed entirely, return nil. */
2683 return unbind_to (count
, Qnil
);
2685 tem
= Fmemq (feature
, Vfeatures
);
2687 error ("Required feature `%s' was not provided",
2688 SDATA (SYMBOL_NAME (feature
)));
2690 /* Once loading finishes, don't undo it. */
2691 Vautoload_queue
= Qt
;
2692 feature
= unbind_to (count
, feature
);
2698 /* Primitives for work of the "widget" library.
2699 In an ideal world, this section would not have been necessary.
2700 However, lisp function calls being as slow as they are, it turns
2701 out that some functions in the widget library (wid-edit.el) are the
2702 bottleneck of Widget operation. Here is their translation to C,
2703 for the sole reason of efficiency. */
2705 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2706 doc
: /* Return non-nil if PLIST has the property PROP.
2707 PLIST is a property list, which is a list of the form
2708 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2709 Unlike `plist-get', this allows you to distinguish between a missing
2710 property and a property with the value nil.
2711 The value is actually the tail of PLIST whose car is PROP. */)
2712 (Lisp_Object plist
, Lisp_Object prop
)
2714 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2717 plist
= XCDR (plist
);
2718 plist
= CDR (plist
);
2723 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2724 doc
: /* In WIDGET, set PROPERTY to VALUE.
2725 The value can later be retrieved with `widget-get'. */)
2726 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2728 CHECK_CONS (widget
);
2729 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2733 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2734 doc
: /* In WIDGET, get the value of PROPERTY.
2735 The value could either be specified when the widget was created, or
2736 later with `widget-put'. */)
2737 (Lisp_Object widget
, Lisp_Object property
)
2745 CHECK_CONS (widget
);
2746 tmp
= Fplist_member (XCDR (widget
), property
);
2752 tmp
= XCAR (widget
);
2755 widget
= Fget (tmp
, Qwidget_type
);
2759 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2760 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2761 ARGS are passed as extra arguments to the function.
2762 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2763 (ptrdiff_t nargs
, Lisp_Object
*args
)
2765 /* This function can GC. */
2766 Lisp_Object newargs
[3];
2767 struct gcpro gcpro1
, gcpro2
;
2770 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2771 newargs
[1] = args
[0];
2772 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2773 GCPRO2 (newargs
[0], newargs
[2]);
2774 result
= Fapply (3, newargs
);
2779 #ifdef HAVE_LANGINFO_CODESET
2780 #include <langinfo.h>
2783 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2784 doc
: /* Access locale data ITEM for the current C locale, if available.
2785 ITEM should be one of the following:
2787 `codeset', returning the character set as a string (locale item CODESET);
2789 `days', returning a 7-element vector of day names (locale items DAY_n);
2791 `months', returning a 12-element vector of month names (locale items MON_n);
2793 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2794 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2796 If the system can't provide such information through a call to
2797 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2799 See also Info node `(libc)Locales'.
2801 The data read from the system are decoded using `locale-coding-system'. */)
2805 #ifdef HAVE_LANGINFO_CODESET
2807 if (EQ (item
, Qcodeset
))
2809 str
= nl_langinfo (CODESET
);
2810 return build_string (str
);
2813 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2815 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2816 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2818 struct gcpro gcpro1
;
2820 synchronize_system_time_locale ();
2821 for (i
= 0; i
< 7; i
++)
2823 str
= nl_langinfo (days
[i
]);
2824 val
= make_unibyte_string (str
, strlen (str
));
2825 /* Fixme: Is this coding system necessarily right, even if
2826 it is consistent with CODESET? If not, what to do? */
2827 Faset (v
, make_number (i
),
2828 code_convert_string_norecord (val
, Vlocale_coding_system
,
2836 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2838 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2839 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2840 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2842 struct gcpro gcpro1
;
2844 synchronize_system_time_locale ();
2845 for (i
= 0; i
< 12; i
++)
2847 str
= nl_langinfo (months
[i
]);
2848 val
= make_unibyte_string (str
, strlen (str
));
2849 Faset (v
, make_number (i
),
2850 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2856 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2857 but is in the locale files. This could be used by ps-print. */
2859 else if (EQ (item
, Qpaper
))
2861 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2862 make_number (nl_langinfo (PAPER_HEIGHT
)));
2864 #endif /* PAPER_WIDTH */
2865 #endif /* HAVE_LANGINFO_CODESET*/
2869 /* base64 encode/decode functions (RFC 2045).
2870 Based on code from GNU recode. */
2872 #define MIME_LINE_LENGTH 76
2874 #define IS_ASCII(Character) \
2876 #define IS_BASE64(Character) \
2877 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2878 #define IS_BASE64_IGNORABLE(Character) \
2879 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2880 || (Character) == '\f' || (Character) == '\r')
2882 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2883 character or return retval if there are no characters left to
2885 #define READ_QUADRUPLET_BYTE(retval) \
2890 if (nchars_return) \
2891 *nchars_return = nchars; \
2896 while (IS_BASE64_IGNORABLE (c))
2898 /* Table of characters coding the 64 values. */
2899 static const char base64_value_to_char
[64] =
2901 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2902 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2903 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2904 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2905 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2906 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2907 '8', '9', '+', '/' /* 60-63 */
2910 /* Table of base64 values for first 128 characters. */
2911 static const short base64_char_to_value
[128] =
2913 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2914 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2915 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2916 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2917 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2918 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2919 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2920 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2921 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2922 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2923 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2924 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2925 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2928 /* The following diagram shows the logical steps by which three octets
2929 get transformed into four base64 characters.
2931 .--------. .--------. .--------.
2932 |aaaaaabb| |bbbbcccc| |ccdddddd|
2933 `--------' `--------' `--------'
2935 .--------+--------+--------+--------.
2936 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2937 `--------+--------+--------+--------'
2939 .--------+--------+--------+--------.
2940 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2941 `--------+--------+--------+--------'
2943 The octets are divided into 6 bit chunks, which are then encoded into
2944 base64 characters. */
2947 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2948 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2951 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2953 doc
: /* Base64-encode the region between BEG and END.
2954 Return the length of the encoded text.
2955 Optional third argument NO-LINE-BREAK means do not break long lines
2956 into shorter lines. */)
2957 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2960 EMACS_INT allength
, length
;
2961 EMACS_INT ibeg
, iend
, encoded_length
;
2962 EMACS_INT old_pos
= PT
;
2965 validate_region (&beg
, &end
);
2967 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2968 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2969 move_gap_both (XFASTINT (beg
), ibeg
);
2971 /* We need to allocate enough room for encoding the text.
2972 We need 33 1/3% more space, plus a newline every 76
2973 characters, and then we round up. */
2974 length
= iend
- ibeg
;
2975 allength
= length
+ length
/3 + 1;
2976 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2978 SAFE_ALLOCA (encoded
, char *, allength
);
2979 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2980 encoded
, length
, NILP (no_line_break
),
2981 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2982 if (encoded_length
> allength
)
2985 if (encoded_length
< 0)
2987 /* The encoding wasn't possible. */
2989 error ("Multibyte character in data for base64 encoding");
2992 /* Now we have encoded the region, so we insert the new contents
2993 and delete the old. (Insert first in order to preserve markers.) */
2994 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2995 insert (encoded
, encoded_length
);
2997 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2999 /* If point was outside of the region, restore it exactly; else just
3000 move to the beginning of the region. */
3001 if (old_pos
>= XFASTINT (end
))
3002 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3003 else if (old_pos
> XFASTINT (beg
))
3004 old_pos
= XFASTINT (beg
);
3007 /* We return the length of the encoded text. */
3008 return make_number (encoded_length
);
3011 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3013 doc
: /* Base64-encode STRING and return the result.
3014 Optional second argument NO-LINE-BREAK means do not break long lines
3015 into shorter lines. */)
3016 (Lisp_Object string
, Lisp_Object no_line_break
)
3018 EMACS_INT allength
, length
, encoded_length
;
3020 Lisp_Object encoded_string
;
3023 CHECK_STRING (string
);
3025 /* We need to allocate enough room for encoding the text.
3026 We need 33 1/3% more space, plus a newline every 76
3027 characters, and then we round up. */
3028 length
= SBYTES (string
);
3029 allength
= length
+ length
/3 + 1;
3030 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3032 /* We need to allocate enough room for decoding the text. */
3033 SAFE_ALLOCA (encoded
, char *, allength
);
3035 encoded_length
= base64_encode_1 (SSDATA (string
),
3036 encoded
, length
, NILP (no_line_break
),
3037 STRING_MULTIBYTE (string
));
3038 if (encoded_length
> allength
)
3041 if (encoded_length
< 0)
3043 /* The encoding wasn't possible. */
3045 error ("Multibyte character in data for base64 encoding");
3048 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3051 return encoded_string
;
3055 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3056 int line_break
, int multibyte
)
3069 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3070 if (CHAR_BYTE8_P (c
))
3071 c
= CHAR_TO_BYTE8 (c
);
3079 /* Wrap line every 76 characters. */
3083 if (counter
< MIME_LINE_LENGTH
/ 4)
3092 /* Process first byte of a triplet. */
3094 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3095 value
= (0x03 & c
) << 4;
3097 /* Process second byte of a triplet. */
3101 *e
++ = base64_value_to_char
[value
];
3109 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3110 if (CHAR_BYTE8_P (c
))
3111 c
= CHAR_TO_BYTE8 (c
);
3119 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3120 value
= (0x0f & c
) << 2;
3122 /* Process third byte of a triplet. */
3126 *e
++ = base64_value_to_char
[value
];
3133 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3134 if (CHAR_BYTE8_P (c
))
3135 c
= CHAR_TO_BYTE8 (c
);
3143 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3144 *e
++ = base64_value_to_char
[0x3f & c
];
3151 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3153 doc
: /* Base64-decode the region between BEG and END.
3154 Return the length of the decoded text.
3155 If the region can't be decoded, signal an error and don't modify the buffer. */)
3156 (Lisp_Object beg
, Lisp_Object end
)
3158 EMACS_INT ibeg
, iend
, length
, allength
;
3160 EMACS_INT old_pos
= PT
;
3161 EMACS_INT decoded_length
;
3162 EMACS_INT inserted_chars
;
3163 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3166 validate_region (&beg
, &end
);
3168 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3169 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3171 length
= iend
- ibeg
;
3173 /* We need to allocate enough room for decoding the text. If we are
3174 working on a multibyte buffer, each decoded code may occupy at
3176 allength
= multibyte
? length
* 2 : length
;
3177 SAFE_ALLOCA (decoded
, char *, allength
);
3179 move_gap_both (XFASTINT (beg
), ibeg
);
3180 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3182 multibyte
, &inserted_chars
);
3183 if (decoded_length
> allength
)
3186 if (decoded_length
< 0)
3188 /* The decoding wasn't possible. */
3190 error ("Invalid base64 data");
3193 /* Now we have decoded the region, so we insert the new contents
3194 and delete the old. (Insert first in order to preserve markers.) */
3195 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3196 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3199 /* Delete the original text. */
3200 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3201 iend
+ decoded_length
, 1);
3203 /* If point was outside of the region, restore it exactly; else just
3204 move to the beginning of the region. */
3205 if (old_pos
>= XFASTINT (end
))
3206 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3207 else if (old_pos
> XFASTINT (beg
))
3208 old_pos
= XFASTINT (beg
);
3209 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3211 return make_number (inserted_chars
);
3214 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3216 doc
: /* Base64-decode STRING and return the result. */)
3217 (Lisp_Object string
)
3220 EMACS_INT length
, decoded_length
;
3221 Lisp_Object decoded_string
;
3224 CHECK_STRING (string
);
3226 length
= SBYTES (string
);
3227 /* We need to allocate enough room for decoding the text. */
3228 SAFE_ALLOCA (decoded
, char *, length
);
3230 /* The decoded result should be unibyte. */
3231 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3233 if (decoded_length
> length
)
3235 else if (decoded_length
>= 0)
3236 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3238 decoded_string
= Qnil
;
3241 if (!STRINGP (decoded_string
))
3242 error ("Invalid base64 data");
3244 return decoded_string
;
3247 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3248 MULTIBYTE is nonzero, the decoded result should be in multibyte
3249 form. If NCHARS_RETRUN is not NULL, store the number of produced
3250 characters in *NCHARS_RETURN. */
3253 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3254 int multibyte
, EMACS_INT
*nchars_return
)
3256 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3259 unsigned long value
;
3260 EMACS_INT nchars
= 0;
3264 /* Process first byte of a quadruplet. */
3266 READ_QUADRUPLET_BYTE (e
-to
);
3270 value
= base64_char_to_value
[c
] << 18;
3272 /* Process second byte of a quadruplet. */
3274 READ_QUADRUPLET_BYTE (-1);
3278 value
|= base64_char_to_value
[c
] << 12;
3280 c
= (unsigned char) (value
>> 16);
3281 if (multibyte
&& c
>= 128)
3282 e
+= BYTE8_STRING (c
, e
);
3287 /* Process third byte of a quadruplet. */
3289 READ_QUADRUPLET_BYTE (-1);
3293 READ_QUADRUPLET_BYTE (-1);
3302 value
|= base64_char_to_value
[c
] << 6;
3304 c
= (unsigned char) (0xff & value
>> 8);
3305 if (multibyte
&& c
>= 128)
3306 e
+= BYTE8_STRING (c
, e
);
3311 /* Process fourth byte of a quadruplet. */
3313 READ_QUADRUPLET_BYTE (-1);
3320 value
|= base64_char_to_value
[c
];
3322 c
= (unsigned char) (0xff & value
);
3323 if (multibyte
&& c
>= 128)
3324 e
+= BYTE8_STRING (c
, e
);
3333 /***********************************************************************
3335 ***** Hash Tables *****
3337 ***********************************************************************/
3339 /* Implemented by gerd@gnu.org. This hash table implementation was
3340 inspired by CMUCL hash tables. */
3344 1. For small tables, association lists are probably faster than
3345 hash tables because they have lower overhead.
3347 For uses of hash tables where the O(1) behavior of table
3348 operations is not a requirement, it might therefore be a good idea
3349 not to hash. Instead, we could just do a linear search in the
3350 key_and_value vector of the hash table. This could be done
3351 if a `:linear-search t' argument is given to make-hash-table. */
3354 /* The list of all weak hash tables. Don't staticpro this one. */
3356 static struct Lisp_Hash_Table
*weak_hash_tables
;
3358 /* Various symbols. */
3360 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3361 Lisp_Object Qeq
, Qeql
, Qequal
;
3362 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3363 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3365 /* Function prototypes. */
3367 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3368 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3369 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3370 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3374 /***********************************************************************
3376 ***********************************************************************/
3378 /* If OBJ is a Lisp hash table, return a pointer to its struct
3379 Lisp_Hash_Table. Otherwise, signal an error. */
3381 static struct Lisp_Hash_Table
*
3382 check_hash_table (Lisp_Object obj
)
3384 CHECK_HASH_TABLE (obj
);
3385 return XHASH_TABLE (obj
);
3389 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3393 next_almost_prime (EMACS_INT n
)
3395 for (n
|= 1; ; n
+= 2)
3396 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3401 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3402 which USED[I] is non-zero. If found at index I in ARGS, set
3403 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3404 0. This function is used to extract a keyword/argument pair from
3405 a DEFUN parameter list. */
3408 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3412 for (i
= 1; i
< nargs
; i
++)
3413 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3424 /* Return a Lisp vector which has the same contents as VEC but has
3425 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3426 vector that are not copied from VEC are set to INIT. */
3429 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3431 struct Lisp_Vector
*v
;
3432 EMACS_INT i
, old_size
;
3434 xassert (VECTORP (vec
));
3435 old_size
= ASIZE (vec
);
3436 xassert (new_size
>= old_size
);
3438 v
= allocate_vector (new_size
);
3439 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3440 for (i
= old_size
; i
< new_size
; ++i
)
3441 v
->contents
[i
] = init
;
3442 XSETVECTOR (vec
, v
);
3447 /***********************************************************************
3449 ***********************************************************************/
3451 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3452 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3453 KEY2 are the same. */
3456 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3457 Lisp_Object key1
, EMACS_UINT hash1
,
3458 Lisp_Object key2
, EMACS_UINT hash2
)
3460 return (FLOATP (key1
)
3462 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3466 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3467 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3468 KEY2 are the same. */
3471 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3472 Lisp_Object key1
, EMACS_UINT hash1
,
3473 Lisp_Object key2
, EMACS_UINT hash2
)
3475 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3479 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3480 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3481 if KEY1 and KEY2 are the same. */
3484 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3485 Lisp_Object key1
, EMACS_UINT hash1
,
3486 Lisp_Object key2
, EMACS_UINT hash2
)
3490 Lisp_Object args
[3];
3492 args
[0] = h
->user_cmp_function
;
3495 return !NILP (Ffuncall (3, args
));
3502 /* Value is a hash code for KEY for use in hash table H which uses
3503 `eq' to compare keys. The hash code returned is guaranteed to fit
3504 in a Lisp integer. */
3507 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3509 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3510 xassert ((hash
& ~INTMASK
) == 0);
3515 /* Value is a hash code for KEY for use in hash table H which uses
3516 `eql' to compare keys. The hash code returned is guaranteed to fit
3517 in a Lisp integer. */
3520 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3524 hash
= sxhash (key
, 0);
3526 hash
= XUINT (key
) ^ XTYPE (key
);
3527 xassert ((hash
& ~INTMASK
) == 0);
3532 /* Value is a hash code for KEY for use in hash table H which uses
3533 `equal' to compare keys. The hash code returned is guaranteed to fit
3534 in a Lisp integer. */
3537 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3539 EMACS_UINT hash
= sxhash (key
, 0);
3540 xassert ((hash
& ~INTMASK
) == 0);
3545 /* Value is a hash code for KEY for use in hash table H which uses as
3546 user-defined function to compare keys. The hash code returned is
3547 guaranteed to fit in a Lisp integer. */
3550 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3552 Lisp_Object args
[2], hash
;
3554 args
[0] = h
->user_hash_function
;
3556 hash
= Ffuncall (2, args
);
3557 if (!INTEGERP (hash
))
3558 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3559 return XUINT (hash
);
3563 /* Create and initialize a new hash table.
3565 TEST specifies the test the hash table will use to compare keys.
3566 It must be either one of the predefined tests `eq', `eql' or
3567 `equal' or a symbol denoting a user-defined test named TEST with
3568 test and hash functions USER_TEST and USER_HASH.
3570 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3572 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3573 new size when it becomes full is computed by adding REHASH_SIZE to
3574 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3575 table's new size is computed by multiplying its old size with
3578 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3579 be resized when the ratio of (number of entries in the table) /
3580 (table size) is >= REHASH_THRESHOLD.
3582 WEAK specifies the weakness of the table. If non-nil, it must be
3583 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3586 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3587 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3588 Lisp_Object user_test
, Lisp_Object user_hash
)
3590 struct Lisp_Hash_Table
*h
;
3592 EMACS_INT index_size
, i
, sz
;
3595 /* Preconditions. */
3596 xassert (SYMBOLP (test
));
3597 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3598 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3599 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3600 xassert (FLOATP (rehash_threshold
)
3601 && 0 < XFLOAT_DATA (rehash_threshold
)
3602 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3604 if (XFASTINT (size
) == 0)
3605 size
= make_number (1);
3607 sz
= XFASTINT (size
);
3608 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3609 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3610 ? next_almost_prime (index_float
)
3611 : MOST_POSITIVE_FIXNUM
+ 1);
3612 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3613 error ("Hash table too large");
3615 /* Allocate a table and initialize it. */
3616 h
= allocate_hash_table ();
3618 /* Initialize hash table slots. */
3620 if (EQ (test
, Qeql
))
3622 h
->cmpfn
= cmpfn_eql
;
3623 h
->hashfn
= hashfn_eql
;
3625 else if (EQ (test
, Qeq
))
3628 h
->hashfn
= hashfn_eq
;
3630 else if (EQ (test
, Qequal
))
3632 h
->cmpfn
= cmpfn_equal
;
3633 h
->hashfn
= hashfn_equal
;
3637 h
->user_cmp_function
= user_test
;
3638 h
->user_hash_function
= user_hash
;
3639 h
->cmpfn
= cmpfn_user_defined
;
3640 h
->hashfn
= hashfn_user_defined
;
3644 h
->rehash_threshold
= rehash_threshold
;
3645 h
->rehash_size
= rehash_size
;
3647 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3648 h
->hash
= Fmake_vector (size
, Qnil
);
3649 h
->next
= Fmake_vector (size
, Qnil
);
3650 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3652 /* Set up the free list. */
3653 for (i
= 0; i
< sz
- 1; ++i
)
3654 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3655 h
->next_free
= make_number (0);
3657 XSET_HASH_TABLE (table
, h
);
3658 xassert (HASH_TABLE_P (table
));
3659 xassert (XHASH_TABLE (table
) == h
);
3661 /* Maybe add this hash table to the list of all weak hash tables. */
3663 h
->next_weak
= NULL
;
3666 h
->next_weak
= weak_hash_tables
;
3667 weak_hash_tables
= h
;
3674 /* Return a copy of hash table H1. Keys and values are not copied,
3675 only the table itself is. */
3678 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3681 struct Lisp_Hash_Table
*h2
;
3682 struct Lisp_Vector
*next
;
3684 h2
= allocate_hash_table ();
3685 next
= h2
->header
.next
.vector
;
3686 memcpy (h2
, h1
, sizeof *h2
);
3687 h2
->header
.next
.vector
= next
;
3688 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3689 h2
->hash
= Fcopy_sequence (h1
->hash
);
3690 h2
->next
= Fcopy_sequence (h1
->next
);
3691 h2
->index
= Fcopy_sequence (h1
->index
);
3692 XSET_HASH_TABLE (table
, h2
);
3694 /* Maybe add this hash table to the list of all weak hash tables. */
3695 if (!NILP (h2
->weak
))
3697 h2
->next_weak
= weak_hash_tables
;
3698 weak_hash_tables
= h2
;
3705 /* Resize hash table H if it's too full. If H cannot be resized
3706 because it's already too large, throw an error. */
3709 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3711 if (NILP (h
->next_free
))
3713 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3714 EMACS_INT i
, new_size
, index_size
;
3718 if (INTEGERP (h
->rehash_size
))
3719 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3722 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3723 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3725 new_size
= float_new_size
;
3726 if (new_size
<= old_size
)
3727 new_size
= old_size
+ 1;
3730 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3732 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3733 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3734 ? next_almost_prime (index_float
)
3735 : MOST_POSITIVE_FIXNUM
+ 1);
3736 nsize
= max (index_size
, 2 * new_size
);
3737 if (nsize
> MOST_POSITIVE_FIXNUM
)
3738 error ("Hash table too large to resize");
3740 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3741 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3742 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3743 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3745 /* Update the free list. Do it so that new entries are added at
3746 the end of the free list. This makes some operations like
3748 for (i
= old_size
; i
< new_size
- 1; ++i
)
3749 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3751 if (!NILP (h
->next_free
))
3753 Lisp_Object last
, next
;
3755 last
= h
->next_free
;
3756 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3760 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3763 XSETFASTINT (h
->next_free
, old_size
);
3766 for (i
= 0; i
< old_size
; ++i
)
3767 if (!NILP (HASH_HASH (h
, i
)))
3769 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3770 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3771 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3772 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3778 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3779 the hash code of KEY. Value is the index of the entry in H
3780 matching KEY, or -1 if not found. */
3783 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3785 EMACS_UINT hash_code
;
3786 EMACS_INT start_of_bucket
;
3789 hash_code
= h
->hashfn (h
, key
);
3793 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3794 idx
= HASH_INDEX (h
, start_of_bucket
);
3796 /* We need not gcpro idx since it's either an integer or nil. */
3799 EMACS_INT i
= XFASTINT (idx
);
3800 if (EQ (key
, HASH_KEY (h
, i
))
3802 && h
->cmpfn (h
, key
, hash_code
,
3803 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3805 idx
= HASH_NEXT (h
, i
);
3808 return NILP (idx
) ? -1 : XFASTINT (idx
);
3812 /* Put an entry into hash table H that associates KEY with VALUE.
3813 HASH is a previously computed hash code of KEY.
3814 Value is the index of the entry in H matching KEY. */
3817 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3820 EMACS_INT start_of_bucket
, i
;
3822 xassert ((hash
& ~INTMASK
) == 0);
3824 /* Increment count after resizing because resizing may fail. */
3825 maybe_resize_hash_table (h
);
3828 /* Store key/value in the key_and_value vector. */
3829 i
= XFASTINT (h
->next_free
);
3830 h
->next_free
= HASH_NEXT (h
, i
);
3831 HASH_KEY (h
, i
) = key
;
3832 HASH_VALUE (h
, i
) = value
;
3834 /* Remember its hash code. */
3835 HASH_HASH (h
, i
) = make_number (hash
);
3837 /* Add new entry to its collision chain. */
3838 start_of_bucket
= hash
% ASIZE (h
->index
);
3839 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3840 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3845 /* Remove the entry matching KEY from hash table H, if there is one. */
3848 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3850 EMACS_UINT hash_code
;
3851 EMACS_INT start_of_bucket
;
3852 Lisp_Object idx
, prev
;
3854 hash_code
= h
->hashfn (h
, key
);
3855 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3856 idx
= HASH_INDEX (h
, start_of_bucket
);
3859 /* We need not gcpro idx, prev since they're either integers or nil. */
3862 EMACS_INT i
= XFASTINT (idx
);
3864 if (EQ (key
, HASH_KEY (h
, i
))
3866 && h
->cmpfn (h
, key
, hash_code
,
3867 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3869 /* Take entry out of collision chain. */
3871 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3873 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3875 /* Clear slots in key_and_value and add the slots to
3877 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3878 HASH_NEXT (h
, i
) = h
->next_free
;
3879 h
->next_free
= make_number (i
);
3881 xassert (h
->count
>= 0);
3887 idx
= HASH_NEXT (h
, i
);
3893 /* Clear hash table H. */
3896 hash_clear (struct Lisp_Hash_Table
*h
)
3900 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3902 for (i
= 0; i
< size
; ++i
)
3904 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3905 HASH_KEY (h
, i
) = Qnil
;
3906 HASH_VALUE (h
, i
) = Qnil
;
3907 HASH_HASH (h
, i
) = Qnil
;
3910 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3911 ASET (h
->index
, i
, Qnil
);
3913 h
->next_free
= make_number (0);
3920 /************************************************************************
3922 ************************************************************************/
3925 init_weak_hash_tables (void)
3927 weak_hash_tables
= NULL
;
3930 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3931 entries from the table that don't survive the current GC.
3932 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3933 non-zero if anything was marked. */
3936 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3938 EMACS_INT bucket
, n
;
3941 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3944 for (bucket
= 0; bucket
< n
; ++bucket
)
3946 Lisp_Object idx
, next
, prev
;
3948 /* Follow collision chain, removing entries that
3949 don't survive this garbage collection. */
3951 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3953 EMACS_INT i
= XFASTINT (idx
);
3954 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3955 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3958 if (EQ (h
->weak
, Qkey
))
3959 remove_p
= !key_known_to_survive_p
;
3960 else if (EQ (h
->weak
, Qvalue
))
3961 remove_p
= !value_known_to_survive_p
;
3962 else if (EQ (h
->weak
, Qkey_or_value
))
3963 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3964 else if (EQ (h
->weak
, Qkey_and_value
))
3965 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3969 next
= HASH_NEXT (h
, i
);
3971 if (remove_entries_p
)
3975 /* Take out of collision chain. */
3977 HASH_INDEX (h
, bucket
) = next
;
3979 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3981 /* Add to free list. */
3982 HASH_NEXT (h
, i
) = h
->next_free
;
3985 /* Clear key, value, and hash. */
3986 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3987 HASH_HASH (h
, i
) = Qnil
;
4000 /* Make sure key and value survive. */
4001 if (!key_known_to_survive_p
)
4003 mark_object (HASH_KEY (h
, i
));
4007 if (!value_known_to_survive_p
)
4009 mark_object (HASH_VALUE (h
, i
));
4020 /* Remove elements from weak hash tables that don't survive the
4021 current garbage collection. Remove weak tables that don't survive
4022 from Vweak_hash_tables. Called from gc_sweep. */
4025 sweep_weak_hash_tables (void)
4027 struct Lisp_Hash_Table
*h
, *used
, *next
;
4030 /* Mark all keys and values that are in use. Keep on marking until
4031 there is no more change. This is necessary for cases like
4032 value-weak table A containing an entry X -> Y, where Y is used in a
4033 key-weak table B, Z -> Y. If B comes after A in the list of weak
4034 tables, X -> Y might be removed from A, although when looking at B
4035 one finds that it shouldn't. */
4039 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4041 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4042 marked
|= sweep_weak_table (h
, 0);
4047 /* Remove tables and entries that aren't used. */
4048 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4050 next
= h
->next_weak
;
4052 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4054 /* TABLE is marked as used. Sweep its contents. */
4056 sweep_weak_table (h
, 1);
4058 /* Add table to the list of used weak hash tables. */
4059 h
->next_weak
= used
;
4064 weak_hash_tables
= used
;
4069 /***********************************************************************
4070 Hash Code Computation
4071 ***********************************************************************/
4073 /* Maximum depth up to which to dive into Lisp structures. */
4075 #define SXHASH_MAX_DEPTH 3
4077 /* Maximum length up to which to take list and vector elements into
4080 #define SXHASH_MAX_LEN 7
4082 /* Combine two integers X and Y for hashing. The result might not fit
4083 into a Lisp integer. */
4085 #define SXHASH_COMBINE(X, Y) \
4086 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4089 /* Hash X, returning a value that fits into a Lisp integer. */
4090 #define SXHASH_REDUCE(X) \
4091 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4093 /* Return a hash for string PTR which has length LEN. The hash
4094 code returned is guaranteed to fit in a Lisp integer. */
4097 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4099 unsigned char *p
= ptr
;
4100 unsigned char *end
= p
+ len
;
4102 EMACS_UINT hash
= 0;
4109 hash
= SXHASH_COMBINE (hash
, c
);
4112 return SXHASH_REDUCE (hash
);
4115 /* Return a hash for the floating point value VAL. */
4118 sxhash_float (double val
)
4120 EMACS_UINT hash
= 0;
4122 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4123 + (sizeof val
% sizeof hash
!= 0))
4127 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4131 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4132 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4133 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4134 return SXHASH_REDUCE (hash
);
4137 /* Return a hash for list LIST. DEPTH is the current depth in the
4138 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4141 sxhash_list (Lisp_Object list
, int depth
)
4143 EMACS_UINT hash
= 0;
4146 if (depth
< SXHASH_MAX_DEPTH
)
4148 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4149 list
= XCDR (list
), ++i
)
4151 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4152 hash
= SXHASH_COMBINE (hash
, hash2
);
4157 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4158 hash
= SXHASH_COMBINE (hash
, hash2
);
4161 return SXHASH_REDUCE (hash
);
4165 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4166 the Lisp structure. */
4169 sxhash_vector (Lisp_Object vec
, int depth
)
4171 EMACS_UINT hash
= ASIZE (vec
);
4174 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4175 for (i
= 0; i
< n
; ++i
)
4177 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4178 hash
= SXHASH_COMBINE (hash
, hash2
);
4181 return SXHASH_REDUCE (hash
);
4184 /* Return a hash for bool-vector VECTOR. */
4187 sxhash_bool_vector (Lisp_Object vec
)
4189 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4192 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4193 for (i
= 0; i
< n
; ++i
)
4194 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4196 return SXHASH_REDUCE (hash
);
4200 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4201 structure. Value is an unsigned integer clipped to INTMASK. */
4204 sxhash (Lisp_Object obj
, int depth
)
4208 if (depth
> SXHASH_MAX_DEPTH
)
4211 switch (XTYPE (obj
))
4222 obj
= SYMBOL_NAME (obj
);
4226 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4229 /* This can be everything from a vector to an overlay. */
4230 case Lisp_Vectorlike
:
4232 /* According to the CL HyperSpec, two arrays are equal only if
4233 they are `eq', except for strings and bit-vectors. In
4234 Emacs, this works differently. We have to compare element
4236 hash
= sxhash_vector (obj
, depth
);
4237 else if (BOOL_VECTOR_P (obj
))
4238 hash
= sxhash_bool_vector (obj
);
4240 /* Others are `equal' if they are `eq', so let's take their
4246 hash
= sxhash_list (obj
, depth
);
4250 hash
= sxhash_float (XFLOAT_DATA (obj
));
4262 /***********************************************************************
4264 ***********************************************************************/
4267 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4268 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4271 EMACS_UINT hash
= sxhash (obj
, 0);
4272 return make_number (hash
);
4276 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4277 doc
: /* Create and return a new hash table.
4279 Arguments are specified as keyword/argument pairs. The following
4280 arguments are defined:
4282 :test TEST -- TEST must be a symbol that specifies how to compare
4283 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4284 `equal'. User-supplied test and hash functions can be specified via
4285 `define-hash-table-test'.
4287 :size SIZE -- A hint as to how many elements will be put in the table.
4290 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4291 fills up. If REHASH-SIZE is an integer, increase the size by that
4292 amount. If it is a float, it must be > 1.0, and the new size is the
4293 old size multiplied by that factor. Default is 1.5.
4295 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4296 Resize the hash table when the ratio (number of entries / table size)
4297 is greater than or equal to THRESHOLD. Default is 0.8.
4299 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4300 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4301 returned is a weak table. Key/value pairs are removed from a weak
4302 hash table when there are no non-weak references pointing to their
4303 key, value, one of key or value, or both key and value, depending on
4304 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4307 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4308 (ptrdiff_t nargs
, Lisp_Object
*args
)
4310 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4311 Lisp_Object user_test
, user_hash
;
4315 /* The vector `used' is used to keep track of arguments that
4316 have been consumed. */
4317 used
= (char *) alloca (nargs
* sizeof *used
);
4318 memset (used
, 0, nargs
* sizeof *used
);
4320 /* See if there's a `:test TEST' among the arguments. */
4321 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4322 test
= i
? args
[i
] : Qeql
;
4323 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4325 /* See if it is a user-defined test. */
4328 prop
= Fget (test
, Qhash_table_test
);
4329 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4330 signal_error ("Invalid hash table test", test
);
4331 user_test
= XCAR (prop
);
4332 user_hash
= XCAR (XCDR (prop
));
4335 user_test
= user_hash
= Qnil
;
4337 /* See if there's a `:size SIZE' argument. */
4338 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4339 size
= i
? args
[i
] : Qnil
;
4341 size
= make_number (DEFAULT_HASH_SIZE
);
4342 else if (!INTEGERP (size
) || XINT (size
) < 0)
4343 signal_error ("Invalid hash table size", size
);
4345 /* Look for `:rehash-size SIZE'. */
4346 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4347 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4348 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4349 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4350 signal_error ("Invalid hash table rehash size", rehash_size
);
4352 /* Look for `:rehash-threshold THRESHOLD'. */
4353 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4354 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4355 if (! (FLOATP (rehash_threshold
)
4356 && 0 < XFLOAT_DATA (rehash_threshold
)
4357 && XFLOAT_DATA (rehash_threshold
) <= 1))
4358 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4360 /* Look for `:weakness WEAK'. */
4361 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4362 weak
= i
? args
[i
] : Qnil
;
4364 weak
= Qkey_and_value
;
4367 && !EQ (weak
, Qvalue
)
4368 && !EQ (weak
, Qkey_or_value
)
4369 && !EQ (weak
, Qkey_and_value
))
4370 signal_error ("Invalid hash table weakness", weak
);
4372 /* Now, all args should have been used up, or there's a problem. */
4373 for (i
= 0; i
< nargs
; ++i
)
4375 signal_error ("Invalid argument list", args
[i
]);
4377 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4378 user_test
, user_hash
);
4382 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4383 doc
: /* Return a copy of hash table TABLE. */)
4386 return copy_hash_table (check_hash_table (table
));
4390 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4391 doc
: /* Return the number of elements in TABLE. */)
4394 return make_number (check_hash_table (table
)->count
);
4398 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4399 Shash_table_rehash_size
, 1, 1, 0,
4400 doc
: /* Return the current rehash size of TABLE. */)
4403 return check_hash_table (table
)->rehash_size
;
4407 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4408 Shash_table_rehash_threshold
, 1, 1, 0,
4409 doc
: /* Return the current rehash threshold of TABLE. */)
4412 return check_hash_table (table
)->rehash_threshold
;
4416 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4417 doc
: /* Return the size of TABLE.
4418 The size can be used as an argument to `make-hash-table' to create
4419 a hash table than can hold as many elements as TABLE holds
4420 without need for resizing. */)
4423 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4424 return make_number (HASH_TABLE_SIZE (h
));
4428 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4429 doc
: /* Return the test TABLE uses. */)
4432 return check_hash_table (table
)->test
;
4436 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4438 doc
: /* Return the weakness of TABLE. */)
4441 return check_hash_table (table
)->weak
;
4445 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4446 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4449 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4453 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4454 doc
: /* Clear hash table TABLE and return it. */)
4457 hash_clear (check_hash_table (table
));
4458 /* Be compatible with XEmacs. */
4463 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4464 doc
: /* Look up KEY in TABLE and return its associated value.
4465 If KEY is not found, return DFLT which defaults to nil. */)
4466 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4468 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4469 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4470 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4474 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4475 doc
: /* Associate KEY with VALUE in hash table TABLE.
4476 If KEY is already present in table, replace its current value with
4477 VALUE. In any case, return VALUE. */)
4478 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4480 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4484 i
= hash_lookup (h
, key
, &hash
);
4486 HASH_VALUE (h
, i
) = value
;
4488 hash_put (h
, key
, value
, hash
);
4494 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4495 doc
: /* Remove KEY from TABLE. */)
4496 (Lisp_Object key
, Lisp_Object table
)
4498 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4499 hash_remove_from_table (h
, key
);
4504 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4505 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4506 FUNCTION is called with two arguments, KEY and VALUE. */)
4507 (Lisp_Object function
, Lisp_Object table
)
4509 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4510 Lisp_Object args
[3];
4513 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4514 if (!NILP (HASH_HASH (h
, i
)))
4517 args
[1] = HASH_KEY (h
, i
);
4518 args
[2] = HASH_VALUE (h
, i
);
4526 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4527 Sdefine_hash_table_test
, 3, 3, 0,
4528 doc
: /* Define a new hash table test with name NAME, a symbol.
4530 In hash tables created with NAME specified as test, use TEST to
4531 compare keys, and HASH for computing hash codes of keys.
4533 TEST must be a function taking two arguments and returning non-nil if
4534 both arguments are the same. HASH must be a function taking one
4535 argument and return an integer that is the hash code of the argument.
4536 Hash code computation should use the whole value range of integers,
4537 including negative integers. */)
4538 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4540 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4545 /************************************************************************
4547 ************************************************************************/
4552 /* Convert a possibly-signed character to an unsigned character. This is
4553 a bit safer than casting to unsigned char, since it catches some type
4554 errors that the cast doesn't. */
4555 static inline unsigned char to_uchar (char ch
) { return ch
; }
4557 /* TYPE: 0 for md5, 1 for sha1. */
4560 crypto_hash_function (int type
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4564 EMACS_INT size_byte
= 0;
4565 EMACS_INT start_char
= 0, end_char
= 0;
4566 EMACS_INT start_byte
= 0, end_byte
= 0;
4567 register EMACS_INT b
, e
;
4568 register struct buffer
*bp
;
4570 Lisp_Object res
=Qnil
;
4572 if (STRINGP (object
))
4574 if (NILP (coding_system
))
4576 /* Decide the coding-system to encode the data with. */
4578 if (STRING_MULTIBYTE (object
))
4579 /* use default, we can't guess correct value */
4580 coding_system
= preferred_coding_system ();
4582 coding_system
= Qraw_text
;
4585 if (NILP (Fcoding_system_p (coding_system
)))
4587 /* Invalid coding system. */
4589 if (!NILP (noerror
))
4590 coding_system
= Qraw_text
;
4592 xsignal1 (Qcoding_system_error
, coding_system
);
4595 if (STRING_MULTIBYTE (object
))
4596 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4598 size
= SCHARS (object
);
4599 size_byte
= SBYTES (object
);
4603 CHECK_NUMBER (start
);
4605 start_char
= XINT (start
);
4610 start_byte
= string_char_to_byte (object
, start_char
);
4616 end_byte
= size_byte
;
4622 end_char
= XINT (end
);
4627 end_byte
= string_char_to_byte (object
, end_char
);
4630 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4631 args_out_of_range_3 (object
, make_number (start_char
),
4632 make_number (end_char
));
4636 struct buffer
*prev
= current_buffer
;
4638 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4640 CHECK_BUFFER (object
);
4642 bp
= XBUFFER (object
);
4643 if (bp
!= current_buffer
)
4644 set_buffer_internal (bp
);
4650 CHECK_NUMBER_COERCE_MARKER (start
);
4658 CHECK_NUMBER_COERCE_MARKER (end
);
4663 temp
= b
, b
= e
, e
= temp
;
4665 if (!(BEGV
<= b
&& e
<= ZV
))
4666 args_out_of_range (start
, end
);
4668 if (NILP (coding_system
))
4670 /* Decide the coding-system to encode the data with.
4671 See fileio.c:Fwrite-region */
4673 if (!NILP (Vcoding_system_for_write
))
4674 coding_system
= Vcoding_system_for_write
;
4677 int force_raw_text
= 0;
4679 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4680 if (NILP (coding_system
)
4681 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4683 coding_system
= Qnil
;
4684 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4688 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4690 /* Check file-coding-system-alist. */
4691 Lisp_Object args
[4], val
;
4693 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4694 args
[3] = Fbuffer_file_name(object
);
4695 val
= Ffind_operation_coding_system (4, args
);
4696 if (CONSP (val
) && !NILP (XCDR (val
)))
4697 coding_system
= XCDR (val
);
4700 if (NILP (coding_system
)
4701 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4703 /* If we still have not decided a coding system, use the
4704 default value of buffer-file-coding-system. */
4705 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4709 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4710 /* Confirm that VAL can surely encode the current region. */
4711 coding_system
= call4 (Vselect_safe_coding_system_function
,
4712 make_number (b
), make_number (e
),
4713 coding_system
, Qnil
);
4716 coding_system
= Qraw_text
;
4719 if (NILP (Fcoding_system_p (coding_system
)))
4721 /* Invalid coding system. */
4723 if (!NILP (noerror
))
4724 coding_system
= Qraw_text
;
4726 xsignal1 (Qcoding_system_error
, coding_system
);
4730 object
= make_buffer_string (b
, e
, 0);
4731 if (prev
!= current_buffer
)
4732 set_buffer_internal (prev
);
4733 /* Discard the unwind protect for recovering the current
4737 if (STRING_MULTIBYTE (object
))
4738 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4746 md5_buffer (SSDATA (object
) + start_byte
,
4747 SBYTES (object
) - (size_byte
- end_byte
),
4753 for (i
= 0; i
< 16; i
++)
4754 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4755 res
= make_string (value
, 32);
4758 res
= make_string (digest
, 16);
4765 sha1_buffer (SSDATA (object
) + start_byte
,
4766 SBYTES (object
) - (size_byte
- end_byte
),
4771 for (i
= 0; i
< 20; i
++)
4772 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4773 res
= make_string (value
, 40);
4776 res
= make_string (digest
, 20);
4784 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4785 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4787 A message digest is a cryptographic checksum of a document, and the
4788 algorithm to calculate it is defined in RFC 1321.
4790 The two optional arguments START and END are character positions
4791 specifying for which part of OBJECT the message digest should be
4792 computed. If nil or omitted, the digest is computed for the whole
4795 The MD5 message digest is computed from the result of encoding the
4796 text in a coding system, not directly from the internal Emacs form of
4797 the text. The optional fourth argument CODING-SYSTEM specifies which
4798 coding system to encode the text with. It should be the same coding
4799 system that you used or will use when actually writing the text into a
4802 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4803 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4804 system would be chosen by default for writing this text into a file.
4806 If OBJECT is a string, the most preferred coding system (see the
4807 command `prefer-coding-system') is used.
4809 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4810 guesswork fails. Normally, an error is signaled in such case. */)
4811 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4813 return crypto_hash_function (0, object
, start
, end
, coding_system
, noerror
, Qnil
);
4816 DEFUN ("sha1", Fsha1
, Ssha1
, 1, 4, 0,
4817 doc
: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
4819 OBJECT is either a string or a buffer. Optional arguments START and
4820 END are character positions specifying which portion of OBJECT for
4821 computing the hash. If BINARY is non-nil, return a string in binary
4823 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4825 return crypto_hash_function (1, object
, start
, end
, Qnil
, Qnil
, binary
);
4832 /* Hash table stuff. */
4833 Qhash_table_p
= intern_c_string ("hash-table-p");
4834 staticpro (&Qhash_table_p
);
4835 Qeq
= intern_c_string ("eq");
4837 Qeql
= intern_c_string ("eql");
4839 Qequal
= intern_c_string ("equal");
4840 staticpro (&Qequal
);
4841 QCtest
= intern_c_string (":test");
4842 staticpro (&QCtest
);
4843 QCsize
= intern_c_string (":size");
4844 staticpro (&QCsize
);
4845 QCrehash_size
= intern_c_string (":rehash-size");
4846 staticpro (&QCrehash_size
);
4847 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4848 staticpro (&QCrehash_threshold
);
4849 QCweakness
= intern_c_string (":weakness");
4850 staticpro (&QCweakness
);
4851 Qkey
= intern_c_string ("key");
4853 Qvalue
= intern_c_string ("value");
4854 staticpro (&Qvalue
);
4855 Qhash_table_test
= intern_c_string ("hash-table-test");
4856 staticpro (&Qhash_table_test
);
4857 Qkey_or_value
= intern_c_string ("key-or-value");
4858 staticpro (&Qkey_or_value
);
4859 Qkey_and_value
= intern_c_string ("key-and-value");
4860 staticpro (&Qkey_and_value
);
4863 defsubr (&Smake_hash_table
);
4864 defsubr (&Scopy_hash_table
);
4865 defsubr (&Shash_table_count
);
4866 defsubr (&Shash_table_rehash_size
);
4867 defsubr (&Shash_table_rehash_threshold
);
4868 defsubr (&Shash_table_size
);
4869 defsubr (&Shash_table_test
);
4870 defsubr (&Shash_table_weakness
);
4871 defsubr (&Shash_table_p
);
4872 defsubr (&Sclrhash
);
4873 defsubr (&Sgethash
);
4874 defsubr (&Sputhash
);
4875 defsubr (&Sremhash
);
4876 defsubr (&Smaphash
);
4877 defsubr (&Sdefine_hash_table_test
);
4879 Qstring_lessp
= intern_c_string ("string-lessp");
4880 staticpro (&Qstring_lessp
);
4881 Qprovide
= intern_c_string ("provide");
4882 staticpro (&Qprovide
);
4883 Qrequire
= intern_c_string ("require");
4884 staticpro (&Qrequire
);
4885 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4886 staticpro (&Qyes_or_no_p_history
);
4887 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4888 staticpro (&Qcursor_in_echo_area
);
4889 Qwidget_type
= intern_c_string ("widget-type");
4890 staticpro (&Qwidget_type
);
4892 staticpro (&string_char_byte_cache_string
);
4893 string_char_byte_cache_string
= Qnil
;
4895 require_nesting_list
= Qnil
;
4896 staticpro (&require_nesting_list
);
4898 Fset (Qyes_or_no_p_history
, Qnil
);
4900 DEFVAR_LISP ("features", Vfeatures
,
4901 doc
: /* A list of symbols which are the features of the executing Emacs.
4902 Used by `featurep' and `require', and altered by `provide'. */);
4903 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4904 Qsubfeatures
= intern_c_string ("subfeatures");
4905 staticpro (&Qsubfeatures
);
4907 #ifdef HAVE_LANGINFO_CODESET
4908 Qcodeset
= intern_c_string ("codeset");
4909 staticpro (&Qcodeset
);
4910 Qdays
= intern_c_string ("days");
4912 Qmonths
= intern_c_string ("months");
4913 staticpro (&Qmonths
);
4914 Qpaper
= intern_c_string ("paper");
4915 staticpro (&Qpaper
);
4916 #endif /* HAVE_LANGINFO_CODESET */
4918 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4919 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4920 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4921 invoked by mouse clicks and mouse menu items.
4923 On some platforms, file selection dialogs are also enabled if this is
4927 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4928 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4929 This applies to commands from menus and tool bar buttons even when
4930 they are initiated from the keyboard. If `use-dialog-box' is nil,
4931 that disables the use of a file dialog, regardless of the value of
4933 use_file_dialog
= 1;
4935 defsubr (&Sidentity
);
4938 defsubr (&Ssafe_length
);
4939 defsubr (&Sstring_bytes
);
4940 defsubr (&Sstring_equal
);
4941 defsubr (&Scompare_strings
);
4942 defsubr (&Sstring_lessp
);
4945 defsubr (&Svconcat
);
4946 defsubr (&Scopy_sequence
);
4947 defsubr (&Sstring_make_multibyte
);
4948 defsubr (&Sstring_make_unibyte
);
4949 defsubr (&Sstring_as_multibyte
);
4950 defsubr (&Sstring_as_unibyte
);
4951 defsubr (&Sstring_to_multibyte
);
4952 defsubr (&Sstring_to_unibyte
);
4953 defsubr (&Scopy_alist
);
4954 defsubr (&Ssubstring
);
4955 defsubr (&Ssubstring_no_properties
);
4968 defsubr (&Snreverse
);
4969 defsubr (&Sreverse
);
4971 defsubr (&Splist_get
);
4973 defsubr (&Splist_put
);
4975 defsubr (&Slax_plist_get
);
4976 defsubr (&Slax_plist_put
);
4979 defsubr (&Sequal_including_properties
);
4980 defsubr (&Sfillarray
);
4981 defsubr (&Sclear_string
);
4985 defsubr (&Smapconcat
);
4986 defsubr (&Syes_or_no_p
);
4987 defsubr (&Sload_average
);
4988 defsubr (&Sfeaturep
);
4989 defsubr (&Srequire
);
4990 defsubr (&Sprovide
);
4991 defsubr (&Splist_member
);
4992 defsubr (&Swidget_put
);
4993 defsubr (&Swidget_get
);
4994 defsubr (&Swidget_apply
);
4995 defsubr (&Sbase64_encode_region
);
4996 defsubr (&Sbase64_decode_region
);
4997 defsubr (&Sbase64_encode_string
);
4998 defsubr (&Sbase64_decode_string
);
5001 defsubr (&Slocale_info
);