1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
33 #include "intervals.h"
36 #include "blockinput.h"
38 #if defined (HAVE_X_WINDOWS)
41 #endif /* HAVE_MENUS */
44 #define NULL ((POINTER_TYPE *)0)
47 Lisp_Object Qstring_lessp
;
48 static Lisp_Object Qprovide
, Qrequire
;
49 static Lisp_Object Qyes_or_no_p_history
;
50 Lisp_Object Qcursor_in_echo_area
;
51 static Lisp_Object Qwidget_type
;
52 static Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
54 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
60 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
61 doc
: /* Return the argument unchanged. */)
67 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
68 doc
: /* Return a pseudo-random number.
69 All integers representable in Lisp are equally likely.
70 On most systems, this is 29 bits' worth.
71 With positive integer LIMIT, return random number in interval [0,LIMIT).
72 With argument t, set the random number seed from the current time and pid.
73 Other values of LIMIT are ignored. */)
77 Lisp_Object lispy_val
;
78 EMACS_UINT denominator
;
81 seed_random (getpid () + time (NULL
));
82 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
84 /* Try to take our random number from the higher bits of VAL,
85 not the lower, since (says Gentzel) the low bits of `random'
86 are less random than the higher ones. We do this by using the
87 quotient rather than the remainder. At the high end of the RNG
88 it's possible to get a quotient larger than n; discarding
89 these values eliminates the bias that would otherwise appear
90 when using a large n. */
91 denominator
= ((EMACS_UINT
) 1 << VALBITS
) / XFASTINT (limit
);
93 val
= get_random () / denominator
;
94 while (val
>= XFASTINT (limit
));
98 XSETINT (lispy_val
, val
);
102 /* Random data-structure functions */
104 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
105 doc
: /* Return the length of vector, list or string SEQUENCE.
106 A byte-code function object is also allowed.
107 If the string contains multibyte characters, this is not necessarily
108 the number of bytes in the string; it is the number of characters.
109 To get the number of bytes, use `string-bytes'. */)
110 (register Lisp_Object sequence
)
112 register Lisp_Object val
;
115 if (STRINGP (sequence
))
116 XSETFASTINT (val
, SCHARS (sequence
));
117 else if (VECTORP (sequence
))
118 XSETFASTINT (val
, ASIZE (sequence
));
119 else if (CHAR_TABLE_P (sequence
))
120 XSETFASTINT (val
, MAX_CHAR
);
121 else if (BOOL_VECTOR_P (sequence
))
122 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
123 else if (COMPILEDP (sequence
))
124 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
125 else if (CONSP (sequence
))
128 while (CONSP (sequence
))
130 sequence
= XCDR (sequence
);
133 if (!CONSP (sequence
))
136 sequence
= XCDR (sequence
);
141 CHECK_LIST_END (sequence
, sequence
);
143 val
= make_number (i
);
145 else if (NILP (sequence
))
146 XSETFASTINT (val
, 0);
148 wrong_type_argument (Qsequencep
, sequence
);
153 /* This does not check for quits. That is safe since it must terminate. */
155 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
156 doc
: /* Return the length of a list, but avoid error or infinite loop.
157 This function never gets an error. If LIST is not really a list,
158 it returns 0. If LIST is circular, it returns a finite value
159 which is at least the number of distinct elements. */)
162 Lisp_Object tail
, halftail
, length
;
165 /* halftail is used to detect circular lists. */
167 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
169 if (EQ (tail
, halftail
) && len
!= 0)
173 halftail
= XCDR (halftail
);
176 XSETINT (length
, len
);
180 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
181 doc
: /* Return the number of bytes in STRING.
182 If STRING is multibyte, this may be greater than the length of STRING. */)
185 CHECK_STRING (string
);
186 return make_number (SBYTES (string
));
189 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
190 doc
: /* Return t if two strings have identical contents.
191 Case is significant, but text properties are ignored.
192 Symbols are also allowed; their print names are used instead. */)
193 (register Lisp_Object s1
, Lisp_Object s2
)
196 s1
= SYMBOL_NAME (s1
);
198 s2
= SYMBOL_NAME (s2
);
202 if (SCHARS (s1
) != SCHARS (s2
)
203 || SBYTES (s1
) != SBYTES (s2
)
204 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
209 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
210 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
211 In string STR1, skip the first START1 characters and stop at END1.
212 In string STR2, skip the first START2 characters and stop at END2.
213 END1 and END2 default to the full lengths of the respective strings.
215 Case is significant in this comparison if IGNORE-CASE is nil.
216 Unibyte strings are converted to multibyte for comparison.
218 The value is t if the strings (or specified portions) match.
219 If string STR1 is less, the value is a negative number N;
220 - 1 - N is the number of characters that match at the beginning.
221 If string STR1 is greater, the value is a positive number N;
222 N - 1 is the number of characters that match at the beginning. */)
223 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
225 register EMACS_INT end1_char
, end2_char
;
226 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
231 start1
= make_number (0);
233 start2
= make_number (0);
234 CHECK_NATNUM (start1
);
235 CHECK_NATNUM (start2
);
244 i1_byte
= string_char_to_byte (str1
, i1
);
245 i2_byte
= string_char_to_byte (str2
, i2
);
247 end1_char
= SCHARS (str1
);
248 if (! NILP (end1
) && end1_char
> XINT (end1
))
249 end1_char
= XINT (end1
);
251 end2_char
= SCHARS (str2
);
252 if (! NILP (end2
) && end2_char
> XINT (end2
))
253 end2_char
= XINT (end2
);
255 while (i1
< end1_char
&& i2
< end2_char
)
257 /* When we find a mismatch, we must compare the
258 characters, not just the bytes. */
261 if (STRING_MULTIBYTE (str1
))
262 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
265 c1
= SREF (str1
, i1
++);
266 MAKE_CHAR_MULTIBYTE (c1
);
269 if (STRING_MULTIBYTE (str2
))
270 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
273 c2
= SREF (str2
, i2
++);
274 MAKE_CHAR_MULTIBYTE (c2
);
280 if (! NILP (ignore_case
))
284 tem
= Fupcase (make_number (c1
));
286 tem
= Fupcase (make_number (c2
));
293 /* Note that I1 has already been incremented
294 past the character that we are comparing;
295 hence we don't add or subtract 1 here. */
297 return make_number (- i1
+ XINT (start1
));
299 return make_number (i1
- XINT (start1
));
303 return make_number (i1
- XINT (start1
) + 1);
305 return make_number (- i1
+ XINT (start1
) - 1);
310 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
311 doc
: /* Return t if first arg string is less than second in lexicographic order.
313 Symbols are also allowed; their print names are used instead. */)
314 (register Lisp_Object s1
, Lisp_Object s2
)
316 register EMACS_INT end
;
317 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
320 s1
= SYMBOL_NAME (s1
);
322 s2
= SYMBOL_NAME (s2
);
326 i1
= i1_byte
= i2
= i2_byte
= 0;
329 if (end
> SCHARS (s2
))
334 /* When we find a mismatch, we must compare the
335 characters, not just the bytes. */
338 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
339 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
342 return c1
< c2
? Qt
: Qnil
;
344 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
347 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
348 enum Lisp_Type target_type
, int last_special
);
352 concat2 (Lisp_Object s1
, Lisp_Object s2
)
357 return concat (2, args
, Lisp_String
, 0);
362 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
368 return concat (3, args
, Lisp_String
, 0);
371 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
372 doc
: /* Concatenate all the arguments and make the result a list.
373 The result is a list whose elements are the elements of all the arguments.
374 Each argument may be a list, vector or string.
375 The last argument is not copied, just used as the tail of the new list.
376 usage: (append &rest SEQUENCES) */)
377 (ptrdiff_t nargs
, Lisp_Object
*args
)
379 return concat (nargs
, args
, Lisp_Cons
, 1);
382 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
383 doc
: /* Concatenate all the arguments and make the result a string.
384 The result is a string whose elements are the elements of all the arguments.
385 Each argument may be a string or a list or vector of characters (integers).
386 usage: (concat &rest SEQUENCES) */)
387 (ptrdiff_t nargs
, Lisp_Object
*args
)
389 return concat (nargs
, args
, Lisp_String
, 0);
392 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
393 doc
: /* Concatenate all the arguments and make the result a vector.
394 The result is a vector whose elements are the elements of all the arguments.
395 Each argument may be a list, vector or string.
396 usage: (vconcat &rest SEQUENCES) */)
397 (ptrdiff_t nargs
, Lisp_Object
*args
)
399 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
403 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
404 doc
: /* Return a copy of a list, vector, string or char-table.
405 The elements of a list or vector are not copied; they are shared
406 with the original. */)
409 if (NILP (arg
)) return arg
;
411 if (CHAR_TABLE_P (arg
))
413 return copy_char_table (arg
);
416 if (BOOL_VECTOR_P (arg
))
420 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
421 / BOOL_VECTOR_BITS_PER_CHAR
);
423 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
424 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
429 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
430 wrong_type_argument (Qsequencep
, arg
);
432 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
435 /* This structure holds information of an argument of `concat' that is
436 a string and has text properties to be copied. */
439 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
440 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
441 EMACS_INT to
; /* refer to VAL (the target string) */
445 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
446 enum Lisp_Type target_type
, int last_special
)
449 register Lisp_Object tail
;
450 register Lisp_Object
this;
452 EMACS_INT toindex_byte
= 0;
453 register EMACS_INT result_len
;
454 register EMACS_INT result_len_byte
;
456 Lisp_Object last_tail
;
459 /* When we make a multibyte string, we can't copy text properties
460 while concatenating each string because the length of resulting
461 string can't be decided until we finish the whole concatenation.
462 So, we record strings that have text properties to be copied
463 here, and copy the text properties after the concatenation. */
464 struct textprop_rec
*textprops
= NULL
;
465 /* Number of elements in textprops. */
466 ptrdiff_t num_textprops
= 0;
471 /* In append, the last arg isn't treated like the others */
472 if (last_special
&& nargs
> 0)
475 last_tail
= args
[nargs
];
480 /* Check each argument. */
481 for (argnum
= 0; argnum
< nargs
; argnum
++)
484 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
485 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
486 wrong_type_argument (Qsequencep
, this);
489 /* Compute total length in chars of arguments in RESULT_LEN.
490 If desired output is a string, also compute length in bytes
491 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
492 whether the result should be a multibyte string. */
496 for (argnum
= 0; argnum
< nargs
; argnum
++)
500 len
= XFASTINT (Flength (this));
501 if (target_type
== Lisp_String
)
503 /* We must count the number of bytes needed in the string
504 as well as the number of characters. */
508 EMACS_INT this_len_byte
;
510 if (VECTORP (this) || COMPILEDP (this))
511 for (i
= 0; i
< len
; i
++)
514 CHECK_CHARACTER (ch
);
516 this_len_byte
= CHAR_BYTES (c
);
517 result_len_byte
+= this_len_byte
;
518 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
521 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
522 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
523 else if (CONSP (this))
524 for (; CONSP (this); this = XCDR (this))
527 CHECK_CHARACTER (ch
);
529 this_len_byte
= CHAR_BYTES (c
);
530 result_len_byte
+= this_len_byte
;
531 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
534 else if (STRINGP (this))
536 if (STRING_MULTIBYTE (this))
539 result_len_byte
+= SBYTES (this);
542 result_len_byte
+= count_size_as_multibyte (SDATA (this),
549 error ("String overflow");
552 if (! some_multibyte
)
553 result_len_byte
= result_len
;
555 /* Create the output object. */
556 if (target_type
== Lisp_Cons
)
557 val
= Fmake_list (make_number (result_len
), Qnil
);
558 else if (target_type
== Lisp_Vectorlike
)
559 val
= Fmake_vector (make_number (result_len
), Qnil
);
560 else if (some_multibyte
)
561 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
563 val
= make_uninit_string (result_len
);
565 /* In `append', if all but last arg are nil, return last arg. */
566 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
569 /* Copy the contents of the args into the result. */
571 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
573 toindex
= 0, toindex_byte
= 0;
577 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
579 for (argnum
= 0; argnum
< nargs
; argnum
++)
582 EMACS_INT thisleni
= 0;
583 register EMACS_INT thisindex
= 0;
584 register EMACS_INT thisindex_byte
= 0;
588 thislen
= Flength (this), thisleni
= XINT (thislen
);
590 /* Between strings of the same kind, copy fast. */
591 if (STRINGP (this) && STRINGP (val
)
592 && STRING_MULTIBYTE (this) == some_multibyte
)
594 EMACS_INT thislen_byte
= SBYTES (this);
596 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
597 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
599 textprops
[num_textprops
].argnum
= argnum
;
600 textprops
[num_textprops
].from
= 0;
601 textprops
[num_textprops
++].to
= toindex
;
603 toindex_byte
+= thislen_byte
;
606 /* Copy a single-byte string to a multibyte string. */
607 else if (STRINGP (this) && STRINGP (val
))
609 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
611 textprops
[num_textprops
].argnum
= argnum
;
612 textprops
[num_textprops
].from
= 0;
613 textprops
[num_textprops
++].to
= toindex
;
615 toindex_byte
+= copy_text (SDATA (this),
616 SDATA (val
) + toindex_byte
,
617 SCHARS (this), 0, 1);
621 /* Copy element by element. */
624 register Lisp_Object elt
;
626 /* Fetch next element of `this' arg into `elt', or break if
627 `this' is exhausted. */
628 if (NILP (this)) break;
630 elt
= XCAR (this), this = XCDR (this);
631 else if (thisindex
>= thisleni
)
633 else if (STRINGP (this))
636 if (STRING_MULTIBYTE (this))
637 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
642 c
= SREF (this, thisindex
); thisindex
++;
643 if (some_multibyte
&& !ASCII_CHAR_P (c
))
644 c
= BYTE8_TO_CHAR (c
);
646 XSETFASTINT (elt
, c
);
648 else if (BOOL_VECTOR_P (this))
651 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
652 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
660 elt
= AREF (this, thisindex
);
664 /* Store this element into the result. */
671 else if (VECTORP (val
))
673 ASET (val
, toindex
, elt
);
679 CHECK_CHARACTER (elt
);
682 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
684 SSET (val
, toindex_byte
++, c
);
690 XSETCDR (prev
, last_tail
);
692 if (num_textprops
> 0)
695 EMACS_INT last_to_end
= -1;
697 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
699 this = args
[textprops
[argnum
].argnum
];
700 props
= text_property_list (this,
702 make_number (SCHARS (this)),
704 /* If successive arguments have properties, be sure that the
705 value of `composition' property be the copy. */
706 if (last_to_end
== textprops
[argnum
].to
)
707 make_composition_value_copy (props
);
708 add_text_properties_from_list (val
, props
,
709 make_number (textprops
[argnum
].to
));
710 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
718 static Lisp_Object string_char_byte_cache_string
;
719 static EMACS_INT string_char_byte_cache_charpos
;
720 static EMACS_INT string_char_byte_cache_bytepos
;
723 clear_string_char_byte_cache (void)
725 string_char_byte_cache_string
= Qnil
;
728 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
731 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
734 EMACS_INT best_below
, best_below_byte
;
735 EMACS_INT best_above
, best_above_byte
;
737 best_below
= best_below_byte
= 0;
738 best_above
= SCHARS (string
);
739 best_above_byte
= SBYTES (string
);
740 if (best_above
== best_above_byte
)
743 if (EQ (string
, string_char_byte_cache_string
))
745 if (string_char_byte_cache_charpos
< char_index
)
747 best_below
= string_char_byte_cache_charpos
;
748 best_below_byte
= string_char_byte_cache_bytepos
;
752 best_above
= string_char_byte_cache_charpos
;
753 best_above_byte
= string_char_byte_cache_bytepos
;
757 if (char_index
- best_below
< best_above
- char_index
)
759 unsigned char *p
= SDATA (string
) + best_below_byte
;
761 while (best_below
< char_index
)
763 p
+= BYTES_BY_CHAR_HEAD (*p
);
766 i_byte
= p
- SDATA (string
);
770 unsigned char *p
= SDATA (string
) + best_above_byte
;
772 while (best_above
> char_index
)
775 while (!CHAR_HEAD_P (*p
)) p
--;
778 i_byte
= p
- SDATA (string
);
781 string_char_byte_cache_bytepos
= i_byte
;
782 string_char_byte_cache_charpos
= char_index
;
783 string_char_byte_cache_string
= string
;
788 /* Return the character index corresponding to BYTE_INDEX in STRING. */
791 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
794 EMACS_INT best_below
, best_below_byte
;
795 EMACS_INT best_above
, best_above_byte
;
797 best_below
= best_below_byte
= 0;
798 best_above
= SCHARS (string
);
799 best_above_byte
= SBYTES (string
);
800 if (best_above
== best_above_byte
)
803 if (EQ (string
, string_char_byte_cache_string
))
805 if (string_char_byte_cache_bytepos
< byte_index
)
807 best_below
= string_char_byte_cache_charpos
;
808 best_below_byte
= string_char_byte_cache_bytepos
;
812 best_above
= string_char_byte_cache_charpos
;
813 best_above_byte
= string_char_byte_cache_bytepos
;
817 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
819 unsigned char *p
= SDATA (string
) + best_below_byte
;
820 unsigned char *pend
= SDATA (string
) + byte_index
;
824 p
+= BYTES_BY_CHAR_HEAD (*p
);
828 i_byte
= p
- SDATA (string
);
832 unsigned char *p
= SDATA (string
) + best_above_byte
;
833 unsigned char *pbeg
= SDATA (string
) + byte_index
;
838 while (!CHAR_HEAD_P (*p
)) p
--;
842 i_byte
= p
- SDATA (string
);
845 string_char_byte_cache_bytepos
= i_byte
;
846 string_char_byte_cache_charpos
= i
;
847 string_char_byte_cache_string
= string
;
852 /* Convert STRING to a multibyte string. */
855 string_make_multibyte (Lisp_Object string
)
862 if (STRING_MULTIBYTE (string
))
865 nbytes
= count_size_as_multibyte (SDATA (string
),
867 /* If all the chars are ASCII, they won't need any more bytes
868 once converted. In that case, we can return STRING itself. */
869 if (nbytes
== SBYTES (string
))
872 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
873 copy_text (SDATA (string
), buf
, SBYTES (string
),
876 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
883 /* Convert STRING (if unibyte) to a multibyte string without changing
884 the number of characters. Characters 0200 trough 0237 are
885 converted to eight-bit characters. */
888 string_to_multibyte (Lisp_Object string
)
895 if (STRING_MULTIBYTE (string
))
898 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
899 /* If all the chars are ASCII, they won't need any more bytes once
901 if (nbytes
== SBYTES (string
))
902 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
904 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
905 memcpy (buf
, SDATA (string
), SBYTES (string
));
906 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
908 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
915 /* Convert STRING to a single-byte string. */
918 string_make_unibyte (Lisp_Object string
)
925 if (! STRING_MULTIBYTE (string
))
928 nchars
= SCHARS (string
);
930 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
931 copy_text (SDATA (string
), buf
, SBYTES (string
),
934 ret
= make_unibyte_string ((char *) buf
, nchars
);
940 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
942 doc
: /* Return the multibyte equivalent of STRING.
943 If STRING is unibyte and contains non-ASCII characters, the function
944 `unibyte-char-to-multibyte' is used to convert each unibyte character
945 to a multibyte character. In this case, the returned string is a
946 newly created string with no text properties. If STRING is multibyte
947 or entirely ASCII, it is returned unchanged. In particular, when
948 STRING is unibyte and entirely ASCII, the returned string is unibyte.
949 \(When the characters are all ASCII, Emacs primitives will treat the
950 string the same way whether it is unibyte or multibyte.) */)
953 CHECK_STRING (string
);
955 return string_make_multibyte (string
);
958 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
960 doc
: /* Return the unibyte equivalent of STRING.
961 Multibyte character codes are converted to unibyte according to
962 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
963 If the lookup in the translation table fails, this function takes just
964 the low 8 bits of each character. */)
967 CHECK_STRING (string
);
969 return string_make_unibyte (string
);
972 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
974 doc
: /* Return a unibyte string with the same individual bytes as STRING.
975 If STRING is unibyte, the result is STRING itself.
976 Otherwise it is a newly created string, with no text properties.
977 If STRING is multibyte and contains a character of charset
978 `eight-bit', it is converted to the corresponding single byte. */)
981 CHECK_STRING (string
);
983 if (STRING_MULTIBYTE (string
))
985 EMACS_INT bytes
= SBYTES (string
);
986 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
988 memcpy (str
, SDATA (string
), bytes
);
989 bytes
= str_as_unibyte (str
, bytes
);
990 string
= make_unibyte_string ((char *) str
, bytes
);
996 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
998 doc
: /* Return a multibyte string with the same individual bytes as STRING.
999 If STRING is multibyte, the result is STRING itself.
1000 Otherwise it is a newly created string, with no text properties.
1002 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1003 part of a correct utf-8 sequence), it is converted to the corresponding
1004 multibyte character of charset `eight-bit'.
1005 See also `string-to-multibyte'.
1007 Beware, this often doesn't really do what you think it does.
1008 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1009 If you're not sure, whether to use `string-as-multibyte' or
1010 `string-to-multibyte', use `string-to-multibyte'. */)
1011 (Lisp_Object string
)
1013 CHECK_STRING (string
);
1015 if (! STRING_MULTIBYTE (string
))
1017 Lisp_Object new_string
;
1018 EMACS_INT nchars
, nbytes
;
1020 parse_str_as_multibyte (SDATA (string
),
1023 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1024 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1025 if (nbytes
!= SBYTES (string
))
1026 str_as_multibyte (SDATA (new_string
), nbytes
,
1027 SBYTES (string
), NULL
);
1028 string
= new_string
;
1029 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1034 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1036 doc
: /* Return a multibyte string with the same individual chars as STRING.
1037 If STRING is multibyte, the result is STRING itself.
1038 Otherwise it is a newly created string, with no text properties.
1040 If STRING is unibyte and contains an 8-bit byte, it is converted to
1041 the corresponding multibyte character of charset `eight-bit'.
1043 This differs from `string-as-multibyte' by converting each byte of a correct
1044 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1045 correct sequence. */)
1046 (Lisp_Object string
)
1048 CHECK_STRING (string
);
1050 return string_to_multibyte (string
);
1053 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1055 doc
: /* Return a unibyte string with the same individual chars as STRING.
1056 If STRING is unibyte, the result is STRING itself.
1057 Otherwise it is a newly created string, with no text properties,
1058 where each `eight-bit' character is converted to the corresponding byte.
1059 If STRING contains a non-ASCII, non-`eight-bit' character,
1060 an error is signaled. */)
1061 (Lisp_Object string
)
1063 CHECK_STRING (string
);
1065 if (STRING_MULTIBYTE (string
))
1067 EMACS_INT chars
= SCHARS (string
);
1068 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1069 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1071 if (converted
< chars
)
1072 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1073 string
= make_unibyte_string ((char *) str
, chars
);
1080 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1081 doc
: /* Return a copy of ALIST.
1082 This is an alist which represents the same mapping from objects to objects,
1083 but does not share the alist structure with ALIST.
1084 The objects mapped (cars and cdrs of elements of the alist)
1085 are shared, however.
1086 Elements of ALIST that are not conses are also shared. */)
1089 register Lisp_Object tem
;
1094 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1095 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1097 register Lisp_Object car
;
1101 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1106 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1107 doc
: /* Return a new string whose contents are a substring of STRING.
1108 The returned string consists of the characters between index FROM
1109 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1110 zero-indexed: 0 means the first character of STRING. Negative values
1111 are counted from the end of STRING. If TO is nil, the substring runs
1112 to the end of STRING.
1114 The STRING argument may also be a vector. In that case, the return
1115 value is a new vector that contains the elements between index FROM
1116 \(inclusive) and index TO (exclusive) of that vector argument. */)
1117 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1121 EMACS_INT size_byte
= 0;
1122 EMACS_INT from_char
, to_char
;
1123 EMACS_INT from_byte
= 0, to_byte
= 0;
1125 CHECK_VECTOR_OR_STRING (string
);
1126 CHECK_NUMBER (from
);
1128 if (STRINGP (string
))
1130 size
= SCHARS (string
);
1131 size_byte
= SBYTES (string
);
1134 size
= ASIZE (string
);
1139 to_byte
= size_byte
;
1145 to_char
= XINT (to
);
1149 if (STRINGP (string
))
1150 to_byte
= string_char_to_byte (string
, to_char
);
1153 from_char
= XINT (from
);
1156 if (STRINGP (string
))
1157 from_byte
= string_char_to_byte (string
, from_char
);
1159 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1160 args_out_of_range_3 (string
, make_number (from_char
),
1161 make_number (to_char
));
1163 if (STRINGP (string
))
1165 res
= make_specified_string (SSDATA (string
) + from_byte
,
1166 to_char
- from_char
, to_byte
- from_byte
,
1167 STRING_MULTIBYTE (string
));
1168 copy_text_properties (make_number (from_char
), make_number (to_char
),
1169 string
, make_number (0), res
, Qnil
);
1172 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1178 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1179 doc
: /* Return a substring of STRING, without text properties.
1180 It starts at index FROM and ends before TO.
1181 TO may be nil or omitted; then the substring runs to the end of STRING.
1182 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1183 If FROM or TO is negative, it counts from the end.
1185 With one argument, just copy STRING without its properties. */)
1186 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1188 EMACS_INT size
, size_byte
;
1189 EMACS_INT from_char
, to_char
;
1190 EMACS_INT from_byte
, to_byte
;
1192 CHECK_STRING (string
);
1194 size
= SCHARS (string
);
1195 size_byte
= SBYTES (string
);
1198 from_char
= from_byte
= 0;
1201 CHECK_NUMBER (from
);
1202 from_char
= XINT (from
);
1206 from_byte
= string_char_to_byte (string
, from_char
);
1212 to_byte
= size_byte
;
1218 to_char
= XINT (to
);
1222 to_byte
= string_char_to_byte (string
, to_char
);
1225 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1226 args_out_of_range_3 (string
, make_number (from_char
),
1227 make_number (to_char
));
1229 return make_specified_string (SSDATA (string
) + from_byte
,
1230 to_char
- from_char
, to_byte
- from_byte
,
1231 STRING_MULTIBYTE (string
));
1234 /* Extract a substring of STRING, giving start and end positions
1235 both in characters and in bytes. */
1238 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1239 EMACS_INT to
, EMACS_INT to_byte
)
1244 CHECK_VECTOR_OR_STRING (string
);
1246 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1248 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1249 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1251 if (STRINGP (string
))
1253 res
= make_specified_string (SSDATA (string
) + from_byte
,
1254 to
- from
, to_byte
- from_byte
,
1255 STRING_MULTIBYTE (string
));
1256 copy_text_properties (make_number (from
), make_number (to
),
1257 string
, make_number (0), res
, Qnil
);
1260 res
= Fvector (to
- from
, &AREF (string
, from
));
1265 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1266 doc
: /* Take cdr N times on LIST, return the result. */)
1267 (Lisp_Object n
, Lisp_Object list
)
1269 register int i
, num
;
1272 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1275 CHECK_LIST_CONS (list
, list
);
1281 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1282 doc
: /* Return the Nth element of LIST.
1283 N counts from zero. If LIST is not that long, nil is returned. */)
1284 (Lisp_Object n
, Lisp_Object list
)
1286 return Fcar (Fnthcdr (n
, list
));
1289 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1290 doc
: /* Return element of SEQUENCE at index N. */)
1291 (register Lisp_Object sequence
, Lisp_Object n
)
1294 if (CONSP (sequence
) || NILP (sequence
))
1295 return Fcar (Fnthcdr (n
, sequence
));
1297 /* Faref signals a "not array" error, so check here. */
1298 CHECK_ARRAY (sequence
, Qsequencep
);
1299 return Faref (sequence
, n
);
1302 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1303 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1304 The value is actually the tail of LIST whose car is ELT. */)
1305 (register Lisp_Object elt
, Lisp_Object list
)
1307 register Lisp_Object tail
;
1308 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1310 register Lisp_Object tem
;
1311 CHECK_LIST_CONS (tail
, list
);
1313 if (! NILP (Fequal (elt
, tem
)))
1320 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1321 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1322 The value is actually the tail of LIST whose car is ELT. */)
1323 (register Lisp_Object elt
, Lisp_Object list
)
1327 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1331 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1335 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1346 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1347 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1348 The value is actually the tail of LIST whose car is ELT. */)
1349 (register Lisp_Object elt
, Lisp_Object list
)
1351 register Lisp_Object tail
;
1354 return Fmemq (elt
, list
);
1356 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1358 register Lisp_Object tem
;
1359 CHECK_LIST_CONS (tail
, list
);
1361 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1368 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1369 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1370 The value is actually the first element of LIST whose car is KEY.
1371 Elements of LIST that are not conses are ignored. */)
1372 (Lisp_Object key
, Lisp_Object list
)
1377 || (CONSP (XCAR (list
))
1378 && EQ (XCAR (XCAR (list
)), key
)))
1383 || (CONSP (XCAR (list
))
1384 && EQ (XCAR (XCAR (list
)), key
)))
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1400 /* Like Fassq but never report an error and do not allow quits.
1401 Use only on lists known never to be circular. */
1404 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1407 && (!CONSP (XCAR (list
))
1408 || !EQ (XCAR (XCAR (list
)), key
)))
1411 return CAR_SAFE (list
);
1414 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1415 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1416 The value is actually the first element of LIST whose car equals KEY. */)
1417 (Lisp_Object key
, Lisp_Object list
)
1424 || (CONSP (XCAR (list
))
1425 && (car
= XCAR (XCAR (list
)),
1426 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1431 || (CONSP (XCAR (list
))
1432 && (car
= XCAR (XCAR (list
)),
1433 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1438 || (CONSP (XCAR (list
))
1439 && (car
= XCAR (XCAR (list
)),
1440 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1450 /* Like Fassoc but never report an error and do not allow quits.
1451 Use only on lists known never to be circular. */
1454 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1457 && (!CONSP (XCAR (list
))
1458 || (!EQ (XCAR (XCAR (list
)), key
)
1459 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1462 return CONSP (list
) ? XCAR (list
) : Qnil
;
1465 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1466 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1467 The value is actually the first element of LIST whose cdr is KEY. */)
1468 (register Lisp_Object key
, Lisp_Object list
)
1473 || (CONSP (XCAR (list
))
1474 && EQ (XCDR (XCAR (list
)), key
)))
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCDR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCDR (XCAR (list
)), key
)))
1496 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1497 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1498 The value is actually the first element of LIST whose cdr equals KEY. */)
1499 (Lisp_Object key
, Lisp_Object list
)
1506 || (CONSP (XCAR (list
))
1507 && (cdr
= XCDR (XCAR (list
)),
1508 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1513 || (CONSP (XCAR (list
))
1514 && (cdr
= XCDR (XCAR (list
)),
1515 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1520 || (CONSP (XCAR (list
))
1521 && (cdr
= XCDR (XCAR (list
)),
1522 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1532 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1533 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1534 The modified LIST is returned. Comparison is done with `eq'.
1535 If the first member of LIST is ELT, there is no way to remove it by side effect;
1536 therefore, write `(setq foo (delq element foo))'
1537 to be sure of changing the value of `foo'. */)
1538 (register Lisp_Object elt
, Lisp_Object list
)
1540 register Lisp_Object tail
, prev
;
1541 register Lisp_Object tem
;
1545 while (!NILP (tail
))
1547 CHECK_LIST_CONS (tail
, list
);
1554 Fsetcdr (prev
, XCDR (tail
));
1564 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1565 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1566 SEQ must be a list, a vector, or a string.
1567 The modified SEQ is returned. Comparison is done with `equal'.
1568 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1569 is not a side effect; it is simply using a different sequence.
1570 Therefore, write `(setq foo (delete element foo))'
1571 to be sure of changing the value of `foo'. */)
1572 (Lisp_Object elt
, Lisp_Object seq
)
1578 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1579 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1582 if (n
!= ASIZE (seq
))
1584 struct Lisp_Vector
*p
= allocate_vector (n
);
1586 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1587 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1588 p
->contents
[n
++] = AREF (seq
, i
);
1590 XSETVECTOR (seq
, p
);
1593 else if (STRINGP (seq
))
1595 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1598 for (i
= nchars
= nbytes
= ibyte
= 0;
1600 ++i
, ibyte
+= cbytes
)
1602 if (STRING_MULTIBYTE (seq
))
1604 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1605 cbytes
= CHAR_BYTES (c
);
1613 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1620 if (nchars
!= SCHARS (seq
))
1624 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1625 if (!STRING_MULTIBYTE (seq
))
1626 STRING_SET_UNIBYTE (tem
);
1628 for (i
= nchars
= nbytes
= ibyte
= 0;
1630 ++i
, ibyte
+= cbytes
)
1632 if (STRING_MULTIBYTE (seq
))
1634 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1635 cbytes
= CHAR_BYTES (c
);
1643 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1645 unsigned char *from
= SDATA (seq
) + ibyte
;
1646 unsigned char *to
= SDATA (tem
) + nbytes
;
1652 for (n
= cbytes
; n
--; )
1662 Lisp_Object tail
, prev
;
1664 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1666 CHECK_LIST_CONS (tail
, seq
);
1668 if (!NILP (Fequal (elt
, XCAR (tail
))))
1673 Fsetcdr (prev
, XCDR (tail
));
1684 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1685 doc
: /* Reverse LIST by modifying cdr pointers.
1686 Return the reversed list. */)
1689 register Lisp_Object prev
, tail
, next
;
1691 if (NILP (list
)) return list
;
1694 while (!NILP (tail
))
1697 CHECK_LIST_CONS (tail
, list
);
1699 Fsetcdr (tail
, prev
);
1706 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1707 doc
: /* Reverse LIST, copying. Return the reversed list.
1708 See also the function `nreverse', which is used more often. */)
1713 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1716 new = Fcons (XCAR (list
), new);
1718 CHECK_LIST_END (list
, list
);
1722 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1724 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1725 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1726 Returns the sorted list. LIST is modified by side effects.
1727 PREDICATE is called with two elements of LIST, and should return non-nil
1728 if the first element should sort before the second. */)
1729 (Lisp_Object list
, Lisp_Object predicate
)
1731 Lisp_Object front
, back
;
1732 register Lisp_Object len
, tem
;
1733 struct gcpro gcpro1
, gcpro2
;
1734 register int length
;
1737 len
= Flength (list
);
1738 length
= XINT (len
);
1742 XSETINT (len
, (length
/ 2) - 1);
1743 tem
= Fnthcdr (len
, list
);
1745 Fsetcdr (tem
, Qnil
);
1747 GCPRO2 (front
, back
);
1748 front
= Fsort (front
, predicate
);
1749 back
= Fsort (back
, predicate
);
1751 return merge (front
, back
, predicate
);
1755 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1758 register Lisp_Object tail
;
1760 register Lisp_Object l1
, l2
;
1761 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1768 /* It is sufficient to protect org_l1 and org_l2.
1769 When l1 and l2 are updated, we copy the new values
1770 back into the org_ vars. */
1771 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1791 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1807 Fsetcdr (tail
, tem
);
1813 /* This does not check for quits. That is safe since it must terminate. */
1815 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1816 doc
: /* Extract a value from a property list.
1817 PLIST is a property list, which is a list of the form
1818 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1819 corresponding to the given PROP, or nil if PROP is not one of the
1820 properties on the list. This function never signals an error. */)
1821 (Lisp_Object plist
, Lisp_Object prop
)
1823 Lisp_Object tail
, halftail
;
1825 /* halftail is used to detect circular lists. */
1826 tail
= halftail
= plist
;
1827 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1829 if (EQ (prop
, XCAR (tail
)))
1830 return XCAR (XCDR (tail
));
1832 tail
= XCDR (XCDR (tail
));
1833 halftail
= XCDR (halftail
);
1834 if (EQ (tail
, halftail
))
1837 #if 0 /* Unsafe version. */
1838 /* This function can be called asynchronously
1839 (setup_coding_system). Don't QUIT in that case. */
1840 if (!interrupt_input_blocked
)
1848 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1849 doc
: /* Return the value of SYMBOL's PROPNAME property.
1850 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1851 (Lisp_Object symbol
, Lisp_Object propname
)
1853 CHECK_SYMBOL (symbol
);
1854 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1857 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1858 doc
: /* Change value in PLIST of PROP to VAL.
1859 PLIST is a property list, which is a list of the form
1860 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1861 If PROP is already a property on the list, its value is set to VAL,
1862 otherwise the new PROP VAL pair is added. The new plist is returned;
1863 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1864 The PLIST is modified by side effects. */)
1865 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1867 register Lisp_Object tail
, prev
;
1868 Lisp_Object newcell
;
1870 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1871 tail
= XCDR (XCDR (tail
)))
1873 if (EQ (prop
, XCAR (tail
)))
1875 Fsetcar (XCDR (tail
), val
);
1882 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1886 Fsetcdr (XCDR (prev
), newcell
);
1890 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1891 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1892 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1893 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1895 CHECK_SYMBOL (symbol
);
1896 XSYMBOL (symbol
)->plist
1897 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1901 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1902 doc
: /* Extract a value from a property list, comparing with `equal'.
1903 PLIST is a property list, which is a list of the form
1904 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1905 corresponding to the given PROP, or nil if PROP is not
1906 one of the properties on the list. */)
1907 (Lisp_Object plist
, Lisp_Object prop
)
1912 CONSP (tail
) && CONSP (XCDR (tail
));
1913 tail
= XCDR (XCDR (tail
)))
1915 if (! NILP (Fequal (prop
, XCAR (tail
))))
1916 return XCAR (XCDR (tail
));
1921 CHECK_LIST_END (tail
, prop
);
1926 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1927 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1928 PLIST is a property list, which is a list of the form
1929 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1930 If PROP is already a property on the list, its value is set to VAL,
1931 otherwise the new PROP VAL pair is added. The new plist is returned;
1932 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1933 The PLIST is modified by side effects. */)
1934 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1936 register Lisp_Object tail
, prev
;
1937 Lisp_Object newcell
;
1939 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1940 tail
= XCDR (XCDR (tail
)))
1942 if (! NILP (Fequal (prop
, XCAR (tail
))))
1944 Fsetcar (XCDR (tail
), val
);
1951 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1955 Fsetcdr (XCDR (prev
), newcell
);
1959 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1960 doc
: /* Return t if the two args are the same Lisp object.
1961 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1962 (Lisp_Object obj1
, Lisp_Object obj2
)
1965 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1967 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1970 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1971 doc
: /* Return t if two Lisp objects have similar structure and contents.
1972 They must have the same data type.
1973 Conses are compared by comparing the cars and the cdrs.
1974 Vectors and strings are compared element by element.
1975 Numbers are compared by value, but integers cannot equal floats.
1976 (Use `=' if you want integers and floats to be able to be equal.)
1977 Symbols must match exactly. */)
1978 (register Lisp_Object o1
, Lisp_Object o2
)
1980 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1983 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1984 doc
: /* Return t if two Lisp objects have similar structure and contents.
1985 This is like `equal' except that it compares the text properties
1986 of strings. (`equal' ignores text properties.) */)
1987 (register Lisp_Object o1
, Lisp_Object o2
)
1989 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
1992 /* DEPTH is current depth of recursion. Signal an error if it
1994 PROPS, if non-nil, means compare string text properties too. */
1997 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2000 error ("Stack overflow in equal");
2006 if (XTYPE (o1
) != XTYPE (o2
))
2015 d1
= extract_float (o1
);
2016 d2
= extract_float (o2
);
2017 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2018 though they are not =. */
2019 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2023 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2030 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2034 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2036 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2039 o1
= XOVERLAY (o1
)->plist
;
2040 o2
= XOVERLAY (o2
)->plist
;
2045 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2046 && (XMARKER (o1
)->buffer
== 0
2047 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2051 case Lisp_Vectorlike
:
2054 EMACS_INT size
= ASIZE (o1
);
2055 /* Pseudovectors have the type encoded in the size field, so this test
2056 actually checks that the objects have the same type as well as the
2058 if (ASIZE (o2
) != size
)
2060 /* Boolvectors are compared much like strings. */
2061 if (BOOL_VECTOR_P (o1
))
2063 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2065 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2066 ((XBOOL_VECTOR (o1
)->size
2067 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2068 / BOOL_VECTOR_BITS_PER_CHAR
)))
2072 if (WINDOW_CONFIGURATIONP (o1
))
2073 return compare_window_configurations (o1
, o2
, 0);
2075 /* Aside from them, only true vectors, char-tables, compiled
2076 functions, and fonts (font-spec, font-entity, font-object)
2077 are sensible to compare, so eliminate the others now. */
2078 if (size
& PSEUDOVECTOR_FLAG
)
2080 if (!(size
& (PVEC_COMPILED
2081 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2083 size
&= PSEUDOVECTOR_SIZE_MASK
;
2085 for (i
= 0; i
< size
; i
++)
2090 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2098 if (SCHARS (o1
) != SCHARS (o2
))
2100 if (SBYTES (o1
) != SBYTES (o2
))
2102 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2104 if (props
&& !compare_string_intervals (o1
, o2
))
2116 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2117 doc
: /* Store each element of ARRAY with ITEM.
2118 ARRAY is a vector, string, char-table, or bool-vector. */)
2119 (Lisp_Object array
, Lisp_Object item
)
2121 register EMACS_INT size
, idx
;
2124 if (VECTORP (array
))
2126 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2127 size
= ASIZE (array
);
2128 for (idx
= 0; idx
< size
; idx
++)
2131 else if (CHAR_TABLE_P (array
))
2135 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2136 XCHAR_TABLE (array
)->contents
[i
] = item
;
2137 XCHAR_TABLE (array
)->defalt
= item
;
2139 else if (STRINGP (array
))
2141 register unsigned char *p
= SDATA (array
);
2142 CHECK_NUMBER (item
);
2143 charval
= XINT (item
);
2144 size
= SCHARS (array
);
2145 if (STRING_MULTIBYTE (array
))
2147 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2148 int len
= CHAR_STRING (charval
, str
);
2149 EMACS_INT size_byte
= SBYTES (array
);
2150 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2153 if (size
!= size_byte
)
2156 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2157 if (len
!= this_len
)
2158 error ("Attempt to change byte length of a string");
2161 for (i
= 0; i
< size_byte
; i
++)
2162 *p
++ = str
[i
% len
];
2165 for (idx
= 0; idx
< size
; idx
++)
2168 else if (BOOL_VECTOR_P (array
))
2170 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2172 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2173 / BOOL_VECTOR_BITS_PER_CHAR
);
2175 charval
= (! NILP (item
) ? -1 : 0);
2176 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2178 if (idx
< size_in_chars
)
2180 /* Mask out bits beyond the vector size. */
2181 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2182 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2187 wrong_type_argument (Qarrayp
, array
);
2191 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2193 doc
: /* Clear the contents of STRING.
2194 This makes STRING unibyte and may change its length. */)
2195 (Lisp_Object string
)
2198 CHECK_STRING (string
);
2199 len
= SBYTES (string
);
2200 memset (SDATA (string
), 0, len
);
2201 STRING_SET_CHARS (string
, len
);
2202 STRING_SET_UNIBYTE (string
);
2208 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2210 Lisp_Object args
[2];
2213 return Fnconc (2, args
);
2216 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2217 doc
: /* Concatenate any number of lists by altering them.
2218 Only the last argument is not altered, and need not be a list.
2219 usage: (nconc &rest LISTS) */)
2220 (ptrdiff_t nargs
, Lisp_Object
*args
)
2223 register Lisp_Object tail
, tem
, val
;
2227 for (argnum
= 0; argnum
< nargs
; argnum
++)
2230 if (NILP (tem
)) continue;
2235 if (argnum
+ 1 == nargs
) break;
2237 CHECK_LIST_CONS (tem
, tem
);
2246 tem
= args
[argnum
+ 1];
2247 Fsetcdr (tail
, tem
);
2249 args
[argnum
+ 1] = tail
;
2255 /* This is the guts of all mapping functions.
2256 Apply FN to each element of SEQ, one by one,
2257 storing the results into elements of VALS, a C vector of Lisp_Objects.
2258 LENI is the length of VALS, which should also be the length of SEQ. */
2261 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2263 register Lisp_Object tail
;
2265 register EMACS_INT i
;
2266 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2270 /* Don't let vals contain any garbage when GC happens. */
2271 for (i
= 0; i
< leni
; i
++)
2274 GCPRO3 (dummy
, fn
, seq
);
2276 gcpro1
.nvars
= leni
;
2280 /* We need not explicitly protect `tail' because it is used only on lists, and
2281 1) lists are not relocated and 2) the list is marked via `seq' so will not
2284 if (VECTORP (seq
) || COMPILEDP (seq
))
2286 for (i
= 0; i
< leni
; i
++)
2288 dummy
= call1 (fn
, AREF (seq
, i
));
2293 else if (BOOL_VECTOR_P (seq
))
2295 for (i
= 0; i
< leni
; i
++)
2298 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2299 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2300 dummy
= call1 (fn
, dummy
);
2305 else if (STRINGP (seq
))
2309 for (i
= 0, i_byte
= 0; i
< leni
;)
2312 EMACS_INT i_before
= i
;
2314 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2315 XSETFASTINT (dummy
, c
);
2316 dummy
= call1 (fn
, dummy
);
2318 vals
[i_before
] = dummy
;
2321 else /* Must be a list, since Flength did not get an error */
2324 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2326 dummy
= call1 (fn
, XCAR (tail
));
2336 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2337 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2338 In between each pair of results, stick in SEPARATOR. Thus, " " as
2339 SEPARATOR results in spaces between the values returned by FUNCTION.
2340 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2341 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2344 register EMACS_INT leni
;
2346 register Lisp_Object
*args
;
2347 struct gcpro gcpro1
;
2351 len
= Flength (sequence
);
2352 if (CHAR_TABLE_P (sequence
))
2353 wrong_type_argument (Qlistp
, sequence
);
2355 nargs
= leni
+ leni
- 1;
2356 if (nargs
< 0) return empty_unibyte_string
;
2358 SAFE_ALLOCA_LISP (args
, nargs
);
2361 mapcar1 (leni
, args
, function
, sequence
);
2364 for (i
= leni
- 1; i
> 0; i
--)
2365 args
[i
+ i
] = args
[i
];
2367 for (i
= 1; i
< nargs
; i
+= 2)
2368 args
[i
] = separator
;
2370 ret
= Fconcat (nargs
, args
);
2376 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2377 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2378 The result is a list just as long as SEQUENCE.
2379 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2380 (Lisp_Object function
, Lisp_Object sequence
)
2382 register Lisp_Object len
;
2383 register EMACS_INT leni
;
2384 register Lisp_Object
*args
;
2388 len
= Flength (sequence
);
2389 if (CHAR_TABLE_P (sequence
))
2390 wrong_type_argument (Qlistp
, sequence
);
2391 leni
= XFASTINT (len
);
2393 SAFE_ALLOCA_LISP (args
, leni
);
2395 mapcar1 (leni
, args
, function
, sequence
);
2397 ret
= Flist (leni
, args
);
2403 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2404 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2405 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2406 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2407 (Lisp_Object function
, Lisp_Object sequence
)
2409 register EMACS_INT leni
;
2411 leni
= XFASTINT (Flength (sequence
));
2412 if (CHAR_TABLE_P (sequence
))
2413 wrong_type_argument (Qlistp
, sequence
);
2414 mapcar1 (leni
, 0, function
, sequence
);
2419 /* This is how C code calls `yes-or-no-p' and allows the user
2422 Anything that calls this function must protect from GC! */
2425 do_yes_or_no_p (Lisp_Object prompt
)
2427 return call1 (intern ("yes-or-no-p"), prompt
);
2430 /* Anything that calls this function must protect from GC! */
2432 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2433 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2434 PROMPT is the string to display to ask the question. It should end in
2435 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2437 The user must confirm the answer with RET, and can edit it until it
2440 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2441 is nil, and `use-dialog-box' is non-nil. */)
2442 (Lisp_Object prompt
)
2444 register Lisp_Object ans
;
2445 Lisp_Object args
[2];
2446 struct gcpro gcpro1
;
2448 CHECK_STRING (prompt
);
2451 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2452 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2456 Lisp_Object pane
, menu
, obj
;
2457 redisplay_preserve_echo_area (4);
2458 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2459 Fcons (Fcons (build_string ("No"), Qnil
),
2462 menu
= Fcons (prompt
, pane
);
2463 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2467 #endif /* HAVE_MENUS */
2470 args
[1] = build_string ("(yes or no) ");
2471 prompt
= Fconcat (2, args
);
2477 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2478 Qyes_or_no_p_history
, Qnil
,
2480 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2485 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2493 message ("Please answer yes or no.");
2494 Fsleep_for (make_number (2), Qnil
);
2498 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2499 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2501 Each of the three load averages is multiplied by 100, then converted
2504 When USE-FLOATS is non-nil, floats will be used instead of integers.
2505 These floats are not multiplied by 100.
2507 If the 5-minute or 15-minute load averages are not available, return a
2508 shortened list, containing only those averages which are available.
2510 An error is thrown if the load average can't be obtained. In some
2511 cases making it work would require Emacs being installed setuid or
2512 setgid so that it can read kernel information, and that usually isn't
2514 (Lisp_Object use_floats
)
2517 int loads
= getloadavg (load_ave
, 3);
2518 Lisp_Object ret
= Qnil
;
2521 error ("load-average not implemented for this operating system");
2525 Lisp_Object load
= (NILP (use_floats
) ?
2526 make_number ((int) (100.0 * load_ave
[loads
]))
2527 : make_float (load_ave
[loads
]));
2528 ret
= Fcons (load
, ret
);
2534 static Lisp_Object Qsubfeatures
;
2536 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2537 doc
: /* Return t if FEATURE is present in this Emacs.
2539 Use this to conditionalize execution of lisp code based on the
2540 presence or absence of Emacs or environment extensions.
2541 Use `provide' to declare that a feature is available. This function
2542 looks at the value of the variable `features'. The optional argument
2543 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2544 (Lisp_Object feature
, Lisp_Object subfeature
)
2546 register Lisp_Object tem
;
2547 CHECK_SYMBOL (feature
);
2548 tem
= Fmemq (feature
, Vfeatures
);
2549 if (!NILP (tem
) && !NILP (subfeature
))
2550 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2551 return (NILP (tem
)) ? Qnil
: Qt
;
2554 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2555 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2556 The optional argument SUBFEATURES should be a list of symbols listing
2557 particular subfeatures supported in this version of FEATURE. */)
2558 (Lisp_Object feature
, Lisp_Object subfeatures
)
2560 register Lisp_Object tem
;
2561 CHECK_SYMBOL (feature
);
2562 CHECK_LIST (subfeatures
);
2563 if (!NILP (Vautoload_queue
))
2564 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2566 tem
= Fmemq (feature
, Vfeatures
);
2568 Vfeatures
= Fcons (feature
, Vfeatures
);
2569 if (!NILP (subfeatures
))
2570 Fput (feature
, Qsubfeatures
, subfeatures
);
2571 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2573 /* Run any load-hooks for this file. */
2574 tem
= Fassq (feature
, Vafter_load_alist
);
2576 Fprogn (XCDR (tem
));
2581 /* `require' and its subroutines. */
2583 /* List of features currently being require'd, innermost first. */
2585 static Lisp_Object require_nesting_list
;
2588 require_unwind (Lisp_Object old_value
)
2590 return require_nesting_list
= old_value
;
2593 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2594 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2595 If FEATURE is not a member of the list `features', then the feature
2596 is not loaded; so load the file FILENAME.
2597 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2598 and `load' will try to load this name appended with the suffix `.elc' or
2599 `.el', in that order. The name without appended suffix will not be used.
2600 If the optional third argument NOERROR is non-nil,
2601 then return nil if the file is not found instead of signaling an error.
2602 Normally the return value is FEATURE.
2603 The normal messages at start and end of loading FILENAME are suppressed. */)
2604 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2606 register Lisp_Object tem
;
2607 struct gcpro gcpro1
, gcpro2
;
2608 int from_file
= load_in_progress
;
2610 CHECK_SYMBOL (feature
);
2612 /* Record the presence of `require' in this file
2613 even if the feature specified is already loaded.
2614 But not more than once in any file,
2615 and not when we aren't loading or reading from a file. */
2617 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2618 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2623 tem
= Fcons (Qrequire
, feature
);
2624 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2625 LOADHIST_ATTACH (tem
);
2627 tem
= Fmemq (feature
, Vfeatures
);
2631 int count
= SPECPDL_INDEX ();
2634 /* This is to make sure that loadup.el gives a clear picture
2635 of what files are preloaded and when. */
2636 if (! NILP (Vpurify_flag
))
2637 error ("(require %s) while preparing to dump",
2638 SDATA (SYMBOL_NAME (feature
)));
2640 /* A certain amount of recursive `require' is legitimate,
2641 but if we require the same feature recursively 3 times,
2643 tem
= require_nesting_list
;
2644 while (! NILP (tem
))
2646 if (! NILP (Fequal (feature
, XCAR (tem
))))
2651 error ("Recursive `require' for feature `%s'",
2652 SDATA (SYMBOL_NAME (feature
)));
2654 /* Update the list for any nested `require's that occur. */
2655 record_unwind_protect (require_unwind
, require_nesting_list
);
2656 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2658 /* Value saved here is to be restored into Vautoload_queue */
2659 record_unwind_protect (un_autoload
, Vautoload_queue
);
2660 Vautoload_queue
= Qt
;
2662 /* Load the file. */
2663 GCPRO2 (feature
, filename
);
2664 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2665 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2668 /* If load failed entirely, return nil. */
2670 return unbind_to (count
, Qnil
);
2672 tem
= Fmemq (feature
, Vfeatures
);
2674 error ("Required feature `%s' was not provided",
2675 SDATA (SYMBOL_NAME (feature
)));
2677 /* Once loading finishes, don't undo it. */
2678 Vautoload_queue
= Qt
;
2679 feature
= unbind_to (count
, feature
);
2685 /* Primitives for work of the "widget" library.
2686 In an ideal world, this section would not have been necessary.
2687 However, lisp function calls being as slow as they are, it turns
2688 out that some functions in the widget library (wid-edit.el) are the
2689 bottleneck of Widget operation. Here is their translation to C,
2690 for the sole reason of efficiency. */
2692 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2693 doc
: /* Return non-nil if PLIST has the property PROP.
2694 PLIST is a property list, which is a list of the form
2695 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2696 Unlike `plist-get', this allows you to distinguish between a missing
2697 property and a property with the value nil.
2698 The value is actually the tail of PLIST whose car is PROP. */)
2699 (Lisp_Object plist
, Lisp_Object prop
)
2701 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2704 plist
= XCDR (plist
);
2705 plist
= CDR (plist
);
2710 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2711 doc
: /* In WIDGET, set PROPERTY to VALUE.
2712 The value can later be retrieved with `widget-get'. */)
2713 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2715 CHECK_CONS (widget
);
2716 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2720 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2721 doc
: /* In WIDGET, get the value of PROPERTY.
2722 The value could either be specified when the widget was created, or
2723 later with `widget-put'. */)
2724 (Lisp_Object widget
, Lisp_Object property
)
2732 CHECK_CONS (widget
);
2733 tmp
= Fplist_member (XCDR (widget
), property
);
2739 tmp
= XCAR (widget
);
2742 widget
= Fget (tmp
, Qwidget_type
);
2746 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2747 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2748 ARGS are passed as extra arguments to the function.
2749 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2750 (ptrdiff_t nargs
, Lisp_Object
*args
)
2752 /* This function can GC. */
2753 Lisp_Object newargs
[3];
2754 struct gcpro gcpro1
, gcpro2
;
2757 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2758 newargs
[1] = args
[0];
2759 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2760 GCPRO2 (newargs
[0], newargs
[2]);
2761 result
= Fapply (3, newargs
);
2766 #ifdef HAVE_LANGINFO_CODESET
2767 #include <langinfo.h>
2770 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2771 doc
: /* Access locale data ITEM for the current C locale, if available.
2772 ITEM should be one of the following:
2774 `codeset', returning the character set as a string (locale item CODESET);
2776 `days', returning a 7-element vector of day names (locale items DAY_n);
2778 `months', returning a 12-element vector of month names (locale items MON_n);
2780 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2781 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2783 If the system can't provide such information through a call to
2784 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2786 See also Info node `(libc)Locales'.
2788 The data read from the system are decoded using `locale-coding-system'. */)
2792 #ifdef HAVE_LANGINFO_CODESET
2794 if (EQ (item
, Qcodeset
))
2796 str
= nl_langinfo (CODESET
);
2797 return build_string (str
);
2800 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2802 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2803 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2805 struct gcpro gcpro1
;
2807 synchronize_system_time_locale ();
2808 for (i
= 0; i
< 7; i
++)
2810 str
= nl_langinfo (days
[i
]);
2811 val
= make_unibyte_string (str
, strlen (str
));
2812 /* Fixme: Is this coding system necessarily right, even if
2813 it is consistent with CODESET? If not, what to do? */
2814 Faset (v
, make_number (i
),
2815 code_convert_string_norecord (val
, Vlocale_coding_system
,
2823 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2825 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2826 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2827 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2829 struct gcpro gcpro1
;
2831 synchronize_system_time_locale ();
2832 for (i
= 0; i
< 12; i
++)
2834 str
= nl_langinfo (months
[i
]);
2835 val
= make_unibyte_string (str
, strlen (str
));
2836 Faset (v
, make_number (i
),
2837 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2843 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2844 but is in the locale files. This could be used by ps-print. */
2846 else if (EQ (item
, Qpaper
))
2848 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2849 make_number (nl_langinfo (PAPER_HEIGHT
)));
2851 #endif /* PAPER_WIDTH */
2852 #endif /* HAVE_LANGINFO_CODESET*/
2856 /* base64 encode/decode functions (RFC 2045).
2857 Based on code from GNU recode. */
2859 #define MIME_LINE_LENGTH 76
2861 #define IS_ASCII(Character) \
2863 #define IS_BASE64(Character) \
2864 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2865 #define IS_BASE64_IGNORABLE(Character) \
2866 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2867 || (Character) == '\f' || (Character) == '\r')
2869 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2870 character or return retval if there are no characters left to
2872 #define READ_QUADRUPLET_BYTE(retval) \
2877 if (nchars_return) \
2878 *nchars_return = nchars; \
2883 while (IS_BASE64_IGNORABLE (c))
2885 /* Table of characters coding the 64 values. */
2886 static const char base64_value_to_char
[64] =
2888 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2889 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2890 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2891 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2892 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2893 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2894 '8', '9', '+', '/' /* 60-63 */
2897 /* Table of base64 values for first 128 characters. */
2898 static const short base64_char_to_value
[128] =
2900 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2901 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2902 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2903 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2904 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2905 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2906 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2907 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2908 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2909 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2910 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2911 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2912 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2915 /* The following diagram shows the logical steps by which three octets
2916 get transformed into four base64 characters.
2918 .--------. .--------. .--------.
2919 |aaaaaabb| |bbbbcccc| |ccdddddd|
2920 `--------' `--------' `--------'
2922 .--------+--------+--------+--------.
2923 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2924 `--------+--------+--------+--------'
2926 .--------+--------+--------+--------.
2927 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2928 `--------+--------+--------+--------'
2930 The octets are divided into 6 bit chunks, which are then encoded into
2931 base64 characters. */
2934 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2935 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2938 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2940 doc
: /* Base64-encode the region between BEG and END.
2941 Return the length of the encoded text.
2942 Optional third argument NO-LINE-BREAK means do not break long lines
2943 into shorter lines. */)
2944 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2947 EMACS_INT allength
, length
;
2948 EMACS_INT ibeg
, iend
, encoded_length
;
2949 EMACS_INT old_pos
= PT
;
2952 validate_region (&beg
, &end
);
2954 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2955 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2956 move_gap_both (XFASTINT (beg
), ibeg
);
2958 /* We need to allocate enough room for encoding the text.
2959 We need 33 1/3% more space, plus a newline every 76
2960 characters, and then we round up. */
2961 length
= iend
- ibeg
;
2962 allength
= length
+ length
/3 + 1;
2963 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2965 SAFE_ALLOCA (encoded
, char *, allength
);
2966 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2967 encoded
, length
, NILP (no_line_break
),
2968 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2969 if (encoded_length
> allength
)
2972 if (encoded_length
< 0)
2974 /* The encoding wasn't possible. */
2976 error ("Multibyte character in data for base64 encoding");
2979 /* Now we have encoded the region, so we insert the new contents
2980 and delete the old. (Insert first in order to preserve markers.) */
2981 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2982 insert (encoded
, encoded_length
);
2984 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2986 /* If point was outside of the region, restore it exactly; else just
2987 move to the beginning of the region. */
2988 if (old_pos
>= XFASTINT (end
))
2989 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2990 else if (old_pos
> XFASTINT (beg
))
2991 old_pos
= XFASTINT (beg
);
2994 /* We return the length of the encoded text. */
2995 return make_number (encoded_length
);
2998 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3000 doc
: /* Base64-encode STRING and return the result.
3001 Optional second argument NO-LINE-BREAK means do not break long lines
3002 into shorter lines. */)
3003 (Lisp_Object string
, Lisp_Object no_line_break
)
3005 EMACS_INT allength
, length
, encoded_length
;
3007 Lisp_Object encoded_string
;
3010 CHECK_STRING (string
);
3012 /* We need to allocate enough room for encoding the text.
3013 We need 33 1/3% more space, plus a newline every 76
3014 characters, and then we round up. */
3015 length
= SBYTES (string
);
3016 allength
= length
+ length
/3 + 1;
3017 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3019 /* We need to allocate enough room for decoding the text. */
3020 SAFE_ALLOCA (encoded
, char *, allength
);
3022 encoded_length
= base64_encode_1 (SSDATA (string
),
3023 encoded
, length
, NILP (no_line_break
),
3024 STRING_MULTIBYTE (string
));
3025 if (encoded_length
> allength
)
3028 if (encoded_length
< 0)
3030 /* The encoding wasn't possible. */
3032 error ("Multibyte character in data for base64 encoding");
3035 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3038 return encoded_string
;
3042 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3043 int line_break
, int multibyte
)
3056 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3057 if (CHAR_BYTE8_P (c
))
3058 c
= CHAR_TO_BYTE8 (c
);
3066 /* Wrap line every 76 characters. */
3070 if (counter
< MIME_LINE_LENGTH
/ 4)
3079 /* Process first byte of a triplet. */
3081 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3082 value
= (0x03 & c
) << 4;
3084 /* Process second byte of a triplet. */
3088 *e
++ = base64_value_to_char
[value
];
3096 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3097 if (CHAR_BYTE8_P (c
))
3098 c
= CHAR_TO_BYTE8 (c
);
3106 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3107 value
= (0x0f & c
) << 2;
3109 /* Process third byte of a triplet. */
3113 *e
++ = base64_value_to_char
[value
];
3120 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3121 if (CHAR_BYTE8_P (c
))
3122 c
= CHAR_TO_BYTE8 (c
);
3130 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3131 *e
++ = base64_value_to_char
[0x3f & c
];
3138 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3140 doc
: /* Base64-decode the region between BEG and END.
3141 Return the length of the decoded text.
3142 If the region can't be decoded, signal an error and don't modify the buffer. */)
3143 (Lisp_Object beg
, Lisp_Object end
)
3145 EMACS_INT ibeg
, iend
, length
, allength
;
3147 EMACS_INT old_pos
= PT
;
3148 EMACS_INT decoded_length
;
3149 EMACS_INT inserted_chars
;
3150 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3153 validate_region (&beg
, &end
);
3155 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3156 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3158 length
= iend
- ibeg
;
3160 /* We need to allocate enough room for decoding the text. If we are
3161 working on a multibyte buffer, each decoded code may occupy at
3163 allength
= multibyte
? length
* 2 : length
;
3164 SAFE_ALLOCA (decoded
, char *, allength
);
3166 move_gap_both (XFASTINT (beg
), ibeg
);
3167 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3169 multibyte
, &inserted_chars
);
3170 if (decoded_length
> allength
)
3173 if (decoded_length
< 0)
3175 /* The decoding wasn't possible. */
3177 error ("Invalid base64 data");
3180 /* Now we have decoded the region, so we insert the new contents
3181 and delete the old. (Insert first in order to preserve markers.) */
3182 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3183 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3186 /* Delete the original text. */
3187 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3188 iend
+ decoded_length
, 1);
3190 /* If point was outside of the region, restore it exactly; else just
3191 move to the beginning of the region. */
3192 if (old_pos
>= XFASTINT (end
))
3193 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3194 else if (old_pos
> XFASTINT (beg
))
3195 old_pos
= XFASTINT (beg
);
3196 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3198 return make_number (inserted_chars
);
3201 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3203 doc
: /* Base64-decode STRING and return the result. */)
3204 (Lisp_Object string
)
3207 EMACS_INT length
, decoded_length
;
3208 Lisp_Object decoded_string
;
3211 CHECK_STRING (string
);
3213 length
= SBYTES (string
);
3214 /* We need to allocate enough room for decoding the text. */
3215 SAFE_ALLOCA (decoded
, char *, length
);
3217 /* The decoded result should be unibyte. */
3218 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3220 if (decoded_length
> length
)
3222 else if (decoded_length
>= 0)
3223 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3225 decoded_string
= Qnil
;
3228 if (!STRINGP (decoded_string
))
3229 error ("Invalid base64 data");
3231 return decoded_string
;
3234 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3235 MULTIBYTE is nonzero, the decoded result should be in multibyte
3236 form. If NCHARS_RETRUN is not NULL, store the number of produced
3237 characters in *NCHARS_RETURN. */
3240 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3241 int multibyte
, EMACS_INT
*nchars_return
)
3243 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3246 unsigned long value
;
3247 EMACS_INT nchars
= 0;
3251 /* Process first byte of a quadruplet. */
3253 READ_QUADRUPLET_BYTE (e
-to
);
3257 value
= base64_char_to_value
[c
] << 18;
3259 /* Process second byte of a quadruplet. */
3261 READ_QUADRUPLET_BYTE (-1);
3265 value
|= base64_char_to_value
[c
] << 12;
3267 c
= (unsigned char) (value
>> 16);
3268 if (multibyte
&& c
>= 128)
3269 e
+= BYTE8_STRING (c
, e
);
3274 /* Process third byte of a quadruplet. */
3276 READ_QUADRUPLET_BYTE (-1);
3280 READ_QUADRUPLET_BYTE (-1);
3289 value
|= base64_char_to_value
[c
] << 6;
3291 c
= (unsigned char) (0xff & value
>> 8);
3292 if (multibyte
&& c
>= 128)
3293 e
+= BYTE8_STRING (c
, e
);
3298 /* Process fourth byte of a quadruplet. */
3300 READ_QUADRUPLET_BYTE (-1);
3307 value
|= base64_char_to_value
[c
];
3309 c
= (unsigned char) (0xff & value
);
3310 if (multibyte
&& c
>= 128)
3311 e
+= BYTE8_STRING (c
, e
);
3320 /***********************************************************************
3322 ***** Hash Tables *****
3324 ***********************************************************************/
3326 /* Implemented by gerd@gnu.org. This hash table implementation was
3327 inspired by CMUCL hash tables. */
3331 1. For small tables, association lists are probably faster than
3332 hash tables because they have lower overhead.
3334 For uses of hash tables where the O(1) behavior of table
3335 operations is not a requirement, it might therefore be a good idea
3336 not to hash. Instead, we could just do a linear search in the
3337 key_and_value vector of the hash table. This could be done
3338 if a `:linear-search t' argument is given to make-hash-table. */
3341 /* The list of all weak hash tables. Don't staticpro this one. */
3343 static struct Lisp_Hash_Table
*weak_hash_tables
;
3345 /* Various symbols. */
3347 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3348 Lisp_Object Qeq
, Qeql
, Qequal
;
3349 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3350 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3352 /* Function prototypes. */
3354 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3355 static ptrdiff_t get_key_arg (Lisp_Object
, ptrdiff_t, Lisp_Object
*, char *);
3356 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3357 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3361 /***********************************************************************
3363 ***********************************************************************/
3365 /* If OBJ is a Lisp hash table, return a pointer to its struct
3366 Lisp_Hash_Table. Otherwise, signal an error. */
3368 static struct Lisp_Hash_Table
*
3369 check_hash_table (Lisp_Object obj
)
3371 CHECK_HASH_TABLE (obj
);
3372 return XHASH_TABLE (obj
);
3376 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3380 next_almost_prime (EMACS_INT n
)
3382 for (n
|= 1; ; n
+= 2)
3383 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3388 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3389 which USED[I] is non-zero. If found at index I in ARGS, set
3390 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3391 0. This function is used to extract a keyword/argument pair from
3392 a DEFUN parameter list. */
3395 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3399 for (i
= 1; i
< nargs
; i
++)
3400 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3411 /* Return a Lisp vector which has the same contents as VEC but has
3412 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3413 vector that are not copied from VEC are set to INIT. */
3416 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3418 struct Lisp_Vector
*v
;
3419 EMACS_INT i
, old_size
;
3421 xassert (VECTORP (vec
));
3422 old_size
= ASIZE (vec
);
3423 xassert (new_size
>= old_size
);
3425 v
= allocate_vector (new_size
);
3426 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3427 for (i
= old_size
; i
< new_size
; ++i
)
3428 v
->contents
[i
] = init
;
3429 XSETVECTOR (vec
, v
);
3434 /***********************************************************************
3436 ***********************************************************************/
3438 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3439 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3440 KEY2 are the same. */
3443 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3444 Lisp_Object key1
, EMACS_UINT hash1
,
3445 Lisp_Object key2
, EMACS_UINT hash2
)
3447 return (FLOATP (key1
)
3449 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3453 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3454 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3455 KEY2 are the same. */
3458 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3459 Lisp_Object key1
, EMACS_UINT hash1
,
3460 Lisp_Object key2
, EMACS_UINT hash2
)
3462 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3466 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3467 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3468 if KEY1 and KEY2 are the same. */
3471 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3472 Lisp_Object key1
, EMACS_UINT hash1
,
3473 Lisp_Object key2
, EMACS_UINT hash2
)
3477 Lisp_Object args
[3];
3479 args
[0] = h
->user_cmp_function
;
3482 return !NILP (Ffuncall (3, args
));
3489 /* Value is a hash code for KEY for use in hash table H which uses
3490 `eq' to compare keys. The hash code returned is guaranteed to fit
3491 in a Lisp integer. */
3494 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3496 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3497 xassert ((hash
& ~INTMASK
) == 0);
3502 /* Value is a hash code for KEY for use in hash table H which uses
3503 `eql' to compare keys. The hash code returned is guaranteed to fit
3504 in a Lisp integer. */
3507 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3511 hash
= sxhash (key
, 0);
3513 hash
= XUINT (key
) ^ XTYPE (key
);
3514 xassert ((hash
& ~INTMASK
) == 0);
3519 /* Value is a hash code for KEY for use in hash table H which uses
3520 `equal' to compare keys. The hash code returned is guaranteed to fit
3521 in a Lisp integer. */
3524 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3526 EMACS_UINT hash
= sxhash (key
, 0);
3527 xassert ((hash
& ~INTMASK
) == 0);
3532 /* Value is a hash code for KEY for use in hash table H which uses as
3533 user-defined function to compare keys. The hash code returned is
3534 guaranteed to fit in a Lisp integer. */
3537 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3539 Lisp_Object args
[2], hash
;
3541 args
[0] = h
->user_hash_function
;
3543 hash
= Ffuncall (2, args
);
3544 if (!INTEGERP (hash
))
3545 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3546 return XUINT (hash
);
3550 /* Create and initialize a new hash table.
3552 TEST specifies the test the hash table will use to compare keys.
3553 It must be either one of the predefined tests `eq', `eql' or
3554 `equal' or a symbol denoting a user-defined test named TEST with
3555 test and hash functions USER_TEST and USER_HASH.
3557 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3559 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3560 new size when it becomes full is computed by adding REHASH_SIZE to
3561 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3562 table's new size is computed by multiplying its old size with
3565 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3566 be resized when the ratio of (number of entries in the table) /
3567 (table size) is >= REHASH_THRESHOLD.
3569 WEAK specifies the weakness of the table. If non-nil, it must be
3570 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3573 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3574 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3575 Lisp_Object user_test
, Lisp_Object user_hash
)
3577 struct Lisp_Hash_Table
*h
;
3579 EMACS_INT index_size
, i
, sz
;
3582 /* Preconditions. */
3583 xassert (SYMBOLP (test
));
3584 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3585 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3586 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3587 xassert (FLOATP (rehash_threshold
)
3588 && 0 < XFLOAT_DATA (rehash_threshold
)
3589 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3591 if (XFASTINT (size
) == 0)
3592 size
= make_number (1);
3594 sz
= XFASTINT (size
);
3595 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3596 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3597 ? next_almost_prime (index_float
)
3598 : MOST_POSITIVE_FIXNUM
+ 1);
3599 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3600 error ("Hash table too large");
3602 /* Allocate a table and initialize it. */
3603 h
= allocate_hash_table ();
3605 /* Initialize hash table slots. */
3607 if (EQ (test
, Qeql
))
3609 h
->cmpfn
= cmpfn_eql
;
3610 h
->hashfn
= hashfn_eql
;
3612 else if (EQ (test
, Qeq
))
3615 h
->hashfn
= hashfn_eq
;
3617 else if (EQ (test
, Qequal
))
3619 h
->cmpfn
= cmpfn_equal
;
3620 h
->hashfn
= hashfn_equal
;
3624 h
->user_cmp_function
= user_test
;
3625 h
->user_hash_function
= user_hash
;
3626 h
->cmpfn
= cmpfn_user_defined
;
3627 h
->hashfn
= hashfn_user_defined
;
3631 h
->rehash_threshold
= rehash_threshold
;
3632 h
->rehash_size
= rehash_size
;
3634 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3635 h
->hash
= Fmake_vector (size
, Qnil
);
3636 h
->next
= Fmake_vector (size
, Qnil
);
3637 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3639 /* Set up the free list. */
3640 for (i
= 0; i
< sz
- 1; ++i
)
3641 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3642 h
->next_free
= make_number (0);
3644 XSET_HASH_TABLE (table
, h
);
3645 xassert (HASH_TABLE_P (table
));
3646 xassert (XHASH_TABLE (table
) == h
);
3648 /* Maybe add this hash table to the list of all weak hash tables. */
3650 h
->next_weak
= NULL
;
3653 h
->next_weak
= weak_hash_tables
;
3654 weak_hash_tables
= h
;
3661 /* Return a copy of hash table H1. Keys and values are not copied,
3662 only the table itself is. */
3665 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3668 struct Lisp_Hash_Table
*h2
;
3669 struct Lisp_Vector
*next
;
3671 h2
= allocate_hash_table ();
3672 next
= h2
->header
.next
.vector
;
3673 memcpy (h2
, h1
, sizeof *h2
);
3674 h2
->header
.next
.vector
= next
;
3675 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3676 h2
->hash
= Fcopy_sequence (h1
->hash
);
3677 h2
->next
= Fcopy_sequence (h1
->next
);
3678 h2
->index
= Fcopy_sequence (h1
->index
);
3679 XSET_HASH_TABLE (table
, h2
);
3681 /* Maybe add this hash table to the list of all weak hash tables. */
3682 if (!NILP (h2
->weak
))
3684 h2
->next_weak
= weak_hash_tables
;
3685 weak_hash_tables
= h2
;
3692 /* Resize hash table H if it's too full. If H cannot be resized
3693 because it's already too large, throw an error. */
3696 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3698 if (NILP (h
->next_free
))
3700 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3701 EMACS_INT i
, new_size
, index_size
;
3705 if (INTEGERP (h
->rehash_size
))
3706 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3709 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3710 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3712 new_size
= float_new_size
;
3713 if (new_size
<= old_size
)
3714 new_size
= old_size
+ 1;
3717 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3719 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3720 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3721 ? next_almost_prime (index_float
)
3722 : MOST_POSITIVE_FIXNUM
+ 1);
3723 nsize
= max (index_size
, 2 * new_size
);
3724 if (nsize
> MOST_POSITIVE_FIXNUM
)
3725 error ("Hash table too large to resize");
3727 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3728 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3729 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3730 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3732 /* Update the free list. Do it so that new entries are added at
3733 the end of the free list. This makes some operations like
3735 for (i
= old_size
; i
< new_size
- 1; ++i
)
3736 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3738 if (!NILP (h
->next_free
))
3740 Lisp_Object last
, next
;
3742 last
= h
->next_free
;
3743 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3747 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3750 XSETFASTINT (h
->next_free
, old_size
);
3753 for (i
= 0; i
< old_size
; ++i
)
3754 if (!NILP (HASH_HASH (h
, i
)))
3756 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3757 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3758 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3759 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3765 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3766 the hash code of KEY. Value is the index of the entry in H
3767 matching KEY, or -1 if not found. */
3770 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3772 EMACS_UINT hash_code
;
3773 EMACS_INT start_of_bucket
;
3776 hash_code
= h
->hashfn (h
, key
);
3780 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3781 idx
= HASH_INDEX (h
, start_of_bucket
);
3783 /* We need not gcpro idx since it's either an integer or nil. */
3786 EMACS_INT i
= XFASTINT (idx
);
3787 if (EQ (key
, HASH_KEY (h
, i
))
3789 && h
->cmpfn (h
, key
, hash_code
,
3790 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3792 idx
= HASH_NEXT (h
, i
);
3795 return NILP (idx
) ? -1 : XFASTINT (idx
);
3799 /* Put an entry into hash table H that associates KEY with VALUE.
3800 HASH is a previously computed hash code of KEY.
3801 Value is the index of the entry in H matching KEY. */
3804 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3807 EMACS_INT start_of_bucket
, i
;
3809 xassert ((hash
& ~INTMASK
) == 0);
3811 /* Increment count after resizing because resizing may fail. */
3812 maybe_resize_hash_table (h
);
3815 /* Store key/value in the key_and_value vector. */
3816 i
= XFASTINT (h
->next_free
);
3817 h
->next_free
= HASH_NEXT (h
, i
);
3818 HASH_KEY (h
, i
) = key
;
3819 HASH_VALUE (h
, i
) = value
;
3821 /* Remember its hash code. */
3822 HASH_HASH (h
, i
) = make_number (hash
);
3824 /* Add new entry to its collision chain. */
3825 start_of_bucket
= hash
% ASIZE (h
->index
);
3826 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3827 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3832 /* Remove the entry matching KEY from hash table H, if there is one. */
3835 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3837 EMACS_UINT hash_code
;
3838 EMACS_INT start_of_bucket
;
3839 Lisp_Object idx
, prev
;
3841 hash_code
= h
->hashfn (h
, key
);
3842 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3843 idx
= HASH_INDEX (h
, start_of_bucket
);
3846 /* We need not gcpro idx, prev since they're either integers or nil. */
3849 EMACS_INT i
= XFASTINT (idx
);
3851 if (EQ (key
, HASH_KEY (h
, i
))
3853 && h
->cmpfn (h
, key
, hash_code
,
3854 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3856 /* Take entry out of collision chain. */
3858 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3860 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3862 /* Clear slots in key_and_value and add the slots to
3864 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3865 HASH_NEXT (h
, i
) = h
->next_free
;
3866 h
->next_free
= make_number (i
);
3868 xassert (h
->count
>= 0);
3874 idx
= HASH_NEXT (h
, i
);
3880 /* Clear hash table H. */
3883 hash_clear (struct Lisp_Hash_Table
*h
)
3887 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3889 for (i
= 0; i
< size
; ++i
)
3891 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3892 HASH_KEY (h
, i
) = Qnil
;
3893 HASH_VALUE (h
, i
) = Qnil
;
3894 HASH_HASH (h
, i
) = Qnil
;
3897 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3898 ASET (h
->index
, i
, Qnil
);
3900 h
->next_free
= make_number (0);
3907 /************************************************************************
3909 ************************************************************************/
3912 init_weak_hash_tables (void)
3914 weak_hash_tables
= NULL
;
3917 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3918 entries from the table that don't survive the current GC.
3919 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3920 non-zero if anything was marked. */
3923 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3925 EMACS_INT bucket
, n
;
3928 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3931 for (bucket
= 0; bucket
< n
; ++bucket
)
3933 Lisp_Object idx
, next
, prev
;
3935 /* Follow collision chain, removing entries that
3936 don't survive this garbage collection. */
3938 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3940 EMACS_INT i
= XFASTINT (idx
);
3941 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3942 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3945 if (EQ (h
->weak
, Qkey
))
3946 remove_p
= !key_known_to_survive_p
;
3947 else if (EQ (h
->weak
, Qvalue
))
3948 remove_p
= !value_known_to_survive_p
;
3949 else if (EQ (h
->weak
, Qkey_or_value
))
3950 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3951 else if (EQ (h
->weak
, Qkey_and_value
))
3952 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3956 next
= HASH_NEXT (h
, i
);
3958 if (remove_entries_p
)
3962 /* Take out of collision chain. */
3964 HASH_INDEX (h
, bucket
) = next
;
3966 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3968 /* Add to free list. */
3969 HASH_NEXT (h
, i
) = h
->next_free
;
3972 /* Clear key, value, and hash. */
3973 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3974 HASH_HASH (h
, i
) = Qnil
;
3987 /* Make sure key and value survive. */
3988 if (!key_known_to_survive_p
)
3990 mark_object (HASH_KEY (h
, i
));
3994 if (!value_known_to_survive_p
)
3996 mark_object (HASH_VALUE (h
, i
));
4007 /* Remove elements from weak hash tables that don't survive the
4008 current garbage collection. Remove weak tables that don't survive
4009 from Vweak_hash_tables. Called from gc_sweep. */
4012 sweep_weak_hash_tables (void)
4014 struct Lisp_Hash_Table
*h
, *used
, *next
;
4017 /* Mark all keys and values that are in use. Keep on marking until
4018 there is no more change. This is necessary for cases like
4019 value-weak table A containing an entry X -> Y, where Y is used in a
4020 key-weak table B, Z -> Y. If B comes after A in the list of weak
4021 tables, X -> Y might be removed from A, although when looking at B
4022 one finds that it shouldn't. */
4026 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4028 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4029 marked
|= sweep_weak_table (h
, 0);
4034 /* Remove tables and entries that aren't used. */
4035 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4037 next
= h
->next_weak
;
4039 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4041 /* TABLE is marked as used. Sweep its contents. */
4043 sweep_weak_table (h
, 1);
4045 /* Add table to the list of used weak hash tables. */
4046 h
->next_weak
= used
;
4051 weak_hash_tables
= used
;
4056 /***********************************************************************
4057 Hash Code Computation
4058 ***********************************************************************/
4060 /* Maximum depth up to which to dive into Lisp structures. */
4062 #define SXHASH_MAX_DEPTH 3
4064 /* Maximum length up to which to take list and vector elements into
4067 #define SXHASH_MAX_LEN 7
4069 /* Combine two integers X and Y for hashing. The result might not fit
4070 into a Lisp integer. */
4072 #define SXHASH_COMBINE(X, Y) \
4073 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4076 /* Hash X, returning a value that fits into a Lisp integer. */
4077 #define SXHASH_REDUCE(X) \
4078 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4080 /* Return a hash for string PTR which has length LEN. The hash
4081 code returned is guaranteed to fit in a Lisp integer. */
4084 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4086 unsigned char *p
= ptr
;
4087 unsigned char *end
= p
+ len
;
4089 EMACS_UINT hash
= 0;
4096 hash
= SXHASH_COMBINE (hash
, c
);
4099 return SXHASH_REDUCE (hash
);
4102 /* Return a hash for the floating point value VAL. */
4105 sxhash_float (double val
)
4107 EMACS_UINT hash
= 0;
4109 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4110 + (sizeof val
% sizeof hash
!= 0))
4114 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4118 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4119 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4120 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4121 return SXHASH_REDUCE (hash
);
4124 /* Return a hash for list LIST. DEPTH is the current depth in the
4125 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4128 sxhash_list (Lisp_Object list
, int depth
)
4130 EMACS_UINT hash
= 0;
4133 if (depth
< SXHASH_MAX_DEPTH
)
4135 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4136 list
= XCDR (list
), ++i
)
4138 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4139 hash
= SXHASH_COMBINE (hash
, hash2
);
4144 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4145 hash
= SXHASH_COMBINE (hash
, hash2
);
4148 return SXHASH_REDUCE (hash
);
4152 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4153 the Lisp structure. */
4156 sxhash_vector (Lisp_Object vec
, int depth
)
4158 EMACS_UINT hash
= ASIZE (vec
);
4161 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4162 for (i
= 0; i
< n
; ++i
)
4164 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4165 hash
= SXHASH_COMBINE (hash
, hash2
);
4168 return SXHASH_REDUCE (hash
);
4171 /* Return a hash for bool-vector VECTOR. */
4174 sxhash_bool_vector (Lisp_Object vec
)
4176 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4179 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4180 for (i
= 0; i
< n
; ++i
)
4181 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4183 return SXHASH_REDUCE (hash
);
4187 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4188 structure. Value is an unsigned integer clipped to INTMASK. */
4191 sxhash (Lisp_Object obj
, int depth
)
4195 if (depth
> SXHASH_MAX_DEPTH
)
4198 switch (XTYPE (obj
))
4209 obj
= SYMBOL_NAME (obj
);
4213 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4216 /* This can be everything from a vector to an overlay. */
4217 case Lisp_Vectorlike
:
4219 /* According to the CL HyperSpec, two arrays are equal only if
4220 they are `eq', except for strings and bit-vectors. In
4221 Emacs, this works differently. We have to compare element
4223 hash
= sxhash_vector (obj
, depth
);
4224 else if (BOOL_VECTOR_P (obj
))
4225 hash
= sxhash_bool_vector (obj
);
4227 /* Others are `equal' if they are `eq', so let's take their
4233 hash
= sxhash_list (obj
, depth
);
4237 hash
= sxhash_float (XFLOAT_DATA (obj
));
4249 /***********************************************************************
4251 ***********************************************************************/
4254 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4255 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4258 EMACS_UINT hash
= sxhash (obj
, 0);
4259 return make_number (hash
);
4263 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4264 doc
: /* Create and return a new hash table.
4266 Arguments are specified as keyword/argument pairs. The following
4267 arguments are defined:
4269 :test TEST -- TEST must be a symbol that specifies how to compare
4270 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4271 `equal'. User-supplied test and hash functions can be specified via
4272 `define-hash-table-test'.
4274 :size SIZE -- A hint as to how many elements will be put in the table.
4277 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4278 fills up. If REHASH-SIZE is an integer, increase the size by that
4279 amount. If it is a float, it must be > 1.0, and the new size is the
4280 old size multiplied by that factor. Default is 1.5.
4282 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4283 Resize the hash table when the ratio (number of entries / table size)
4284 is greater than or equal to THRESHOLD. Default is 0.8.
4286 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4287 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4288 returned is a weak table. Key/value pairs are removed from a weak
4289 hash table when there are no non-weak references pointing to their
4290 key, value, one of key or value, or both key and value, depending on
4291 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4294 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4295 (ptrdiff_t nargs
, Lisp_Object
*args
)
4297 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4298 Lisp_Object user_test
, user_hash
;
4302 /* The vector `used' is used to keep track of arguments that
4303 have been consumed. */
4304 used
= (char *) alloca (nargs
* sizeof *used
);
4305 memset (used
, 0, nargs
* sizeof *used
);
4307 /* See if there's a `:test TEST' among the arguments. */
4308 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4309 test
= i
? args
[i
] : Qeql
;
4310 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4312 /* See if it is a user-defined test. */
4315 prop
= Fget (test
, Qhash_table_test
);
4316 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4317 signal_error ("Invalid hash table test", test
);
4318 user_test
= XCAR (prop
);
4319 user_hash
= XCAR (XCDR (prop
));
4322 user_test
= user_hash
= Qnil
;
4324 /* See if there's a `:size SIZE' argument. */
4325 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4326 size
= i
? args
[i
] : Qnil
;
4328 size
= make_number (DEFAULT_HASH_SIZE
);
4329 else if (!INTEGERP (size
) || XINT (size
) < 0)
4330 signal_error ("Invalid hash table size", size
);
4332 /* Look for `:rehash-size SIZE'. */
4333 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4334 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4335 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4336 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4337 signal_error ("Invalid hash table rehash size", rehash_size
);
4339 /* Look for `:rehash-threshold THRESHOLD'. */
4340 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4341 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4342 if (! (FLOATP (rehash_threshold
)
4343 && 0 < XFLOAT_DATA (rehash_threshold
)
4344 && XFLOAT_DATA (rehash_threshold
) <= 1))
4345 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4347 /* Look for `:weakness WEAK'. */
4348 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4349 weak
= i
? args
[i
] : Qnil
;
4351 weak
= Qkey_and_value
;
4354 && !EQ (weak
, Qvalue
)
4355 && !EQ (weak
, Qkey_or_value
)
4356 && !EQ (weak
, Qkey_and_value
))
4357 signal_error ("Invalid hash table weakness", weak
);
4359 /* Now, all args should have been used up, or there's a problem. */
4360 for (i
= 0; i
< nargs
; ++i
)
4362 signal_error ("Invalid argument list", args
[i
]);
4364 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4365 user_test
, user_hash
);
4369 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4370 doc
: /* Return a copy of hash table TABLE. */)
4373 return copy_hash_table (check_hash_table (table
));
4377 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4378 doc
: /* Return the number of elements in TABLE. */)
4381 return make_number (check_hash_table (table
)->count
);
4385 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4386 Shash_table_rehash_size
, 1, 1, 0,
4387 doc
: /* Return the current rehash size of TABLE. */)
4390 return check_hash_table (table
)->rehash_size
;
4394 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4395 Shash_table_rehash_threshold
, 1, 1, 0,
4396 doc
: /* Return the current rehash threshold of TABLE. */)
4399 return check_hash_table (table
)->rehash_threshold
;
4403 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4404 doc
: /* Return the size of TABLE.
4405 The size can be used as an argument to `make-hash-table' to create
4406 a hash table than can hold as many elements as TABLE holds
4407 without need for resizing. */)
4410 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4411 return make_number (HASH_TABLE_SIZE (h
));
4415 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4416 doc
: /* Return the test TABLE uses. */)
4419 return check_hash_table (table
)->test
;
4423 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4425 doc
: /* Return the weakness of TABLE. */)
4428 return check_hash_table (table
)->weak
;
4432 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4433 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4436 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4440 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4441 doc
: /* Clear hash table TABLE and return it. */)
4444 hash_clear (check_hash_table (table
));
4445 /* Be compatible with XEmacs. */
4450 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4451 doc
: /* Look up KEY in TABLE and return its associated value.
4452 If KEY is not found, return DFLT which defaults to nil. */)
4453 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4455 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4456 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4457 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4461 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4462 doc
: /* Associate KEY with VALUE in hash table TABLE.
4463 If KEY is already present in table, replace its current value with
4464 VALUE. In any case, return VALUE. */)
4465 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4467 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4471 i
= hash_lookup (h
, key
, &hash
);
4473 HASH_VALUE (h
, i
) = value
;
4475 hash_put (h
, key
, value
, hash
);
4481 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4482 doc
: /* Remove KEY from TABLE. */)
4483 (Lisp_Object key
, Lisp_Object table
)
4485 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4486 hash_remove_from_table (h
, key
);
4491 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4492 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4493 FUNCTION is called with two arguments, KEY and VALUE. */)
4494 (Lisp_Object function
, Lisp_Object table
)
4496 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4497 Lisp_Object args
[3];
4500 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4501 if (!NILP (HASH_HASH (h
, i
)))
4504 args
[1] = HASH_KEY (h
, i
);
4505 args
[2] = HASH_VALUE (h
, i
);
4513 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4514 Sdefine_hash_table_test
, 3, 3, 0,
4515 doc
: /* Define a new hash table test with name NAME, a symbol.
4517 In hash tables created with NAME specified as test, use TEST to
4518 compare keys, and HASH for computing hash codes of keys.
4520 TEST must be a function taking two arguments and returning non-nil if
4521 both arguments are the same. HASH must be a function taking one
4522 argument and return an integer that is the hash code of the argument.
4523 Hash code computation should use the whole value range of integers,
4524 including negative integers. */)
4525 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4527 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4532 /************************************************************************
4534 ************************************************************************/
4539 /* Convert a possibly-signed character to an unsigned character. This is
4540 a bit safer than casting to unsigned char, since it catches some type
4541 errors that the cast doesn't. */
4542 static inline unsigned char to_uchar (char ch
) { return ch
; }
4544 /* TYPE: 0 for md5, 1 for sha1. */
4547 crypto_hash_function (int type
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4551 EMACS_INT size_byte
= 0;
4552 EMACS_INT start_char
= 0, end_char
= 0;
4553 EMACS_INT start_byte
= 0, end_byte
= 0;
4554 register EMACS_INT b
, e
;
4555 register struct buffer
*bp
;
4557 Lisp_Object res
=Qnil
;
4559 if (STRINGP (object
))
4561 if (NILP (coding_system
))
4563 /* Decide the coding-system to encode the data with. */
4565 if (STRING_MULTIBYTE (object
))
4566 /* use default, we can't guess correct value */
4567 coding_system
= preferred_coding_system ();
4569 coding_system
= Qraw_text
;
4572 if (NILP (Fcoding_system_p (coding_system
)))
4574 /* Invalid coding system. */
4576 if (!NILP (noerror
))
4577 coding_system
= Qraw_text
;
4579 xsignal1 (Qcoding_system_error
, coding_system
);
4582 if (STRING_MULTIBYTE (object
))
4583 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4585 size
= SCHARS (object
);
4586 size_byte
= SBYTES (object
);
4590 CHECK_NUMBER (start
);
4592 start_char
= XINT (start
);
4597 start_byte
= string_char_to_byte (object
, start_char
);
4603 end_byte
= size_byte
;
4609 end_char
= XINT (end
);
4614 end_byte
= string_char_to_byte (object
, end_char
);
4617 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4618 args_out_of_range_3 (object
, make_number (start_char
),
4619 make_number (end_char
));
4623 struct buffer
*prev
= current_buffer
;
4625 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4627 CHECK_BUFFER (object
);
4629 bp
= XBUFFER (object
);
4630 if (bp
!= current_buffer
)
4631 set_buffer_internal (bp
);
4637 CHECK_NUMBER_COERCE_MARKER (start
);
4645 CHECK_NUMBER_COERCE_MARKER (end
);
4650 temp
= b
, b
= e
, e
= temp
;
4652 if (!(BEGV
<= b
&& e
<= ZV
))
4653 args_out_of_range (start
, end
);
4655 if (NILP (coding_system
))
4657 /* Decide the coding-system to encode the data with.
4658 See fileio.c:Fwrite-region */
4660 if (!NILP (Vcoding_system_for_write
))
4661 coding_system
= Vcoding_system_for_write
;
4664 int force_raw_text
= 0;
4666 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4667 if (NILP (coding_system
)
4668 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4670 coding_system
= Qnil
;
4671 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4675 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4677 /* Check file-coding-system-alist. */
4678 Lisp_Object args
[4], val
;
4680 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4681 args
[3] = Fbuffer_file_name(object
);
4682 val
= Ffind_operation_coding_system (4, args
);
4683 if (CONSP (val
) && !NILP (XCDR (val
)))
4684 coding_system
= XCDR (val
);
4687 if (NILP (coding_system
)
4688 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4690 /* If we still have not decided a coding system, use the
4691 default value of buffer-file-coding-system. */
4692 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4696 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4697 /* Confirm that VAL can surely encode the current region. */
4698 coding_system
= call4 (Vselect_safe_coding_system_function
,
4699 make_number (b
), make_number (e
),
4700 coding_system
, Qnil
);
4703 coding_system
= Qraw_text
;
4706 if (NILP (Fcoding_system_p (coding_system
)))
4708 /* Invalid coding system. */
4710 if (!NILP (noerror
))
4711 coding_system
= Qraw_text
;
4713 xsignal1 (Qcoding_system_error
, coding_system
);
4717 object
= make_buffer_string (b
, e
, 0);
4718 if (prev
!= current_buffer
)
4719 set_buffer_internal (prev
);
4720 /* Discard the unwind protect for recovering the current
4724 if (STRING_MULTIBYTE (object
))
4725 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4733 md5_buffer (SSDATA (object
) + start_byte
,
4734 SBYTES (object
) - (size_byte
- end_byte
),
4740 for (i
= 0; i
< 16; i
++)
4741 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4742 res
= make_string (value
, 32);
4745 res
= make_string (digest
, 16);
4752 sha1_buffer (SSDATA (object
) + start_byte
,
4753 SBYTES (object
) - (size_byte
- end_byte
),
4758 for (i
= 0; i
< 20; i
++)
4759 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4760 res
= make_string (value
, 40);
4763 res
= make_string (digest
, 20);
4771 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4772 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4774 A message digest is a cryptographic checksum of a document, and the
4775 algorithm to calculate it is defined in RFC 1321.
4777 The two optional arguments START and END are character positions
4778 specifying for which part of OBJECT the message digest should be
4779 computed. If nil or omitted, the digest is computed for the whole
4782 The MD5 message digest is computed from the result of encoding the
4783 text in a coding system, not directly from the internal Emacs form of
4784 the text. The optional fourth argument CODING-SYSTEM specifies which
4785 coding system to encode the text with. It should be the same coding
4786 system that you used or will use when actually writing the text into a
4789 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4790 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4791 system would be chosen by default for writing this text into a file.
4793 If OBJECT is a string, the most preferred coding system (see the
4794 command `prefer-coding-system') is used.
4796 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4797 guesswork fails. Normally, an error is signaled in such case. */)
4798 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4800 return crypto_hash_function (0, object
, start
, end
, coding_system
, noerror
, Qnil
);
4803 DEFUN ("sha1", Fsha1
, Ssha1
, 1, 4, 0,
4804 doc
: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
4806 OBJECT is either a string or a buffer. Optional arguments START and
4807 END are character positions specifying which portion of OBJECT for
4808 computing the hash. If BINARY is non-nil, return a string in binary
4810 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4812 return crypto_hash_function (1, object
, start
, end
, Qnil
, Qnil
, binary
);
4819 /* Hash table stuff. */
4820 Qhash_table_p
= intern_c_string ("hash-table-p");
4821 staticpro (&Qhash_table_p
);
4822 Qeq
= intern_c_string ("eq");
4824 Qeql
= intern_c_string ("eql");
4826 Qequal
= intern_c_string ("equal");
4827 staticpro (&Qequal
);
4828 QCtest
= intern_c_string (":test");
4829 staticpro (&QCtest
);
4830 QCsize
= intern_c_string (":size");
4831 staticpro (&QCsize
);
4832 QCrehash_size
= intern_c_string (":rehash-size");
4833 staticpro (&QCrehash_size
);
4834 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4835 staticpro (&QCrehash_threshold
);
4836 QCweakness
= intern_c_string (":weakness");
4837 staticpro (&QCweakness
);
4838 Qkey
= intern_c_string ("key");
4840 Qvalue
= intern_c_string ("value");
4841 staticpro (&Qvalue
);
4842 Qhash_table_test
= intern_c_string ("hash-table-test");
4843 staticpro (&Qhash_table_test
);
4844 Qkey_or_value
= intern_c_string ("key-or-value");
4845 staticpro (&Qkey_or_value
);
4846 Qkey_and_value
= intern_c_string ("key-and-value");
4847 staticpro (&Qkey_and_value
);
4850 defsubr (&Smake_hash_table
);
4851 defsubr (&Scopy_hash_table
);
4852 defsubr (&Shash_table_count
);
4853 defsubr (&Shash_table_rehash_size
);
4854 defsubr (&Shash_table_rehash_threshold
);
4855 defsubr (&Shash_table_size
);
4856 defsubr (&Shash_table_test
);
4857 defsubr (&Shash_table_weakness
);
4858 defsubr (&Shash_table_p
);
4859 defsubr (&Sclrhash
);
4860 defsubr (&Sgethash
);
4861 defsubr (&Sputhash
);
4862 defsubr (&Sremhash
);
4863 defsubr (&Smaphash
);
4864 defsubr (&Sdefine_hash_table_test
);
4866 Qstring_lessp
= intern_c_string ("string-lessp");
4867 staticpro (&Qstring_lessp
);
4868 Qprovide
= intern_c_string ("provide");
4869 staticpro (&Qprovide
);
4870 Qrequire
= intern_c_string ("require");
4871 staticpro (&Qrequire
);
4872 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4873 staticpro (&Qyes_or_no_p_history
);
4874 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4875 staticpro (&Qcursor_in_echo_area
);
4876 Qwidget_type
= intern_c_string ("widget-type");
4877 staticpro (&Qwidget_type
);
4879 staticpro (&string_char_byte_cache_string
);
4880 string_char_byte_cache_string
= Qnil
;
4882 require_nesting_list
= Qnil
;
4883 staticpro (&require_nesting_list
);
4885 Fset (Qyes_or_no_p_history
, Qnil
);
4887 DEFVAR_LISP ("features", Vfeatures
,
4888 doc
: /* A list of symbols which are the features of the executing Emacs.
4889 Used by `featurep' and `require', and altered by `provide'. */);
4890 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4891 Qsubfeatures
= intern_c_string ("subfeatures");
4892 staticpro (&Qsubfeatures
);
4894 #ifdef HAVE_LANGINFO_CODESET
4895 Qcodeset
= intern_c_string ("codeset");
4896 staticpro (&Qcodeset
);
4897 Qdays
= intern_c_string ("days");
4899 Qmonths
= intern_c_string ("months");
4900 staticpro (&Qmonths
);
4901 Qpaper
= intern_c_string ("paper");
4902 staticpro (&Qpaper
);
4903 #endif /* HAVE_LANGINFO_CODESET */
4905 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4906 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4907 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4908 invoked by mouse clicks and mouse menu items.
4910 On some platforms, file selection dialogs are also enabled if this is
4914 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4915 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4916 This applies to commands from menus and tool bar buttons even when
4917 they are initiated from the keyboard. If `use-dialog-box' is nil,
4918 that disables the use of a file dialog, regardless of the value of
4920 use_file_dialog
= 1;
4922 defsubr (&Sidentity
);
4925 defsubr (&Ssafe_length
);
4926 defsubr (&Sstring_bytes
);
4927 defsubr (&Sstring_equal
);
4928 defsubr (&Scompare_strings
);
4929 defsubr (&Sstring_lessp
);
4932 defsubr (&Svconcat
);
4933 defsubr (&Scopy_sequence
);
4934 defsubr (&Sstring_make_multibyte
);
4935 defsubr (&Sstring_make_unibyte
);
4936 defsubr (&Sstring_as_multibyte
);
4937 defsubr (&Sstring_as_unibyte
);
4938 defsubr (&Sstring_to_multibyte
);
4939 defsubr (&Sstring_to_unibyte
);
4940 defsubr (&Scopy_alist
);
4941 defsubr (&Ssubstring
);
4942 defsubr (&Ssubstring_no_properties
);
4955 defsubr (&Snreverse
);
4956 defsubr (&Sreverse
);
4958 defsubr (&Splist_get
);
4960 defsubr (&Splist_put
);
4962 defsubr (&Slax_plist_get
);
4963 defsubr (&Slax_plist_put
);
4966 defsubr (&Sequal_including_properties
);
4967 defsubr (&Sfillarray
);
4968 defsubr (&Sclear_string
);
4972 defsubr (&Smapconcat
);
4973 defsubr (&Syes_or_no_p
);
4974 defsubr (&Sload_average
);
4975 defsubr (&Sfeaturep
);
4976 defsubr (&Srequire
);
4977 defsubr (&Sprovide
);
4978 defsubr (&Splist_member
);
4979 defsubr (&Swidget_put
);
4980 defsubr (&Swidget_get
);
4981 defsubr (&Swidget_apply
);
4982 defsubr (&Sbase64_encode_region
);
4983 defsubr (&Sbase64_decode_region
);
4984 defsubr (&Sbase64_encode_string
);
4985 defsubr (&Sbase64_decode_string
);
4988 defsubr (&Slocale_info
);