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 (size_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 (size_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 (size_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 (size_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 int 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 (size_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
;
455 register size_t argnum
;
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 int 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. */
507 EMACS_INT this_len_byte
;
509 if (VECTORP (this) || COMPILEDP (this))
510 for (i
= 0; i
< len
; i
++)
513 CHECK_CHARACTER (ch
);
514 this_len_byte
= CHAR_BYTES (XINT (ch
));
515 result_len_byte
+= this_len_byte
;
516 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
519 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
520 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
521 else if (CONSP (this))
522 for (; CONSP (this); this = XCDR (this))
525 CHECK_CHARACTER (ch
);
526 this_len_byte
= CHAR_BYTES (XINT (ch
));
527 result_len_byte
+= this_len_byte
;
528 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
531 else if (STRINGP (this))
533 if (STRING_MULTIBYTE (this))
536 result_len_byte
+= SBYTES (this);
539 result_len_byte
+= count_size_as_multibyte (SDATA (this),
546 error ("String overflow");
549 if (! some_multibyte
)
550 result_len_byte
= result_len
;
552 /* Create the output object. */
553 if (target_type
== Lisp_Cons
)
554 val
= Fmake_list (make_number (result_len
), Qnil
);
555 else if (target_type
== Lisp_Vectorlike
)
556 val
= Fmake_vector (make_number (result_len
), Qnil
);
557 else if (some_multibyte
)
558 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
560 val
= make_uninit_string (result_len
);
562 /* In `append', if all but last arg are nil, return last arg. */
563 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
566 /* Copy the contents of the args into the result. */
568 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
570 toindex
= 0, toindex_byte
= 0;
574 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
576 for (argnum
= 0; argnum
< nargs
; argnum
++)
579 EMACS_INT thisleni
= 0;
580 register EMACS_INT thisindex
= 0;
581 register EMACS_INT thisindex_byte
= 0;
585 thislen
= Flength (this), thisleni
= XINT (thislen
);
587 /* Between strings of the same kind, copy fast. */
588 if (STRINGP (this) && STRINGP (val
)
589 && STRING_MULTIBYTE (this) == some_multibyte
)
591 EMACS_INT thislen_byte
= SBYTES (this);
593 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
594 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
596 textprops
[num_textprops
].argnum
= argnum
;
597 textprops
[num_textprops
].from
= 0;
598 textprops
[num_textprops
++].to
= toindex
;
600 toindex_byte
+= thislen_byte
;
603 /* Copy a single-byte string to a multibyte string. */
604 else if (STRINGP (this) && STRINGP (val
))
606 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
608 textprops
[num_textprops
].argnum
= argnum
;
609 textprops
[num_textprops
].from
= 0;
610 textprops
[num_textprops
++].to
= toindex
;
612 toindex_byte
+= copy_text (SDATA (this),
613 SDATA (val
) + toindex_byte
,
614 SCHARS (this), 0, 1);
618 /* Copy element by element. */
621 register Lisp_Object elt
;
623 /* Fetch next element of `this' arg into `elt', or break if
624 `this' is exhausted. */
625 if (NILP (this)) break;
627 elt
= XCAR (this), this = XCDR (this);
628 else if (thisindex
>= thisleni
)
630 else if (STRINGP (this))
633 if (STRING_MULTIBYTE (this))
635 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
638 XSETFASTINT (elt
, c
);
642 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
644 && !ASCII_CHAR_P (XINT (elt
))
645 && XINT (elt
) < 0400)
647 c
= BYTE8_TO_CHAR (XINT (elt
));
652 else if (BOOL_VECTOR_P (this))
655 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
656 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
664 elt
= AREF (this, thisindex
);
668 /* Store this element into the result. */
675 else if (VECTORP (val
))
677 ASET (val
, toindex
, elt
);
683 CHECK_CHARACTER (elt
);
686 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
688 SSET (val
, toindex_byte
++, c
);
694 XSETCDR (prev
, last_tail
);
696 if (num_textprops
> 0)
699 EMACS_INT last_to_end
= -1;
701 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
703 this = args
[textprops
[argnum
].argnum
];
704 props
= text_property_list (this,
706 make_number (SCHARS (this)),
708 /* If successive arguments have properties, be sure that the
709 value of `composition' property be the copy. */
710 if (last_to_end
== textprops
[argnum
].to
)
711 make_composition_value_copy (props
);
712 add_text_properties_from_list (val
, props
,
713 make_number (textprops
[argnum
].to
));
714 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
722 static Lisp_Object string_char_byte_cache_string
;
723 static EMACS_INT string_char_byte_cache_charpos
;
724 static EMACS_INT string_char_byte_cache_bytepos
;
727 clear_string_char_byte_cache (void)
729 string_char_byte_cache_string
= Qnil
;
732 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
735 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
738 EMACS_INT best_below
, best_below_byte
;
739 EMACS_INT best_above
, best_above_byte
;
741 best_below
= best_below_byte
= 0;
742 best_above
= SCHARS (string
);
743 best_above_byte
= SBYTES (string
);
744 if (best_above
== best_above_byte
)
747 if (EQ (string
, string_char_byte_cache_string
))
749 if (string_char_byte_cache_charpos
< char_index
)
751 best_below
= string_char_byte_cache_charpos
;
752 best_below_byte
= string_char_byte_cache_bytepos
;
756 best_above
= string_char_byte_cache_charpos
;
757 best_above_byte
= string_char_byte_cache_bytepos
;
761 if (char_index
- best_below
< best_above
- char_index
)
763 unsigned char *p
= SDATA (string
) + best_below_byte
;
765 while (best_below
< char_index
)
767 p
+= BYTES_BY_CHAR_HEAD (*p
);
770 i_byte
= p
- SDATA (string
);
774 unsigned char *p
= SDATA (string
) + best_above_byte
;
776 while (best_above
> char_index
)
779 while (!CHAR_HEAD_P (*p
)) p
--;
782 i_byte
= p
- SDATA (string
);
785 string_char_byte_cache_bytepos
= i_byte
;
786 string_char_byte_cache_charpos
= char_index
;
787 string_char_byte_cache_string
= string
;
792 /* Return the character index corresponding to BYTE_INDEX in STRING. */
795 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
798 EMACS_INT best_below
, best_below_byte
;
799 EMACS_INT best_above
, best_above_byte
;
801 best_below
= best_below_byte
= 0;
802 best_above
= SCHARS (string
);
803 best_above_byte
= SBYTES (string
);
804 if (best_above
== best_above_byte
)
807 if (EQ (string
, string_char_byte_cache_string
))
809 if (string_char_byte_cache_bytepos
< byte_index
)
811 best_below
= string_char_byte_cache_charpos
;
812 best_below_byte
= string_char_byte_cache_bytepos
;
816 best_above
= string_char_byte_cache_charpos
;
817 best_above_byte
= string_char_byte_cache_bytepos
;
821 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
823 unsigned char *p
= SDATA (string
) + best_below_byte
;
824 unsigned char *pend
= SDATA (string
) + byte_index
;
828 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
837 unsigned char *pbeg
= SDATA (string
) + byte_index
;
842 while (!CHAR_HEAD_P (*p
)) p
--;
846 i_byte
= p
- SDATA (string
);
849 string_char_byte_cache_bytepos
= i_byte
;
850 string_char_byte_cache_charpos
= i
;
851 string_char_byte_cache_string
= string
;
856 /* Convert STRING to a multibyte string. */
859 string_make_multibyte (Lisp_Object string
)
866 if (STRING_MULTIBYTE (string
))
869 nbytes
= count_size_as_multibyte (SDATA (string
),
871 /* If all the chars are ASCII, they won't need any more bytes
872 once converted. In that case, we can return STRING itself. */
873 if (nbytes
== SBYTES (string
))
876 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
877 copy_text (SDATA (string
), buf
, SBYTES (string
),
880 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
887 /* Convert STRING (if unibyte) to a multibyte string without changing
888 the number of characters. Characters 0200 trough 0237 are
889 converted to eight-bit characters. */
892 string_to_multibyte (Lisp_Object string
)
899 if (STRING_MULTIBYTE (string
))
902 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
903 /* If all the chars are ASCII, they won't need any more bytes once
905 if (nbytes
== SBYTES (string
))
906 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
908 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
909 memcpy (buf
, SDATA (string
), SBYTES (string
));
910 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
912 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
919 /* Convert STRING to a single-byte string. */
922 string_make_unibyte (Lisp_Object string
)
929 if (! STRING_MULTIBYTE (string
))
932 nchars
= SCHARS (string
);
934 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
935 copy_text (SDATA (string
), buf
, SBYTES (string
),
938 ret
= make_unibyte_string ((char *) buf
, nchars
);
944 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
946 doc
: /* Return the multibyte equivalent of STRING.
947 If STRING is unibyte and contains non-ASCII characters, the function
948 `unibyte-char-to-multibyte' is used to convert each unibyte character
949 to a multibyte character. In this case, the returned string is a
950 newly created string with no text properties. If STRING is multibyte
951 or entirely ASCII, it is returned unchanged. In particular, when
952 STRING is unibyte and entirely ASCII, the returned string is unibyte.
953 \(When the characters are all ASCII, Emacs primitives will treat the
954 string the same way whether it is unibyte or multibyte.) */)
957 CHECK_STRING (string
);
959 return string_make_multibyte (string
);
962 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
964 doc
: /* Return the unibyte equivalent of STRING.
965 Multibyte character codes are converted to unibyte according to
966 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
967 If the lookup in the translation table fails, this function takes just
968 the low 8 bits of each character. */)
971 CHECK_STRING (string
);
973 return string_make_unibyte (string
);
976 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
978 doc
: /* Return a unibyte string with the same individual bytes as STRING.
979 If STRING is unibyte, the result is STRING itself.
980 Otherwise it is a newly created string, with no text properties.
981 If STRING is multibyte and contains a character of charset
982 `eight-bit', it is converted to the corresponding single byte. */)
985 CHECK_STRING (string
);
987 if (STRING_MULTIBYTE (string
))
989 EMACS_INT bytes
= SBYTES (string
);
990 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
992 memcpy (str
, SDATA (string
), bytes
);
993 bytes
= str_as_unibyte (str
, bytes
);
994 string
= make_unibyte_string ((char *) str
, bytes
);
1000 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1002 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1003 If STRING is multibyte, the result is STRING itself.
1004 Otherwise it is a newly created string, with no text properties.
1006 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1007 part of a correct utf-8 sequence), it is converted to the corresponding
1008 multibyte character of charset `eight-bit'.
1009 See also `string-to-multibyte'.
1011 Beware, this often doesn't really do what you think it does.
1012 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1013 If you're not sure, whether to use `string-as-multibyte' or
1014 `string-to-multibyte', use `string-to-multibyte'. */)
1015 (Lisp_Object string
)
1017 CHECK_STRING (string
);
1019 if (! STRING_MULTIBYTE (string
))
1021 Lisp_Object new_string
;
1022 EMACS_INT nchars
, nbytes
;
1024 parse_str_as_multibyte (SDATA (string
),
1027 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1028 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1029 if (nbytes
!= SBYTES (string
))
1030 str_as_multibyte (SDATA (new_string
), nbytes
,
1031 SBYTES (string
), NULL
);
1032 string
= new_string
;
1033 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1038 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1040 doc
: /* Return a multibyte string with the same individual chars as STRING.
1041 If STRING is multibyte, the result is STRING itself.
1042 Otherwise it is a newly created string, with no text properties.
1044 If STRING is unibyte and contains an 8-bit byte, it is converted to
1045 the corresponding multibyte character of charset `eight-bit'.
1047 This differs from `string-as-multibyte' by converting each byte of a correct
1048 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1049 correct sequence. */)
1050 (Lisp_Object string
)
1052 CHECK_STRING (string
);
1054 return string_to_multibyte (string
);
1057 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1059 doc
: /* Return a unibyte string with the same individual chars as STRING.
1060 If STRING is unibyte, the result is STRING itself.
1061 Otherwise it is a newly created string, with no text properties,
1062 where each `eight-bit' character is converted to the corresponding byte.
1063 If STRING contains a non-ASCII, non-`eight-bit' character,
1064 an error is signaled. */)
1065 (Lisp_Object string
)
1067 CHECK_STRING (string
);
1069 if (STRING_MULTIBYTE (string
))
1071 EMACS_INT chars
= SCHARS (string
);
1072 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1073 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1075 if (converted
< chars
)
1076 error ("Can't convert the %"pI
"dth character to unibyte", converted
);
1077 string
= make_unibyte_string ((char *) str
, chars
);
1084 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1085 doc
: /* Return a copy of ALIST.
1086 This is an alist which represents the same mapping from objects to objects,
1087 but does not share the alist structure with ALIST.
1088 The objects mapped (cars and cdrs of elements of the alist)
1089 are shared, however.
1090 Elements of ALIST that are not conses are also shared. */)
1093 register Lisp_Object tem
;
1098 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1099 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1101 register Lisp_Object car
;
1105 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1110 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1111 doc
: /* Return a new string whose contents are a substring of STRING.
1112 The returned string consists of the characters between index FROM
1113 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1114 zero-indexed: 0 means the first character of STRING. Negative values
1115 are counted from the end of STRING. If TO is nil, the substring runs
1116 to the end of STRING.
1118 The STRING argument may also be a vector. In that case, the return
1119 value is a new vector that contains the elements between index FROM
1120 \(inclusive) and index TO (exclusive) of that vector argument. */)
1121 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1125 EMACS_INT size_byte
= 0;
1126 EMACS_INT from_char
, to_char
;
1127 EMACS_INT from_byte
= 0, to_byte
= 0;
1129 CHECK_VECTOR_OR_STRING (string
);
1130 CHECK_NUMBER (from
);
1132 if (STRINGP (string
))
1134 size
= SCHARS (string
);
1135 size_byte
= SBYTES (string
);
1138 size
= ASIZE (string
);
1143 to_byte
= size_byte
;
1149 to_char
= XINT (to
);
1153 if (STRINGP (string
))
1154 to_byte
= string_char_to_byte (string
, to_char
);
1157 from_char
= XINT (from
);
1160 if (STRINGP (string
))
1161 from_byte
= string_char_to_byte (string
, from_char
);
1163 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1164 args_out_of_range_3 (string
, make_number (from_char
),
1165 make_number (to_char
));
1167 if (STRINGP (string
))
1169 res
= make_specified_string (SSDATA (string
) + from_byte
,
1170 to_char
- from_char
, to_byte
- from_byte
,
1171 STRING_MULTIBYTE (string
));
1172 copy_text_properties (make_number (from_char
), make_number (to_char
),
1173 string
, make_number (0), res
, Qnil
);
1176 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1182 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1183 doc
: /* Return a substring of STRING, without text properties.
1184 It starts at index FROM and ends before TO.
1185 TO may be nil or omitted; then the substring runs to the end of STRING.
1186 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1187 If FROM or TO is negative, it counts from the end.
1189 With one argument, just copy STRING without its properties. */)
1190 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1192 EMACS_INT size
, size_byte
;
1193 EMACS_INT from_char
, to_char
;
1194 EMACS_INT from_byte
, to_byte
;
1196 CHECK_STRING (string
);
1198 size
= SCHARS (string
);
1199 size_byte
= SBYTES (string
);
1202 from_char
= from_byte
= 0;
1205 CHECK_NUMBER (from
);
1206 from_char
= XINT (from
);
1210 from_byte
= string_char_to_byte (string
, from_char
);
1216 to_byte
= size_byte
;
1222 to_char
= XINT (to
);
1226 to_byte
= string_char_to_byte (string
, to_char
);
1229 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1230 args_out_of_range_3 (string
, make_number (from_char
),
1231 make_number (to_char
));
1233 return make_specified_string (SSDATA (string
) + from_byte
,
1234 to_char
- from_char
, to_byte
- from_byte
,
1235 STRING_MULTIBYTE (string
));
1238 /* Extract a substring of STRING, giving start and end positions
1239 both in characters and in bytes. */
1242 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1243 EMACS_INT to
, EMACS_INT to_byte
)
1248 CHECK_VECTOR_OR_STRING (string
);
1250 size
= STRINGP (string
) ? SCHARS (string
) : ASIZE (string
);
1252 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1253 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1255 if (STRINGP (string
))
1257 res
= make_specified_string (SSDATA (string
) + from_byte
,
1258 to
- from
, to_byte
- from_byte
,
1259 STRING_MULTIBYTE (string
));
1260 copy_text_properties (make_number (from
), make_number (to
),
1261 string
, make_number (0), res
, Qnil
);
1264 res
= Fvector (to
- from
, &AREF (string
, from
));
1269 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1270 doc
: /* Take cdr N times on LIST, return the result. */)
1271 (Lisp_Object n
, Lisp_Object list
)
1273 register int i
, num
;
1276 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1279 CHECK_LIST_CONS (list
, list
);
1285 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1286 doc
: /* Return the Nth element of LIST.
1287 N counts from zero. If LIST is not that long, nil is returned. */)
1288 (Lisp_Object n
, Lisp_Object list
)
1290 return Fcar (Fnthcdr (n
, list
));
1293 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1294 doc
: /* Return element of SEQUENCE at index N. */)
1295 (register Lisp_Object sequence
, Lisp_Object n
)
1298 if (CONSP (sequence
) || NILP (sequence
))
1299 return Fcar (Fnthcdr (n
, sequence
));
1301 /* Faref signals a "not array" error, so check here. */
1302 CHECK_ARRAY (sequence
, Qsequencep
);
1303 return Faref (sequence
, n
);
1306 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1307 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1308 The value is actually the tail of LIST whose car is ELT. */)
1309 (register Lisp_Object elt
, Lisp_Object list
)
1311 register Lisp_Object tail
;
1312 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1314 register Lisp_Object tem
;
1315 CHECK_LIST_CONS (tail
, list
);
1317 if (! NILP (Fequal (elt
, tem
)))
1324 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1325 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1326 The value is actually the tail of LIST whose car is ELT. */)
1327 (register Lisp_Object elt
, Lisp_Object list
)
1331 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1335 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1339 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1350 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1351 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1352 The value is actually the tail of LIST whose car is ELT. */)
1353 (register Lisp_Object elt
, Lisp_Object list
)
1355 register Lisp_Object tail
;
1358 return Fmemq (elt
, list
);
1360 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1362 register Lisp_Object tem
;
1363 CHECK_LIST_CONS (tail
, list
);
1365 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1372 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1373 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1374 The value is actually the first element of LIST whose car is KEY.
1375 Elements of LIST that are not conses are ignored. */)
1376 (Lisp_Object key
, Lisp_Object list
)
1381 || (CONSP (XCAR (list
))
1382 && EQ (XCAR (XCAR (list
)), key
)))
1387 || (CONSP (XCAR (list
))
1388 && EQ (XCAR (XCAR (list
)), key
)))
1393 || (CONSP (XCAR (list
))
1394 && EQ (XCAR (XCAR (list
)), key
)))
1404 /* Like Fassq but never report an error and do not allow quits.
1405 Use only on lists known never to be circular. */
1408 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1411 && (!CONSP (XCAR (list
))
1412 || !EQ (XCAR (XCAR (list
)), key
)))
1415 return CAR_SAFE (list
);
1418 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1419 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1420 The value is actually the first element of LIST whose car equals KEY. */)
1421 (Lisp_Object key
, Lisp_Object list
)
1428 || (CONSP (XCAR (list
))
1429 && (car
= XCAR (XCAR (list
)),
1430 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1435 || (CONSP (XCAR (list
))
1436 && (car
= XCAR (XCAR (list
)),
1437 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1442 || (CONSP (XCAR (list
))
1443 && (car
= XCAR (XCAR (list
)),
1444 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1454 /* Like Fassoc but never report an error and do not allow quits.
1455 Use only on lists known never to be circular. */
1458 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1461 && (!CONSP (XCAR (list
))
1462 || (!EQ (XCAR (XCAR (list
)), key
)
1463 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1466 return CONSP (list
) ? XCAR (list
) : Qnil
;
1469 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1470 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1471 The value is actually the first element of LIST whose cdr is KEY. */)
1472 (register Lisp_Object key
, Lisp_Object list
)
1477 || (CONSP (XCAR (list
))
1478 && EQ (XCDR (XCAR (list
)), key
)))
1483 || (CONSP (XCAR (list
))
1484 && EQ (XCDR (XCAR (list
)), key
)))
1489 || (CONSP (XCAR (list
))
1490 && EQ (XCDR (XCAR (list
)), key
)))
1500 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1501 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1502 The value is actually the first element of LIST whose cdr equals KEY. */)
1503 (Lisp_Object key
, Lisp_Object list
)
1510 || (CONSP (XCAR (list
))
1511 && (cdr
= XCDR (XCAR (list
)),
1512 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1536 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1537 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1538 The modified LIST is returned. Comparison is done with `eq'.
1539 If the first member of LIST is ELT, there is no way to remove it by side effect;
1540 therefore, write `(setq foo (delq element foo))'
1541 to be sure of changing the value of `foo'. */)
1542 (register Lisp_Object elt
, Lisp_Object list
)
1544 register Lisp_Object tail
, prev
;
1545 register Lisp_Object tem
;
1549 while (!NILP (tail
))
1551 CHECK_LIST_CONS (tail
, list
);
1558 Fsetcdr (prev
, XCDR (tail
));
1568 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1569 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1570 SEQ must be a list, a vector, or a string.
1571 The modified SEQ is returned. Comparison is done with `equal'.
1572 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1573 is not a side effect; it is simply using a different sequence.
1574 Therefore, write `(setq foo (delete element foo))'
1575 to be sure of changing the value of `foo'. */)
1576 (Lisp_Object elt
, Lisp_Object seq
)
1582 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1583 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1586 if (n
!= ASIZE (seq
))
1588 struct Lisp_Vector
*p
= allocate_vector (n
);
1590 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1591 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1592 p
->contents
[n
++] = AREF (seq
, i
);
1594 XSETVECTOR (seq
, p
);
1597 else if (STRINGP (seq
))
1599 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1602 for (i
= nchars
= nbytes
= ibyte
= 0;
1604 ++i
, ibyte
+= cbytes
)
1606 if (STRING_MULTIBYTE (seq
))
1608 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1609 cbytes
= CHAR_BYTES (c
);
1617 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1624 if (nchars
!= SCHARS (seq
))
1628 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1629 if (!STRING_MULTIBYTE (seq
))
1630 STRING_SET_UNIBYTE (tem
);
1632 for (i
= nchars
= nbytes
= ibyte
= 0;
1634 ++i
, ibyte
+= cbytes
)
1636 if (STRING_MULTIBYTE (seq
))
1638 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1639 cbytes
= CHAR_BYTES (c
);
1647 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1649 unsigned char *from
= SDATA (seq
) + ibyte
;
1650 unsigned char *to
= SDATA (tem
) + nbytes
;
1656 for (n
= cbytes
; n
--; )
1666 Lisp_Object tail
, prev
;
1668 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1670 CHECK_LIST_CONS (tail
, seq
);
1672 if (!NILP (Fequal (elt
, XCAR (tail
))))
1677 Fsetcdr (prev
, XCDR (tail
));
1688 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1689 doc
: /* Reverse LIST by modifying cdr pointers.
1690 Return the reversed list. */)
1693 register Lisp_Object prev
, tail
, next
;
1695 if (NILP (list
)) return list
;
1698 while (!NILP (tail
))
1701 CHECK_LIST_CONS (tail
, list
);
1703 Fsetcdr (tail
, prev
);
1710 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1711 doc
: /* Reverse LIST, copying. Return the reversed list.
1712 See also the function `nreverse', which is used more often. */)
1717 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1720 new = Fcons (XCAR (list
), new);
1722 CHECK_LIST_END (list
, list
);
1726 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1728 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1729 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1730 Returns the sorted list. LIST is modified by side effects.
1731 PREDICATE is called with two elements of LIST, and should return non-nil
1732 if the first element should sort before the second. */)
1733 (Lisp_Object list
, Lisp_Object predicate
)
1735 Lisp_Object front
, back
;
1736 register Lisp_Object len
, tem
;
1737 struct gcpro gcpro1
, gcpro2
;
1738 register int length
;
1741 len
= Flength (list
);
1742 length
= XINT (len
);
1746 XSETINT (len
, (length
/ 2) - 1);
1747 tem
= Fnthcdr (len
, list
);
1749 Fsetcdr (tem
, Qnil
);
1751 GCPRO2 (front
, back
);
1752 front
= Fsort (front
, predicate
);
1753 back
= Fsort (back
, predicate
);
1755 return merge (front
, back
, predicate
);
1759 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1762 register Lisp_Object tail
;
1764 register Lisp_Object l1
, l2
;
1765 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1772 /* It is sufficient to protect org_l1 and org_l2.
1773 When l1 and l2 are updated, we copy the new values
1774 back into the org_ vars. */
1775 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1795 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1811 Fsetcdr (tail
, tem
);
1817 /* This does not check for quits. That is safe since it must terminate. */
1819 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1820 doc
: /* Extract a value from a property list.
1821 PLIST is a property list, which is a list of the form
1822 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1823 corresponding to the given PROP, or nil if PROP is not one of the
1824 properties on the list. This function never signals an error. */)
1825 (Lisp_Object plist
, Lisp_Object prop
)
1827 Lisp_Object tail
, halftail
;
1829 /* halftail is used to detect circular lists. */
1830 tail
= halftail
= plist
;
1831 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1833 if (EQ (prop
, XCAR (tail
)))
1834 return XCAR (XCDR (tail
));
1836 tail
= XCDR (XCDR (tail
));
1837 halftail
= XCDR (halftail
);
1838 if (EQ (tail
, halftail
))
1841 #if 0 /* Unsafe version. */
1842 /* This function can be called asynchronously
1843 (setup_coding_system). Don't QUIT in that case. */
1844 if (!interrupt_input_blocked
)
1852 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1853 doc
: /* Return the value of SYMBOL's PROPNAME property.
1854 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1855 (Lisp_Object symbol
, Lisp_Object propname
)
1857 CHECK_SYMBOL (symbol
);
1858 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1861 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1862 doc
: /* Change value in PLIST of PROP to VAL.
1863 PLIST is a property list, which is a list of the form
1864 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1865 If PROP is already a property on the list, its value is set to VAL,
1866 otherwise the new PROP VAL pair is added. The new plist is returned;
1867 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1868 The PLIST is modified by side effects. */)
1869 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1871 register Lisp_Object tail
, prev
;
1872 Lisp_Object newcell
;
1874 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1875 tail
= XCDR (XCDR (tail
)))
1877 if (EQ (prop
, XCAR (tail
)))
1879 Fsetcar (XCDR (tail
), val
);
1886 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1890 Fsetcdr (XCDR (prev
), newcell
);
1894 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1895 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1896 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1897 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1899 CHECK_SYMBOL (symbol
);
1900 XSYMBOL (symbol
)->plist
1901 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1905 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1906 doc
: /* Extract a value from a property list, comparing with `equal'.
1907 PLIST is a property list, which is a list of the form
1908 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1909 corresponding to the given PROP, or nil if PROP is not
1910 one of the properties on the list. */)
1911 (Lisp_Object plist
, Lisp_Object prop
)
1916 CONSP (tail
) && CONSP (XCDR (tail
));
1917 tail
= XCDR (XCDR (tail
)))
1919 if (! NILP (Fequal (prop
, XCAR (tail
))))
1920 return XCAR (XCDR (tail
));
1925 CHECK_LIST_END (tail
, prop
);
1930 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1931 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1932 PLIST is a property list, which is a list of the form
1933 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1934 If PROP is already a property on the list, its value is set to VAL,
1935 otherwise the new PROP VAL pair is added. The new plist is returned;
1936 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1937 The PLIST is modified by side effects. */)
1938 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1940 register Lisp_Object tail
, prev
;
1941 Lisp_Object newcell
;
1943 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1944 tail
= XCDR (XCDR (tail
)))
1946 if (! NILP (Fequal (prop
, XCAR (tail
))))
1948 Fsetcar (XCDR (tail
), val
);
1955 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1959 Fsetcdr (XCDR (prev
), newcell
);
1963 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1964 doc
: /* Return t if the two args are the same Lisp object.
1965 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1966 (Lisp_Object obj1
, Lisp_Object obj2
)
1969 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1971 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1974 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1975 doc
: /* Return t if two Lisp objects have similar structure and contents.
1976 They must have the same data type.
1977 Conses are compared by comparing the cars and the cdrs.
1978 Vectors and strings are compared element by element.
1979 Numbers are compared by value, but integers cannot equal floats.
1980 (Use `=' if you want integers and floats to be able to be equal.)
1981 Symbols must match exactly. */)
1982 (register Lisp_Object o1
, Lisp_Object o2
)
1984 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1987 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1988 doc
: /* Return t if two Lisp objects have similar structure and contents.
1989 This is like `equal' except that it compares the text properties
1990 of strings. (`equal' ignores text properties.) */)
1991 (register Lisp_Object o1
, Lisp_Object o2
)
1993 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
1996 /* DEPTH is current depth of recursion. Signal an error if it
1998 PROPS, if non-nil, means compare string text properties too. */
2001 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2004 error ("Stack overflow in equal");
2010 if (XTYPE (o1
) != XTYPE (o2
))
2019 d1
= extract_float (o1
);
2020 d2
= extract_float (o2
);
2021 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2022 though they are not =. */
2023 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2027 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2034 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2038 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2040 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2043 o1
= XOVERLAY (o1
)->plist
;
2044 o2
= XOVERLAY (o2
)->plist
;
2049 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2050 && (XMARKER (o1
)->buffer
== 0
2051 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2055 case Lisp_Vectorlike
:
2058 EMACS_INT size
= ASIZE (o1
);
2059 /* Pseudovectors have the type encoded in the size field, so this test
2060 actually checks that the objects have the same type as well as the
2062 if (ASIZE (o2
) != size
)
2064 /* Boolvectors are compared much like strings. */
2065 if (BOOL_VECTOR_P (o1
))
2067 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2069 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2070 ((XBOOL_VECTOR (o1
)->size
2071 + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2072 / BOOL_VECTOR_BITS_PER_CHAR
)))
2076 if (WINDOW_CONFIGURATIONP (o1
))
2077 return compare_window_configurations (o1
, o2
, 0);
2079 /* Aside from them, only true vectors, char-tables, compiled
2080 functions, and fonts (font-spec, font-entity, font-object)
2081 are sensible to compare, so eliminate the others now. */
2082 if (size
& PSEUDOVECTOR_FLAG
)
2084 if (!(size
& (PVEC_COMPILED
2085 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2087 size
&= PSEUDOVECTOR_SIZE_MASK
;
2089 for (i
= 0; i
< size
; i
++)
2094 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2102 if (SCHARS (o1
) != SCHARS (o2
))
2104 if (SBYTES (o1
) != SBYTES (o2
))
2106 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2108 if (props
&& !compare_string_intervals (o1
, o2
))
2120 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2121 doc
: /* Store each element of ARRAY with ITEM.
2122 ARRAY is a vector, string, char-table, or bool-vector. */)
2123 (Lisp_Object array
, Lisp_Object item
)
2125 register EMACS_INT size
, idx
;
2128 if (VECTORP (array
))
2130 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2131 size
= ASIZE (array
);
2132 for (idx
= 0; idx
< size
; idx
++)
2135 else if (CHAR_TABLE_P (array
))
2139 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2140 XCHAR_TABLE (array
)->contents
[i
] = item
;
2141 XCHAR_TABLE (array
)->defalt
= item
;
2143 else if (STRINGP (array
))
2145 register unsigned char *p
= SDATA (array
);
2146 CHECK_NUMBER (item
);
2147 charval
= XINT (item
);
2148 size
= SCHARS (array
);
2149 if (STRING_MULTIBYTE (array
))
2151 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2152 int len
= CHAR_STRING (charval
, str
);
2153 EMACS_INT size_byte
= SBYTES (array
);
2154 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2157 if (size
!= size_byte
)
2160 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2161 if (len
!= this_len
)
2162 error ("Attempt to change byte length of a string");
2165 for (i
= 0; i
< size_byte
; i
++)
2166 *p
++ = str
[i
% len
];
2169 for (idx
= 0; idx
< size
; idx
++)
2172 else if (BOOL_VECTOR_P (array
))
2174 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2176 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2177 / BOOL_VECTOR_BITS_PER_CHAR
);
2179 charval
= (! NILP (item
) ? -1 : 0);
2180 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2182 if (idx
< size_in_chars
)
2184 /* Mask out bits beyond the vector size. */
2185 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2186 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2191 wrong_type_argument (Qarrayp
, array
);
2195 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2197 doc
: /* Clear the contents of STRING.
2198 This makes STRING unibyte and may change its length. */)
2199 (Lisp_Object string
)
2202 CHECK_STRING (string
);
2203 len
= SBYTES (string
);
2204 memset (SDATA (string
), 0, len
);
2205 STRING_SET_CHARS (string
, len
);
2206 STRING_SET_UNIBYTE (string
);
2212 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2214 Lisp_Object args
[2];
2217 return Fnconc (2, args
);
2220 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2221 doc
: /* Concatenate any number of lists by altering them.
2222 Only the last argument is not altered, and need not be a list.
2223 usage: (nconc &rest LISTS) */)
2224 (size_t nargs
, Lisp_Object
*args
)
2226 register size_t argnum
;
2227 register Lisp_Object tail
, tem
, val
;
2231 for (argnum
= 0; argnum
< nargs
; argnum
++)
2234 if (NILP (tem
)) continue;
2239 if (argnum
+ 1 == nargs
) break;
2241 CHECK_LIST_CONS (tem
, tem
);
2250 tem
= args
[argnum
+ 1];
2251 Fsetcdr (tail
, tem
);
2253 args
[argnum
+ 1] = tail
;
2259 /* This is the guts of all mapping functions.
2260 Apply FN to each element of SEQ, one by one,
2261 storing the results into elements of VALS, a C vector of Lisp_Objects.
2262 LENI is the length of VALS, which should also be the length of SEQ. */
2265 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2267 register Lisp_Object tail
;
2269 register EMACS_INT i
;
2270 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2274 /* Don't let vals contain any garbage when GC happens. */
2275 for (i
= 0; i
< leni
; i
++)
2278 GCPRO3 (dummy
, fn
, seq
);
2280 gcpro1
.nvars
= leni
;
2284 /* We need not explicitly protect `tail' because it is used only on lists, and
2285 1) lists are not relocated and 2) the list is marked via `seq' so will not
2288 if (VECTORP (seq
) || COMPILEDP (seq
))
2290 for (i
= 0; i
< leni
; i
++)
2292 dummy
= call1 (fn
, AREF (seq
, i
));
2297 else if (BOOL_VECTOR_P (seq
))
2299 for (i
= 0; i
< leni
; i
++)
2302 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2303 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2304 dummy
= call1 (fn
, dummy
);
2309 else if (STRINGP (seq
))
2313 for (i
= 0, i_byte
= 0; i
< leni
;)
2316 EMACS_INT i_before
= i
;
2318 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2319 XSETFASTINT (dummy
, c
);
2320 dummy
= call1 (fn
, dummy
);
2322 vals
[i_before
] = dummy
;
2325 else /* Must be a list, since Flength did not get an error */
2328 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2330 dummy
= call1 (fn
, XCAR (tail
));
2340 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2341 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2342 In between each pair of results, stick in SEPARATOR. Thus, " " as
2343 SEPARATOR results in spaces between the values returned by FUNCTION.
2344 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2345 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2348 register EMACS_INT leni
;
2350 register Lisp_Object
*args
;
2351 register EMACS_INT i
;
2352 struct gcpro gcpro1
;
2356 len
= Flength (sequence
);
2357 if (CHAR_TABLE_P (sequence
))
2358 wrong_type_argument (Qlistp
, sequence
);
2360 nargs
= leni
+ leni
- 1;
2361 if (nargs
< 0) return empty_unibyte_string
;
2363 SAFE_ALLOCA_LISP (args
, nargs
);
2366 mapcar1 (leni
, args
, function
, sequence
);
2369 for (i
= leni
- 1; i
> 0; i
--)
2370 args
[i
+ i
] = args
[i
];
2372 for (i
= 1; i
< nargs
; i
+= 2)
2373 args
[i
] = separator
;
2375 ret
= Fconcat (nargs
, args
);
2381 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2382 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2383 The result is a list just as long as SEQUENCE.
2384 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2385 (Lisp_Object function
, Lisp_Object sequence
)
2387 register Lisp_Object len
;
2388 register EMACS_INT leni
;
2389 register Lisp_Object
*args
;
2393 len
= Flength (sequence
);
2394 if (CHAR_TABLE_P (sequence
))
2395 wrong_type_argument (Qlistp
, sequence
);
2396 leni
= XFASTINT (len
);
2398 SAFE_ALLOCA_LISP (args
, leni
);
2400 mapcar1 (leni
, args
, function
, sequence
);
2402 ret
= Flist (leni
, args
);
2408 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2409 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2410 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2411 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2412 (Lisp_Object function
, Lisp_Object sequence
)
2414 register EMACS_INT leni
;
2416 leni
= XFASTINT (Flength (sequence
));
2417 if (CHAR_TABLE_P (sequence
))
2418 wrong_type_argument (Qlistp
, sequence
);
2419 mapcar1 (leni
, 0, function
, sequence
);
2424 /* This is how C code calls `yes-or-no-p' and allows the user
2427 Anything that calls this function must protect from GC! */
2430 do_yes_or_no_p (Lisp_Object prompt
)
2432 return call1 (intern ("yes-or-no-p"), prompt
);
2435 /* Anything that calls this function must protect from GC! */
2437 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2438 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2439 PROMPT is the string to display to ask the question. It should end in
2440 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2442 The user must confirm the answer with RET, and can edit it until it
2445 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2446 is nil, and `use-dialog-box' is non-nil. */)
2447 (Lisp_Object prompt
)
2449 register Lisp_Object ans
;
2450 Lisp_Object args
[2];
2451 struct gcpro gcpro1
;
2453 CHECK_STRING (prompt
);
2456 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2457 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2461 Lisp_Object pane
, menu
, obj
;
2462 redisplay_preserve_echo_area (4);
2463 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2464 Fcons (Fcons (build_string ("No"), Qnil
),
2467 menu
= Fcons (prompt
, pane
);
2468 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2472 #endif /* HAVE_MENUS */
2475 args
[1] = build_string ("(yes or no) ");
2476 prompt
= Fconcat (2, args
);
2482 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2483 Qyes_or_no_p_history
, Qnil
,
2485 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2490 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2498 message ("Please answer yes or no.");
2499 Fsleep_for (make_number (2), Qnil
);
2503 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2504 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2506 Each of the three load averages is multiplied by 100, then converted
2509 When USE-FLOATS is non-nil, floats will be used instead of integers.
2510 These floats are not multiplied by 100.
2512 If the 5-minute or 15-minute load averages are not available, return a
2513 shortened list, containing only those averages which are available.
2515 An error is thrown if the load average can't be obtained. In some
2516 cases making it work would require Emacs being installed setuid or
2517 setgid so that it can read kernel information, and that usually isn't
2519 (Lisp_Object use_floats
)
2522 int loads
= getloadavg (load_ave
, 3);
2523 Lisp_Object ret
= Qnil
;
2526 error ("load-average not implemented for this operating system");
2530 Lisp_Object load
= (NILP (use_floats
) ?
2531 make_number ((int) (100.0 * load_ave
[loads
]))
2532 : make_float (load_ave
[loads
]));
2533 ret
= Fcons (load
, ret
);
2539 static Lisp_Object Qsubfeatures
;
2541 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2542 doc
: /* Return t if FEATURE is present in this Emacs.
2544 Use this to conditionalize execution of lisp code based on the
2545 presence or absence of Emacs or environment extensions.
2546 Use `provide' to declare that a feature is available. This function
2547 looks at the value of the variable `features'. The optional argument
2548 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2549 (Lisp_Object feature
, Lisp_Object subfeature
)
2551 register Lisp_Object tem
;
2552 CHECK_SYMBOL (feature
);
2553 tem
= Fmemq (feature
, Vfeatures
);
2554 if (!NILP (tem
) && !NILP (subfeature
))
2555 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2556 return (NILP (tem
)) ? Qnil
: Qt
;
2559 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2560 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2561 The optional argument SUBFEATURES should be a list of symbols listing
2562 particular subfeatures supported in this version of FEATURE. */)
2563 (Lisp_Object feature
, Lisp_Object subfeatures
)
2565 register Lisp_Object tem
;
2566 CHECK_SYMBOL (feature
);
2567 CHECK_LIST (subfeatures
);
2568 if (!NILP (Vautoload_queue
))
2569 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2571 tem
= Fmemq (feature
, Vfeatures
);
2573 Vfeatures
= Fcons (feature
, Vfeatures
);
2574 if (!NILP (subfeatures
))
2575 Fput (feature
, Qsubfeatures
, subfeatures
);
2576 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2578 /* Run any load-hooks for this file. */
2579 tem
= Fassq (feature
, Vafter_load_alist
);
2581 Fprogn (XCDR (tem
));
2586 /* `require' and its subroutines. */
2588 /* List of features currently being require'd, innermost first. */
2590 static Lisp_Object require_nesting_list
;
2593 require_unwind (Lisp_Object old_value
)
2595 return require_nesting_list
= old_value
;
2598 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2599 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2600 If FEATURE is not a member of the list `features', then the feature
2601 is not loaded; so load the file FILENAME.
2602 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2603 and `load' will try to load this name appended with the suffix `.elc' or
2604 `.el', in that order. The name without appended suffix will not be used.
2605 If the optional third argument NOERROR is non-nil,
2606 then return nil if the file is not found instead of signaling an error.
2607 Normally the return value is FEATURE.
2608 The normal messages at start and end of loading FILENAME are suppressed. */)
2609 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2611 register Lisp_Object tem
;
2612 struct gcpro gcpro1
, gcpro2
;
2613 int from_file
= load_in_progress
;
2615 CHECK_SYMBOL (feature
);
2617 /* Record the presence of `require' in this file
2618 even if the feature specified is already loaded.
2619 But not more than once in any file,
2620 and not when we aren't loading or reading from a file. */
2622 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2623 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2628 tem
= Fcons (Qrequire
, feature
);
2629 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2630 LOADHIST_ATTACH (tem
);
2632 tem
= Fmemq (feature
, Vfeatures
);
2636 int count
= SPECPDL_INDEX ();
2639 /* This is to make sure that loadup.el gives a clear picture
2640 of what files are preloaded and when. */
2641 if (! NILP (Vpurify_flag
))
2642 error ("(require %s) while preparing to dump",
2643 SDATA (SYMBOL_NAME (feature
)));
2645 /* A certain amount of recursive `require' is legitimate,
2646 but if we require the same feature recursively 3 times,
2648 tem
= require_nesting_list
;
2649 while (! NILP (tem
))
2651 if (! NILP (Fequal (feature
, XCAR (tem
))))
2656 error ("Recursive `require' for feature `%s'",
2657 SDATA (SYMBOL_NAME (feature
)));
2659 /* Update the list for any nested `require's that occur. */
2660 record_unwind_protect (require_unwind
, require_nesting_list
);
2661 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2663 /* Value saved here is to be restored into Vautoload_queue */
2664 record_unwind_protect (un_autoload
, Vautoload_queue
);
2665 Vautoload_queue
= Qt
;
2667 /* Load the file. */
2668 GCPRO2 (feature
, filename
);
2669 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2670 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2673 /* If load failed entirely, return nil. */
2675 return unbind_to (count
, Qnil
);
2677 tem
= Fmemq (feature
, Vfeatures
);
2679 error ("Required feature `%s' was not provided",
2680 SDATA (SYMBOL_NAME (feature
)));
2682 /* Once loading finishes, don't undo it. */
2683 Vautoload_queue
= Qt
;
2684 feature
= unbind_to (count
, feature
);
2690 /* Primitives for work of the "widget" library.
2691 In an ideal world, this section would not have been necessary.
2692 However, lisp function calls being as slow as they are, it turns
2693 out that some functions in the widget library (wid-edit.el) are the
2694 bottleneck of Widget operation. Here is their translation to C,
2695 for the sole reason of efficiency. */
2697 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2698 doc
: /* Return non-nil if PLIST has the property PROP.
2699 PLIST is a property list, which is a list of the form
2700 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2701 Unlike `plist-get', this allows you to distinguish between a missing
2702 property and a property with the value nil.
2703 The value is actually the tail of PLIST whose car is PROP. */)
2704 (Lisp_Object plist
, Lisp_Object prop
)
2706 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2709 plist
= XCDR (plist
);
2710 plist
= CDR (plist
);
2715 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2716 doc
: /* In WIDGET, set PROPERTY to VALUE.
2717 The value can later be retrieved with `widget-get'. */)
2718 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2720 CHECK_CONS (widget
);
2721 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2725 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2726 doc
: /* In WIDGET, get the value of PROPERTY.
2727 The value could either be specified when the widget was created, or
2728 later with `widget-put'. */)
2729 (Lisp_Object widget
, Lisp_Object property
)
2737 CHECK_CONS (widget
);
2738 tmp
= Fplist_member (XCDR (widget
), property
);
2744 tmp
= XCAR (widget
);
2747 widget
= Fget (tmp
, Qwidget_type
);
2751 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2752 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2753 ARGS are passed as extra arguments to the function.
2754 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2755 (size_t nargs
, Lisp_Object
*args
)
2757 /* This function can GC. */
2758 Lisp_Object newargs
[3];
2759 struct gcpro gcpro1
, gcpro2
;
2762 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2763 newargs
[1] = args
[0];
2764 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2765 GCPRO2 (newargs
[0], newargs
[2]);
2766 result
= Fapply (3, newargs
);
2771 #ifdef HAVE_LANGINFO_CODESET
2772 #include <langinfo.h>
2775 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2776 doc
: /* Access locale data ITEM for the current C locale, if available.
2777 ITEM should be one of the following:
2779 `codeset', returning the character set as a string (locale item CODESET);
2781 `days', returning a 7-element vector of day names (locale items DAY_n);
2783 `months', returning a 12-element vector of month names (locale items MON_n);
2785 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2786 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2788 If the system can't provide such information through a call to
2789 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2791 See also Info node `(libc)Locales'.
2793 The data read from the system are decoded using `locale-coding-system'. */)
2797 #ifdef HAVE_LANGINFO_CODESET
2799 if (EQ (item
, Qcodeset
))
2801 str
= nl_langinfo (CODESET
);
2802 return build_string (str
);
2805 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2807 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2808 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2810 struct gcpro gcpro1
;
2812 synchronize_system_time_locale ();
2813 for (i
= 0; i
< 7; i
++)
2815 str
= nl_langinfo (days
[i
]);
2816 val
= make_unibyte_string (str
, strlen (str
));
2817 /* Fixme: Is this coding system necessarily right, even if
2818 it is consistent with CODESET? If not, what to do? */
2819 Faset (v
, make_number (i
),
2820 code_convert_string_norecord (val
, Vlocale_coding_system
,
2828 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2830 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2831 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2832 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2834 struct gcpro gcpro1
;
2836 synchronize_system_time_locale ();
2837 for (i
= 0; i
< 12; i
++)
2839 str
= nl_langinfo (months
[i
]);
2840 val
= make_unibyte_string (str
, strlen (str
));
2841 Faset (v
, make_number (i
),
2842 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2848 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2849 but is in the locale files. This could be used by ps-print. */
2851 else if (EQ (item
, Qpaper
))
2853 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2854 make_number (nl_langinfo (PAPER_HEIGHT
)));
2856 #endif /* PAPER_WIDTH */
2857 #endif /* HAVE_LANGINFO_CODESET*/
2861 /* base64 encode/decode functions (RFC 2045).
2862 Based on code from GNU recode. */
2864 #define MIME_LINE_LENGTH 76
2866 #define IS_ASCII(Character) \
2868 #define IS_BASE64(Character) \
2869 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2870 #define IS_BASE64_IGNORABLE(Character) \
2871 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2872 || (Character) == '\f' || (Character) == '\r')
2874 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2875 character or return retval if there are no characters left to
2877 #define READ_QUADRUPLET_BYTE(retval) \
2882 if (nchars_return) \
2883 *nchars_return = nchars; \
2888 while (IS_BASE64_IGNORABLE (c))
2890 /* Table of characters coding the 64 values. */
2891 static const char base64_value_to_char
[64] =
2893 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2894 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2895 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2896 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2897 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2898 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2899 '8', '9', '+', '/' /* 60-63 */
2902 /* Table of base64 values for first 128 characters. */
2903 static const short base64_char_to_value
[128] =
2905 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2906 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2907 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2908 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2909 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2910 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2911 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2912 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2913 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2914 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2915 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2916 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2917 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2920 /* The following diagram shows the logical steps by which three octets
2921 get transformed into four base64 characters.
2923 .--------. .--------. .--------.
2924 |aaaaaabb| |bbbbcccc| |ccdddddd|
2925 `--------' `--------' `--------'
2927 .--------+--------+--------+--------.
2928 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2929 `--------+--------+--------+--------'
2931 .--------+--------+--------+--------.
2932 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2933 `--------+--------+--------+--------'
2935 The octets are divided into 6 bit chunks, which are then encoded into
2936 base64 characters. */
2939 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2940 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2943 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2945 doc
: /* Base64-encode the region between BEG and END.
2946 Return the length of the encoded text.
2947 Optional third argument NO-LINE-BREAK means do not break long lines
2948 into shorter lines. */)
2949 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2952 EMACS_INT allength
, length
;
2953 EMACS_INT ibeg
, iend
, encoded_length
;
2954 EMACS_INT old_pos
= PT
;
2957 validate_region (&beg
, &end
);
2959 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2960 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2961 move_gap_both (XFASTINT (beg
), ibeg
);
2963 /* We need to allocate enough room for encoding the text.
2964 We need 33 1/3% more space, plus a newline every 76
2965 characters, and then we round up. */
2966 length
= iend
- ibeg
;
2967 allength
= length
+ length
/3 + 1;
2968 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2970 SAFE_ALLOCA (encoded
, char *, allength
);
2971 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2972 encoded
, length
, NILP (no_line_break
),
2973 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2974 if (encoded_length
> allength
)
2977 if (encoded_length
< 0)
2979 /* The encoding wasn't possible. */
2981 error ("Multibyte character in data for base64 encoding");
2984 /* Now we have encoded the region, so we insert the new contents
2985 and delete the old. (Insert first in order to preserve markers.) */
2986 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2987 insert (encoded
, encoded_length
);
2989 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2991 /* If point was outside of the region, restore it exactly; else just
2992 move to the beginning of the region. */
2993 if (old_pos
>= XFASTINT (end
))
2994 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2995 else if (old_pos
> XFASTINT (beg
))
2996 old_pos
= XFASTINT (beg
);
2999 /* We return the length of the encoded text. */
3000 return make_number (encoded_length
);
3003 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3005 doc
: /* Base64-encode STRING and return the result.
3006 Optional second argument NO-LINE-BREAK means do not break long lines
3007 into shorter lines. */)
3008 (Lisp_Object string
, Lisp_Object no_line_break
)
3010 EMACS_INT allength
, length
, encoded_length
;
3012 Lisp_Object encoded_string
;
3015 CHECK_STRING (string
);
3017 /* We need to allocate enough room for encoding the text.
3018 We need 33 1/3% more space, plus a newline every 76
3019 characters, and then we round up. */
3020 length
= SBYTES (string
);
3021 allength
= length
+ length
/3 + 1;
3022 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3024 /* We need to allocate enough room for decoding the text. */
3025 SAFE_ALLOCA (encoded
, char *, allength
);
3027 encoded_length
= base64_encode_1 (SSDATA (string
),
3028 encoded
, length
, NILP (no_line_break
),
3029 STRING_MULTIBYTE (string
));
3030 if (encoded_length
> allength
)
3033 if (encoded_length
< 0)
3035 /* The encoding wasn't possible. */
3037 error ("Multibyte character in data for base64 encoding");
3040 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3043 return encoded_string
;
3047 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3048 int line_break
, int multibyte
)
3061 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3062 if (CHAR_BYTE8_P (c
))
3063 c
= CHAR_TO_BYTE8 (c
);
3071 /* Wrap line every 76 characters. */
3075 if (counter
< MIME_LINE_LENGTH
/ 4)
3084 /* Process first byte of a triplet. */
3086 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3087 value
= (0x03 & c
) << 4;
3089 /* Process second byte of a triplet. */
3093 *e
++ = base64_value_to_char
[value
];
3101 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3102 if (CHAR_BYTE8_P (c
))
3103 c
= CHAR_TO_BYTE8 (c
);
3111 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3112 value
= (0x0f & c
) << 2;
3114 /* Process third byte of a triplet. */
3118 *e
++ = base64_value_to_char
[value
];
3125 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3126 if (CHAR_BYTE8_P (c
))
3127 c
= CHAR_TO_BYTE8 (c
);
3135 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3136 *e
++ = base64_value_to_char
[0x3f & c
];
3143 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3145 doc
: /* Base64-decode the region between BEG and END.
3146 Return the length of the decoded text.
3147 If the region can't be decoded, signal an error and don't modify the buffer. */)
3148 (Lisp_Object beg
, Lisp_Object end
)
3150 EMACS_INT ibeg
, iend
, length
, allength
;
3152 EMACS_INT old_pos
= PT
;
3153 EMACS_INT decoded_length
;
3154 EMACS_INT inserted_chars
;
3155 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3158 validate_region (&beg
, &end
);
3160 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3161 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3163 length
= iend
- ibeg
;
3165 /* We need to allocate enough room for decoding the text. If we are
3166 working on a multibyte buffer, each decoded code may occupy at
3168 allength
= multibyte
? length
* 2 : length
;
3169 SAFE_ALLOCA (decoded
, char *, allength
);
3171 move_gap_both (XFASTINT (beg
), ibeg
);
3172 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3174 multibyte
, &inserted_chars
);
3175 if (decoded_length
> allength
)
3178 if (decoded_length
< 0)
3180 /* The decoding wasn't possible. */
3182 error ("Invalid base64 data");
3185 /* Now we have decoded the region, so we insert the new contents
3186 and delete the old. (Insert first in order to preserve markers.) */
3187 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3188 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3191 /* Delete the original text. */
3192 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3193 iend
+ decoded_length
, 1);
3195 /* If point was outside of the region, restore it exactly; else just
3196 move to the beginning of the region. */
3197 if (old_pos
>= XFASTINT (end
))
3198 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3199 else if (old_pos
> XFASTINT (beg
))
3200 old_pos
= XFASTINT (beg
);
3201 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3203 return make_number (inserted_chars
);
3206 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3208 doc
: /* Base64-decode STRING and return the result. */)
3209 (Lisp_Object string
)
3212 EMACS_INT length
, decoded_length
;
3213 Lisp_Object decoded_string
;
3216 CHECK_STRING (string
);
3218 length
= SBYTES (string
);
3219 /* We need to allocate enough room for decoding the text. */
3220 SAFE_ALLOCA (decoded
, char *, length
);
3222 /* The decoded result should be unibyte. */
3223 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3225 if (decoded_length
> length
)
3227 else if (decoded_length
>= 0)
3228 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3230 decoded_string
= Qnil
;
3233 if (!STRINGP (decoded_string
))
3234 error ("Invalid base64 data");
3236 return decoded_string
;
3239 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3240 MULTIBYTE is nonzero, the decoded result should be in multibyte
3241 form. If NCHARS_RETRUN is not NULL, store the number of produced
3242 characters in *NCHARS_RETURN. */
3245 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3246 int multibyte
, EMACS_INT
*nchars_return
)
3248 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3251 unsigned long value
;
3252 EMACS_INT nchars
= 0;
3256 /* Process first byte of a quadruplet. */
3258 READ_QUADRUPLET_BYTE (e
-to
);
3262 value
= base64_char_to_value
[c
] << 18;
3264 /* Process second byte of a quadruplet. */
3266 READ_QUADRUPLET_BYTE (-1);
3270 value
|= base64_char_to_value
[c
] << 12;
3272 c
= (unsigned char) (value
>> 16);
3273 if (multibyte
&& c
>= 128)
3274 e
+= BYTE8_STRING (c
, e
);
3279 /* Process third byte of a quadruplet. */
3281 READ_QUADRUPLET_BYTE (-1);
3285 READ_QUADRUPLET_BYTE (-1);
3294 value
|= base64_char_to_value
[c
] << 6;
3296 c
= (unsigned char) (0xff & value
>> 8);
3297 if (multibyte
&& c
>= 128)
3298 e
+= BYTE8_STRING (c
, e
);
3303 /* Process fourth byte of a quadruplet. */
3305 READ_QUADRUPLET_BYTE (-1);
3312 value
|= base64_char_to_value
[c
];
3314 c
= (unsigned char) (0xff & value
);
3315 if (multibyte
&& c
>= 128)
3316 e
+= BYTE8_STRING (c
, e
);
3325 /***********************************************************************
3327 ***** Hash Tables *****
3329 ***********************************************************************/
3331 /* Implemented by gerd@gnu.org. This hash table implementation was
3332 inspired by CMUCL hash tables. */
3336 1. For small tables, association lists are probably faster than
3337 hash tables because they have lower overhead.
3339 For uses of hash tables where the O(1) behavior of table
3340 operations is not a requirement, it might therefore be a good idea
3341 not to hash. Instead, we could just do a linear search in the
3342 key_and_value vector of the hash table. This could be done
3343 if a `:linear-search t' argument is given to make-hash-table. */
3346 /* The list of all weak hash tables. Don't staticpro this one. */
3348 static struct Lisp_Hash_Table
*weak_hash_tables
;
3350 /* Various symbols. */
3352 static Lisp_Object Qhash_table_p
, Qkey
, Qvalue
;
3353 Lisp_Object Qeq
, Qeql
, Qequal
;
3354 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3355 static Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3357 /* Function prototypes. */
3359 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3360 static size_t get_key_arg (Lisp_Object
, size_t, Lisp_Object
*, char *);
3361 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3362 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3366 /***********************************************************************
3368 ***********************************************************************/
3370 /* If OBJ is a Lisp hash table, return a pointer to its struct
3371 Lisp_Hash_Table. Otherwise, signal an error. */
3373 static struct Lisp_Hash_Table
*
3374 check_hash_table (Lisp_Object obj
)
3376 CHECK_HASH_TABLE (obj
);
3377 return XHASH_TABLE (obj
);
3381 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3385 next_almost_prime (EMACS_INT n
)
3397 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3398 which USED[I] is non-zero. If found at index I in ARGS, set
3399 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3400 0. This function is used to extract a keyword/argument pair from
3401 a DEFUN parameter list. */
3404 get_key_arg (Lisp_Object key
, size_t nargs
, Lisp_Object
*args
, char *used
)
3408 for (i
= 1; i
< nargs
; i
++)
3409 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3420 /* Return a Lisp vector which has the same contents as VEC but has
3421 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3422 vector that are not copied from VEC are set to INIT. */
3425 larger_vector (Lisp_Object vec
, EMACS_INT new_size
, Lisp_Object init
)
3427 struct Lisp_Vector
*v
;
3428 EMACS_INT i
, old_size
;
3430 xassert (VECTORP (vec
));
3431 old_size
= ASIZE (vec
);
3432 xassert (new_size
>= old_size
);
3434 v
= allocate_vector (new_size
);
3435 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3436 for (i
= old_size
; i
< new_size
; ++i
)
3437 v
->contents
[i
] = init
;
3438 XSETVECTOR (vec
, v
);
3443 /***********************************************************************
3445 ***********************************************************************/
3447 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3448 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3449 KEY2 are the same. */
3452 cmpfn_eql (struct Lisp_Hash_Table
*h
,
3453 Lisp_Object key1
, EMACS_UINT hash1
,
3454 Lisp_Object key2
, EMACS_UINT hash2
)
3456 return (FLOATP (key1
)
3458 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3462 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3463 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3464 KEY2 are the same. */
3467 cmpfn_equal (struct Lisp_Hash_Table
*h
,
3468 Lisp_Object key1
, EMACS_UINT hash1
,
3469 Lisp_Object key2
, EMACS_UINT hash2
)
3471 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3475 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3476 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3477 if KEY1 and KEY2 are the same. */
3480 cmpfn_user_defined (struct Lisp_Hash_Table
*h
,
3481 Lisp_Object key1
, EMACS_UINT hash1
,
3482 Lisp_Object key2
, EMACS_UINT hash2
)
3486 Lisp_Object args
[3];
3488 args
[0] = h
->user_cmp_function
;
3491 return !NILP (Ffuncall (3, args
));
3498 /* Value is a hash code for KEY for use in hash table H which uses
3499 `eq' to compare keys. The hash code returned is guaranteed to fit
3500 in a Lisp integer. */
3503 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3505 EMACS_UINT hash
= XUINT (key
) ^ XTYPE (key
);
3506 xassert ((hash
& ~INTMASK
) == 0);
3511 /* Value is a hash code for KEY for use in hash table H which uses
3512 `eql' to compare keys. The hash code returned is guaranteed to fit
3513 in a Lisp integer. */
3516 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3520 hash
= sxhash (key
, 0);
3522 hash
= XUINT (key
) ^ XTYPE (key
);
3523 xassert ((hash
& ~INTMASK
) == 0);
3528 /* Value is a hash code for KEY for use in hash table H which uses
3529 `equal' to compare keys. The hash code returned is guaranteed to fit
3530 in a Lisp integer. */
3533 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3535 EMACS_UINT hash
= sxhash (key
, 0);
3536 xassert ((hash
& ~INTMASK
) == 0);
3541 /* Value is a hash code for KEY for use in hash table H which uses as
3542 user-defined function to compare keys. The hash code returned is
3543 guaranteed to fit in a Lisp integer. */
3546 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3548 Lisp_Object args
[2], hash
;
3550 args
[0] = h
->user_hash_function
;
3552 hash
= Ffuncall (2, args
);
3553 if (!INTEGERP (hash
))
3554 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3555 return XUINT (hash
);
3559 /* Create and initialize a new hash table.
3561 TEST specifies the test the hash table will use to compare keys.
3562 It must be either one of the predefined tests `eq', `eql' or
3563 `equal' or a symbol denoting a user-defined test named TEST with
3564 test and hash functions USER_TEST and USER_HASH.
3566 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3568 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3569 new size when it becomes full is computed by adding REHASH_SIZE to
3570 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3571 table's new size is computed by multiplying its old size with
3574 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3575 be resized when the ratio of (number of entries in the table) /
3576 (table size) is >= REHASH_THRESHOLD.
3578 WEAK specifies the weakness of the table. If non-nil, it must be
3579 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3582 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3583 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3584 Lisp_Object user_test
, Lisp_Object user_hash
)
3586 struct Lisp_Hash_Table
*h
;
3588 EMACS_INT index_size
, i
, sz
;
3591 /* Preconditions. */
3592 xassert (SYMBOLP (test
));
3593 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3594 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3595 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3596 xassert (FLOATP (rehash_threshold
)
3597 && 0 < XFLOAT_DATA (rehash_threshold
)
3598 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3600 if (XFASTINT (size
) == 0)
3601 size
= make_number (1);
3603 sz
= XFASTINT (size
);
3604 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3605 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3606 ? next_almost_prime (index_float
)
3607 : MOST_POSITIVE_FIXNUM
+ 1);
3608 if (MOST_POSITIVE_FIXNUM
< max (index_size
, 2 * sz
))
3609 error ("Hash table too large");
3611 /* Allocate a table and initialize it. */
3612 h
= allocate_hash_table ();
3614 /* Initialize hash table slots. */
3616 if (EQ (test
, Qeql
))
3618 h
->cmpfn
= cmpfn_eql
;
3619 h
->hashfn
= hashfn_eql
;
3621 else if (EQ (test
, Qeq
))
3624 h
->hashfn
= hashfn_eq
;
3626 else if (EQ (test
, Qequal
))
3628 h
->cmpfn
= cmpfn_equal
;
3629 h
->hashfn
= hashfn_equal
;
3633 h
->user_cmp_function
= user_test
;
3634 h
->user_hash_function
= user_hash
;
3635 h
->cmpfn
= cmpfn_user_defined
;
3636 h
->hashfn
= hashfn_user_defined
;
3640 h
->rehash_threshold
= rehash_threshold
;
3641 h
->rehash_size
= rehash_size
;
3643 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3644 h
->hash
= Fmake_vector (size
, Qnil
);
3645 h
->next
= Fmake_vector (size
, Qnil
);
3646 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3648 /* Set up the free list. */
3649 for (i
= 0; i
< sz
- 1; ++i
)
3650 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3651 h
->next_free
= make_number (0);
3653 XSET_HASH_TABLE (table
, h
);
3654 xassert (HASH_TABLE_P (table
));
3655 xassert (XHASH_TABLE (table
) == h
);
3657 /* Maybe add this hash table to the list of all weak hash tables. */
3659 h
->next_weak
= NULL
;
3662 h
->next_weak
= weak_hash_tables
;
3663 weak_hash_tables
= h
;
3670 /* Return a copy of hash table H1. Keys and values are not copied,
3671 only the table itself is. */
3674 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3677 struct Lisp_Hash_Table
*h2
;
3678 struct Lisp_Vector
*next
;
3680 h2
= allocate_hash_table ();
3681 next
= h2
->header
.next
.vector
;
3682 memcpy (h2
, h1
, sizeof *h2
);
3683 h2
->header
.next
.vector
= next
;
3684 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3685 h2
->hash
= Fcopy_sequence (h1
->hash
);
3686 h2
->next
= Fcopy_sequence (h1
->next
);
3687 h2
->index
= Fcopy_sequence (h1
->index
);
3688 XSET_HASH_TABLE (table
, h2
);
3690 /* Maybe add this hash table to the list of all weak hash tables. */
3691 if (!NILP (h2
->weak
))
3693 h2
->next_weak
= weak_hash_tables
;
3694 weak_hash_tables
= h2
;
3701 /* Resize hash table H if it's too full. If H cannot be resized
3702 because it's already too large, throw an error. */
3705 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3707 if (NILP (h
->next_free
))
3709 EMACS_INT old_size
= HASH_TABLE_SIZE (h
);
3710 EMACS_INT i
, new_size
, index_size
;
3714 if (INTEGERP (h
->rehash_size
))
3715 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3718 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3719 if (float_new_size
< MOST_POSITIVE_FIXNUM
+ 1)
3721 new_size
= float_new_size
;
3722 if (new_size
<= old_size
)
3723 new_size
= old_size
+ 1;
3726 new_size
= MOST_POSITIVE_FIXNUM
+ 1;
3728 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3729 index_size
= (index_float
< MOST_POSITIVE_FIXNUM
+ 1
3730 ? next_almost_prime (index_float
)
3731 : MOST_POSITIVE_FIXNUM
+ 1);
3732 nsize
= max (index_size
, 2 * new_size
);
3733 if (nsize
> MOST_POSITIVE_FIXNUM
)
3734 error ("Hash table too large to resize");
3736 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3737 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3738 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3739 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3741 /* Update the free list. Do it so that new entries are added at
3742 the end of the free list. This makes some operations like
3744 for (i
= old_size
; i
< new_size
- 1; ++i
)
3745 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3747 if (!NILP (h
->next_free
))
3749 Lisp_Object last
, next
;
3751 last
= h
->next_free
;
3752 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3756 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3759 XSETFASTINT (h
->next_free
, old_size
);
3762 for (i
= 0; i
< old_size
; ++i
)
3763 if (!NILP (HASH_HASH (h
, i
)))
3765 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3766 EMACS_INT start_of_bucket
= hash_code
% ASIZE (h
->index
);
3767 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3768 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3774 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3775 the hash code of KEY. Value is the index of the entry in H
3776 matching KEY, or -1 if not found. */
3779 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3781 EMACS_UINT hash_code
;
3782 EMACS_INT start_of_bucket
;
3785 hash_code
= h
->hashfn (h
, key
);
3789 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3790 idx
= HASH_INDEX (h
, start_of_bucket
);
3792 /* We need not gcpro idx since it's either an integer or nil. */
3795 EMACS_INT i
= XFASTINT (idx
);
3796 if (EQ (key
, HASH_KEY (h
, i
))
3798 && h
->cmpfn (h
, key
, hash_code
,
3799 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3801 idx
= HASH_NEXT (h
, i
);
3804 return NILP (idx
) ? -1 : XFASTINT (idx
);
3808 /* Put an entry into hash table H that associates KEY with VALUE.
3809 HASH is a previously computed hash code of KEY.
3810 Value is the index of the entry in H matching KEY. */
3813 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3816 EMACS_INT start_of_bucket
, i
;
3818 xassert ((hash
& ~INTMASK
) == 0);
3820 /* Increment count after resizing because resizing may fail. */
3821 maybe_resize_hash_table (h
);
3824 /* Store key/value in the key_and_value vector. */
3825 i
= XFASTINT (h
->next_free
);
3826 h
->next_free
= HASH_NEXT (h
, i
);
3827 HASH_KEY (h
, i
) = key
;
3828 HASH_VALUE (h
, i
) = value
;
3830 /* Remember its hash code. */
3831 HASH_HASH (h
, i
) = make_number (hash
);
3833 /* Add new entry to its collision chain. */
3834 start_of_bucket
= hash
% ASIZE (h
->index
);
3835 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3836 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3841 /* Remove the entry matching KEY from hash table H, if there is one. */
3844 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3846 EMACS_UINT hash_code
;
3847 EMACS_INT start_of_bucket
;
3848 Lisp_Object idx
, prev
;
3850 hash_code
= h
->hashfn (h
, key
);
3851 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3852 idx
= HASH_INDEX (h
, start_of_bucket
);
3855 /* We need not gcpro idx, prev since they're either integers or nil. */
3858 EMACS_INT i
= XFASTINT (idx
);
3860 if (EQ (key
, HASH_KEY (h
, i
))
3862 && h
->cmpfn (h
, key
, hash_code
,
3863 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3865 /* Take entry out of collision chain. */
3867 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3869 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3871 /* Clear slots in key_and_value and add the slots to
3873 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3874 HASH_NEXT (h
, i
) = h
->next_free
;
3875 h
->next_free
= make_number (i
);
3877 xassert (h
->count
>= 0);
3883 idx
= HASH_NEXT (h
, i
);
3889 /* Clear hash table H. */
3892 hash_clear (struct Lisp_Hash_Table
*h
)
3896 EMACS_INT i
, size
= HASH_TABLE_SIZE (h
);
3898 for (i
= 0; i
< size
; ++i
)
3900 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3901 HASH_KEY (h
, i
) = Qnil
;
3902 HASH_VALUE (h
, i
) = Qnil
;
3903 HASH_HASH (h
, i
) = Qnil
;
3906 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3907 ASET (h
->index
, i
, Qnil
);
3909 h
->next_free
= make_number (0);
3916 /************************************************************************
3918 ************************************************************************/
3921 init_weak_hash_tables (void)
3923 weak_hash_tables
= NULL
;
3926 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3927 entries from the table that don't survive the current GC.
3928 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3929 non-zero if anything was marked. */
3932 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3934 EMACS_INT bucket
, n
;
3937 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3940 for (bucket
= 0; bucket
< n
; ++bucket
)
3942 Lisp_Object idx
, next
, prev
;
3944 /* Follow collision chain, removing entries that
3945 don't survive this garbage collection. */
3947 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3949 EMACS_INT i
= XFASTINT (idx
);
3950 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3951 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3954 if (EQ (h
->weak
, Qkey
))
3955 remove_p
= !key_known_to_survive_p
;
3956 else if (EQ (h
->weak
, Qvalue
))
3957 remove_p
= !value_known_to_survive_p
;
3958 else if (EQ (h
->weak
, Qkey_or_value
))
3959 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3960 else if (EQ (h
->weak
, Qkey_and_value
))
3961 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3965 next
= HASH_NEXT (h
, i
);
3967 if (remove_entries_p
)
3971 /* Take out of collision chain. */
3973 HASH_INDEX (h
, bucket
) = next
;
3975 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3977 /* Add to free list. */
3978 HASH_NEXT (h
, i
) = h
->next_free
;
3981 /* Clear key, value, and hash. */
3982 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3983 HASH_HASH (h
, i
) = Qnil
;
3996 /* Make sure key and value survive. */
3997 if (!key_known_to_survive_p
)
3999 mark_object (HASH_KEY (h
, i
));
4003 if (!value_known_to_survive_p
)
4005 mark_object (HASH_VALUE (h
, i
));
4016 /* Remove elements from weak hash tables that don't survive the
4017 current garbage collection. Remove weak tables that don't survive
4018 from Vweak_hash_tables. Called from gc_sweep. */
4021 sweep_weak_hash_tables (void)
4023 struct Lisp_Hash_Table
*h
, *used
, *next
;
4026 /* Mark all keys and values that are in use. Keep on marking until
4027 there is no more change. This is necessary for cases like
4028 value-weak table A containing an entry X -> Y, where Y is used in a
4029 key-weak table B, Z -> Y. If B comes after A in the list of weak
4030 tables, X -> Y might be removed from A, although when looking at B
4031 one finds that it shouldn't. */
4035 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4037 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4038 marked
|= sweep_weak_table (h
, 0);
4043 /* Remove tables and entries that aren't used. */
4044 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4046 next
= h
->next_weak
;
4048 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4050 /* TABLE is marked as used. Sweep its contents. */
4052 sweep_weak_table (h
, 1);
4054 /* Add table to the list of used weak hash tables. */
4055 h
->next_weak
= used
;
4060 weak_hash_tables
= used
;
4065 /***********************************************************************
4066 Hash Code Computation
4067 ***********************************************************************/
4069 /* Maximum depth up to which to dive into Lisp structures. */
4071 #define SXHASH_MAX_DEPTH 3
4073 /* Maximum length up to which to take list and vector elements into
4076 #define SXHASH_MAX_LEN 7
4078 /* Combine two integers X and Y for hashing. The result might not fit
4079 into a Lisp integer. */
4081 #define SXHASH_COMBINE(X, Y) \
4082 ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
4085 /* Hash X, returning a value that fits into a Lisp integer. */
4086 #define SXHASH_REDUCE(X) \
4087 ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
4089 /* Return a hash for string PTR which has length LEN. The hash
4090 code returned is guaranteed to fit in a Lisp integer. */
4093 sxhash_string (unsigned char *ptr
, EMACS_INT len
)
4095 unsigned char *p
= ptr
;
4096 unsigned char *end
= p
+ len
;
4098 EMACS_UINT hash
= 0;
4105 hash
= SXHASH_COMBINE (hash
, c
);
4108 return SXHASH_REDUCE (hash
);
4111 /* Return a hash for the floating point value VAL. */
4114 sxhash_float (double val
)
4116 EMACS_UINT hash
= 0;
4118 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4119 + (sizeof val
% sizeof hash
!= 0))
4123 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4127 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4128 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4129 hash
= SXHASH_COMBINE (hash
, u
.word
[i
]);
4130 return SXHASH_REDUCE (hash
);
4133 /* Return a hash for list LIST. DEPTH is the current depth in the
4134 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4137 sxhash_list (Lisp_Object list
, int depth
)
4139 EMACS_UINT hash
= 0;
4142 if (depth
< SXHASH_MAX_DEPTH
)
4144 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4145 list
= XCDR (list
), ++i
)
4147 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4148 hash
= SXHASH_COMBINE (hash
, hash2
);
4153 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4154 hash
= SXHASH_COMBINE (hash
, hash2
);
4157 return SXHASH_REDUCE (hash
);
4161 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4162 the Lisp structure. */
4165 sxhash_vector (Lisp_Object vec
, int depth
)
4167 EMACS_UINT hash
= ASIZE (vec
);
4170 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4171 for (i
= 0; i
< n
; ++i
)
4173 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4174 hash
= SXHASH_COMBINE (hash
, hash2
);
4177 return SXHASH_REDUCE (hash
);
4180 /* Return a hash for bool-vector VECTOR. */
4183 sxhash_bool_vector (Lisp_Object vec
)
4185 EMACS_UINT hash
= XBOOL_VECTOR (vec
)->size
;
4188 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4189 for (i
= 0; i
< n
; ++i
)
4190 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4192 return SXHASH_REDUCE (hash
);
4196 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4197 structure. Value is an unsigned integer clipped to INTMASK. */
4200 sxhash (Lisp_Object obj
, int depth
)
4204 if (depth
> SXHASH_MAX_DEPTH
)
4207 switch (XTYPE (obj
))
4218 obj
= SYMBOL_NAME (obj
);
4222 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4225 /* This can be everything from a vector to an overlay. */
4226 case Lisp_Vectorlike
:
4228 /* According to the CL HyperSpec, two arrays are equal only if
4229 they are `eq', except for strings and bit-vectors. In
4230 Emacs, this works differently. We have to compare element
4232 hash
= sxhash_vector (obj
, depth
);
4233 else if (BOOL_VECTOR_P (obj
))
4234 hash
= sxhash_bool_vector (obj
);
4236 /* Others are `equal' if they are `eq', so let's take their
4242 hash
= sxhash_list (obj
, depth
);
4246 hash
= sxhash_float (XFLOAT_DATA (obj
));
4258 /***********************************************************************
4260 ***********************************************************************/
4263 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4264 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4267 EMACS_UINT hash
= sxhash (obj
, 0);
4268 return make_number (hash
);
4272 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4273 doc
: /* Create and return a new hash table.
4275 Arguments are specified as keyword/argument pairs. The following
4276 arguments are defined:
4278 :test TEST -- TEST must be a symbol that specifies how to compare
4279 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4280 `equal'. User-supplied test and hash functions can be specified via
4281 `define-hash-table-test'.
4283 :size SIZE -- A hint as to how many elements will be put in the table.
4286 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4287 fills up. If REHASH-SIZE is an integer, increase the size by that
4288 amount. If it is a float, it must be > 1.0, and the new size is the
4289 old size multiplied by that factor. Default is 1.5.
4291 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4292 Resize the hash table when the ratio (number of entries / table size)
4293 is greater than or equal to THRESHOLD. Default is 0.8.
4295 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4296 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4297 returned is a weak table. Key/value pairs are removed from a weak
4298 hash table when there are no non-weak references pointing to their
4299 key, value, one of key or value, or both key and value, depending on
4300 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4303 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4304 (size_t nargs
, Lisp_Object
*args
)
4306 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4307 Lisp_Object user_test
, user_hash
;
4311 /* The vector `used' is used to keep track of arguments that
4312 have been consumed. */
4313 used
= (char *) alloca (nargs
* sizeof *used
);
4314 memset (used
, 0, nargs
* sizeof *used
);
4316 /* See if there's a `:test TEST' among the arguments. */
4317 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4318 test
= i
? args
[i
] : Qeql
;
4319 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4321 /* See if it is a user-defined test. */
4324 prop
= Fget (test
, Qhash_table_test
);
4325 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4326 signal_error ("Invalid hash table test", test
);
4327 user_test
= XCAR (prop
);
4328 user_hash
= XCAR (XCDR (prop
));
4331 user_test
= user_hash
= Qnil
;
4333 /* See if there's a `:size SIZE' argument. */
4334 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4335 size
= i
? args
[i
] : Qnil
;
4337 size
= make_number (DEFAULT_HASH_SIZE
);
4338 else if (!INTEGERP (size
) || XINT (size
) < 0)
4339 signal_error ("Invalid hash table size", size
);
4341 /* Look for `:rehash-size SIZE'. */
4342 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4343 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4344 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4345 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4346 signal_error ("Invalid hash table rehash size", rehash_size
);
4348 /* Look for `:rehash-threshold THRESHOLD'. */
4349 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4350 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4351 if (! (FLOATP (rehash_threshold
)
4352 && 0 < XFLOAT_DATA (rehash_threshold
)
4353 && XFLOAT_DATA (rehash_threshold
) <= 1))
4354 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4356 /* Look for `:weakness WEAK'. */
4357 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4358 weak
= i
? args
[i
] : Qnil
;
4360 weak
= Qkey_and_value
;
4363 && !EQ (weak
, Qvalue
)
4364 && !EQ (weak
, Qkey_or_value
)
4365 && !EQ (weak
, Qkey_and_value
))
4366 signal_error ("Invalid hash table weakness", weak
);
4368 /* Now, all args should have been used up, or there's a problem. */
4369 for (i
= 0; i
< nargs
; ++i
)
4371 signal_error ("Invalid argument list", args
[i
]);
4373 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4374 user_test
, user_hash
);
4378 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4379 doc
: /* Return a copy of hash table TABLE. */)
4382 return copy_hash_table (check_hash_table (table
));
4386 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4387 doc
: /* Return the number of elements in TABLE. */)
4390 return make_number (check_hash_table (table
)->count
);
4394 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4395 Shash_table_rehash_size
, 1, 1, 0,
4396 doc
: /* Return the current rehash size of TABLE. */)
4399 return check_hash_table (table
)->rehash_size
;
4403 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4404 Shash_table_rehash_threshold
, 1, 1, 0,
4405 doc
: /* Return the current rehash threshold of TABLE. */)
4408 return check_hash_table (table
)->rehash_threshold
;
4412 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4413 doc
: /* Return the size of TABLE.
4414 The size can be used as an argument to `make-hash-table' to create
4415 a hash table than can hold as many elements as TABLE holds
4416 without need for resizing. */)
4419 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4420 return make_number (HASH_TABLE_SIZE (h
));
4424 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4425 doc
: /* Return the test TABLE uses. */)
4428 return check_hash_table (table
)->test
;
4432 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4434 doc
: /* Return the weakness of TABLE. */)
4437 return check_hash_table (table
)->weak
;
4441 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4442 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4445 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4449 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4450 doc
: /* Clear hash table TABLE and return it. */)
4453 hash_clear (check_hash_table (table
));
4454 /* Be compatible with XEmacs. */
4459 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4460 doc
: /* Look up KEY in TABLE and return its associated value.
4461 If KEY is not found, return DFLT which defaults to nil. */)
4462 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4464 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4465 EMACS_INT i
= hash_lookup (h
, key
, NULL
);
4466 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4470 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4471 doc
: /* Associate KEY with VALUE in hash table TABLE.
4472 If KEY is already present in table, replace its current value with
4473 VALUE. In any case, return VALUE. */)
4474 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4476 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4480 i
= hash_lookup (h
, key
, &hash
);
4482 HASH_VALUE (h
, i
) = value
;
4484 hash_put (h
, key
, value
, hash
);
4490 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4491 doc
: /* Remove KEY from TABLE. */)
4492 (Lisp_Object key
, Lisp_Object table
)
4494 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4495 hash_remove_from_table (h
, key
);
4500 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4501 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4502 FUNCTION is called with two arguments, KEY and VALUE. */)
4503 (Lisp_Object function
, Lisp_Object table
)
4505 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4506 Lisp_Object args
[3];
4509 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4510 if (!NILP (HASH_HASH (h
, i
)))
4513 args
[1] = HASH_KEY (h
, i
);
4514 args
[2] = HASH_VALUE (h
, i
);
4522 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4523 Sdefine_hash_table_test
, 3, 3, 0,
4524 doc
: /* Define a new hash table test with name NAME, a symbol.
4526 In hash tables created with NAME specified as test, use TEST to
4527 compare keys, and HASH for computing hash codes of keys.
4529 TEST must be a function taking two arguments and returning non-nil if
4530 both arguments are the same. HASH must be a function taking one
4531 argument and return an integer that is the hash code of the argument.
4532 Hash code computation should use the whole value range of integers,
4533 including negative integers. */)
4534 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4536 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4541 /************************************************************************
4543 ************************************************************************/
4548 /* Convert a possibly-signed character to an unsigned character. This is
4549 a bit safer than casting to unsigned char, since it catches some type
4550 errors that the cast doesn't. */
4551 static inline unsigned char to_uchar (char ch
) { return ch
; }
4553 /* TYPE: 0 for md5, 1 for sha1. */
4556 crypto_hash_function (int type
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
, Lisp_Object binary
)
4560 EMACS_INT size_byte
= 0;
4561 EMACS_INT start_char
= 0, end_char
= 0;
4562 EMACS_INT start_byte
= 0, end_byte
= 0;
4563 register EMACS_INT b
, e
;
4564 register struct buffer
*bp
;
4566 Lisp_Object res
=Qnil
;
4568 if (STRINGP (object
))
4570 if (NILP (coding_system
))
4572 /* Decide the coding-system to encode the data with. */
4574 if (STRING_MULTIBYTE (object
))
4575 /* use default, we can't guess correct value */
4576 coding_system
= preferred_coding_system ();
4578 coding_system
= Qraw_text
;
4581 if (NILP (Fcoding_system_p (coding_system
)))
4583 /* Invalid coding system. */
4585 if (!NILP (noerror
))
4586 coding_system
= Qraw_text
;
4588 xsignal1 (Qcoding_system_error
, coding_system
);
4591 if (STRING_MULTIBYTE (object
))
4592 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4594 size
= SCHARS (object
);
4595 size_byte
= SBYTES (object
);
4599 CHECK_NUMBER (start
);
4601 start_char
= XINT (start
);
4606 start_byte
= string_char_to_byte (object
, start_char
);
4612 end_byte
= size_byte
;
4618 end_char
= XINT (end
);
4623 end_byte
= string_char_to_byte (object
, end_char
);
4626 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4627 args_out_of_range_3 (object
, make_number (start_char
),
4628 make_number (end_char
));
4632 struct buffer
*prev
= current_buffer
;
4634 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4636 CHECK_BUFFER (object
);
4638 bp
= XBUFFER (object
);
4639 if (bp
!= current_buffer
)
4640 set_buffer_internal (bp
);
4646 CHECK_NUMBER_COERCE_MARKER (start
);
4654 CHECK_NUMBER_COERCE_MARKER (end
);
4659 temp
= b
, b
= e
, e
= temp
;
4661 if (!(BEGV
<= b
&& e
<= ZV
))
4662 args_out_of_range (start
, end
);
4664 if (NILP (coding_system
))
4666 /* Decide the coding-system to encode the data with.
4667 See fileio.c:Fwrite-region */
4669 if (!NILP (Vcoding_system_for_write
))
4670 coding_system
= Vcoding_system_for_write
;
4673 int force_raw_text
= 0;
4675 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4676 if (NILP (coding_system
)
4677 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4679 coding_system
= Qnil
;
4680 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4684 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4686 /* Check file-coding-system-alist. */
4687 Lisp_Object args
[4], val
;
4689 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4690 args
[3] = Fbuffer_file_name(object
);
4691 val
= Ffind_operation_coding_system (4, args
);
4692 if (CONSP (val
) && !NILP (XCDR (val
)))
4693 coding_system
= XCDR (val
);
4696 if (NILP (coding_system
)
4697 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4699 /* If we still have not decided a coding system, use the
4700 default value of buffer-file-coding-system. */
4701 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4705 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4706 /* Confirm that VAL can surely encode the current region. */
4707 coding_system
= call4 (Vselect_safe_coding_system_function
,
4708 make_number (b
), make_number (e
),
4709 coding_system
, Qnil
);
4712 coding_system
= Qraw_text
;
4715 if (NILP (Fcoding_system_p (coding_system
)))
4717 /* Invalid coding system. */
4719 if (!NILP (noerror
))
4720 coding_system
= Qraw_text
;
4722 xsignal1 (Qcoding_system_error
, coding_system
);
4726 object
= make_buffer_string (b
, e
, 0);
4727 if (prev
!= current_buffer
)
4728 set_buffer_internal (prev
);
4729 /* Discard the unwind protect for recovering the current
4733 if (STRING_MULTIBYTE (object
))
4734 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4742 md5_buffer (SSDATA (object
) + start_byte
,
4743 SBYTES (object
) - (size_byte
- end_byte
),
4749 for (i
= 0; i
< 16; i
++)
4750 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4751 res
= make_string (value
, 32);
4754 res
= make_string (digest
, 16);
4761 sha1_buffer (SSDATA (object
) + start_byte
,
4762 SBYTES (object
) - (size_byte
- end_byte
),
4767 for (i
= 0; i
< 20; i
++)
4768 sprintf (&value
[2 * i
], "%02x", to_uchar (digest
[i
]));
4769 res
= make_string (value
, 40);
4772 res
= make_string (digest
, 20);
4780 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4781 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4783 A message digest is a cryptographic checksum of a document, and the
4784 algorithm to calculate it is defined in RFC 1321.
4786 The two optional arguments START and END are character positions
4787 specifying for which part of OBJECT the message digest should be
4788 computed. If nil or omitted, the digest is computed for the whole
4791 The MD5 message digest is computed from the result of encoding the
4792 text in a coding system, not directly from the internal Emacs form of
4793 the text. The optional fourth argument CODING-SYSTEM specifies which
4794 coding system to encode the text with. It should be the same coding
4795 system that you used or will use when actually writing the text into a
4798 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4799 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4800 system would be chosen by default for writing this text into a file.
4802 If OBJECT is a string, the most preferred coding system (see the
4803 command `prefer-coding-system') is used.
4805 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4806 guesswork fails. Normally, an error is signaled in such case. */)
4807 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4809 return crypto_hash_function (0, object
, start
, end
, coding_system
, noerror
, Qnil
);
4812 DEFUN ("sha1", Fsha1
, Ssha1
, 1, 4, 0,
4813 doc
: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
4815 OBJECT is either a string or a buffer. Optional arguments START and
4816 END are character positions specifying which portion of OBJECT for
4817 computing the hash. If BINARY is non-nil, return a string in binary
4819 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4821 return crypto_hash_function (1, object
, start
, end
, Qnil
, Qnil
, binary
);
4828 /* Hash table stuff. */
4829 Qhash_table_p
= intern_c_string ("hash-table-p");
4830 staticpro (&Qhash_table_p
);
4831 Qeq
= intern_c_string ("eq");
4833 Qeql
= intern_c_string ("eql");
4835 Qequal
= intern_c_string ("equal");
4836 staticpro (&Qequal
);
4837 QCtest
= intern_c_string (":test");
4838 staticpro (&QCtest
);
4839 QCsize
= intern_c_string (":size");
4840 staticpro (&QCsize
);
4841 QCrehash_size
= intern_c_string (":rehash-size");
4842 staticpro (&QCrehash_size
);
4843 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4844 staticpro (&QCrehash_threshold
);
4845 QCweakness
= intern_c_string (":weakness");
4846 staticpro (&QCweakness
);
4847 Qkey
= intern_c_string ("key");
4849 Qvalue
= intern_c_string ("value");
4850 staticpro (&Qvalue
);
4851 Qhash_table_test
= intern_c_string ("hash-table-test");
4852 staticpro (&Qhash_table_test
);
4853 Qkey_or_value
= intern_c_string ("key-or-value");
4854 staticpro (&Qkey_or_value
);
4855 Qkey_and_value
= intern_c_string ("key-and-value");
4856 staticpro (&Qkey_and_value
);
4859 defsubr (&Smake_hash_table
);
4860 defsubr (&Scopy_hash_table
);
4861 defsubr (&Shash_table_count
);
4862 defsubr (&Shash_table_rehash_size
);
4863 defsubr (&Shash_table_rehash_threshold
);
4864 defsubr (&Shash_table_size
);
4865 defsubr (&Shash_table_test
);
4866 defsubr (&Shash_table_weakness
);
4867 defsubr (&Shash_table_p
);
4868 defsubr (&Sclrhash
);
4869 defsubr (&Sgethash
);
4870 defsubr (&Sputhash
);
4871 defsubr (&Sremhash
);
4872 defsubr (&Smaphash
);
4873 defsubr (&Sdefine_hash_table_test
);
4875 Qstring_lessp
= intern_c_string ("string-lessp");
4876 staticpro (&Qstring_lessp
);
4877 Qprovide
= intern_c_string ("provide");
4878 staticpro (&Qprovide
);
4879 Qrequire
= intern_c_string ("require");
4880 staticpro (&Qrequire
);
4881 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4882 staticpro (&Qyes_or_no_p_history
);
4883 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4884 staticpro (&Qcursor_in_echo_area
);
4885 Qwidget_type
= intern_c_string ("widget-type");
4886 staticpro (&Qwidget_type
);
4888 staticpro (&string_char_byte_cache_string
);
4889 string_char_byte_cache_string
= Qnil
;
4891 require_nesting_list
= Qnil
;
4892 staticpro (&require_nesting_list
);
4894 Fset (Qyes_or_no_p_history
, Qnil
);
4896 DEFVAR_LISP ("features", Vfeatures
,
4897 doc
: /* A list of symbols which are the features of the executing Emacs.
4898 Used by `featurep' and `require', and altered by `provide'. */);
4899 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4900 Qsubfeatures
= intern_c_string ("subfeatures");
4901 staticpro (&Qsubfeatures
);
4903 #ifdef HAVE_LANGINFO_CODESET
4904 Qcodeset
= intern_c_string ("codeset");
4905 staticpro (&Qcodeset
);
4906 Qdays
= intern_c_string ("days");
4908 Qmonths
= intern_c_string ("months");
4909 staticpro (&Qmonths
);
4910 Qpaper
= intern_c_string ("paper");
4911 staticpro (&Qpaper
);
4912 #endif /* HAVE_LANGINFO_CODESET */
4914 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4915 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4916 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4917 invoked by mouse clicks and mouse menu items.
4919 On some platforms, file selection dialogs are also enabled if this is
4923 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4924 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4925 This applies to commands from menus and tool bar buttons even when
4926 they are initiated from the keyboard. If `use-dialog-box' is nil,
4927 that disables the use of a file dialog, regardless of the value of
4929 use_file_dialog
= 1;
4931 defsubr (&Sidentity
);
4934 defsubr (&Ssafe_length
);
4935 defsubr (&Sstring_bytes
);
4936 defsubr (&Sstring_equal
);
4937 defsubr (&Scompare_strings
);
4938 defsubr (&Sstring_lessp
);
4941 defsubr (&Svconcat
);
4942 defsubr (&Scopy_sequence
);
4943 defsubr (&Sstring_make_multibyte
);
4944 defsubr (&Sstring_make_unibyte
);
4945 defsubr (&Sstring_as_multibyte
);
4946 defsubr (&Sstring_as_unibyte
);
4947 defsubr (&Sstring_to_multibyte
);
4948 defsubr (&Sstring_to_unibyte
);
4949 defsubr (&Scopy_alist
);
4950 defsubr (&Ssubstring
);
4951 defsubr (&Ssubstring_no_properties
);
4964 defsubr (&Snreverse
);
4965 defsubr (&Sreverse
);
4967 defsubr (&Splist_get
);
4969 defsubr (&Splist_put
);
4971 defsubr (&Slax_plist_get
);
4972 defsubr (&Slax_plist_put
);
4975 defsubr (&Sequal_including_properties
);
4976 defsubr (&Sfillarray
);
4977 defsubr (&Sclear_string
);
4981 defsubr (&Smapconcat
);
4982 defsubr (&Syes_or_no_p
);
4983 defsubr (&Sload_average
);
4984 defsubr (&Sfeaturep
);
4985 defsubr (&Srequire
);
4986 defsubr (&Sprovide
);
4987 defsubr (&Splist_member
);
4988 defsubr (&Swidget_put
);
4989 defsubr (&Swidget_get
);
4990 defsubr (&Swidget_apply
);
4991 defsubr (&Sbase64_encode_region
);
4992 defsubr (&Sbase64_decode_region
);
4993 defsubr (&Sbase64_encode_string
);
4994 defsubr (&Sbase64_decode_string
);
4997 defsubr (&Slocale_info
);