1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
68 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
70 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
72 extern long get_random (void);
73 extern void seed_random (long);
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 doc
: /* Return the argument unchanged. */)
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 doc
: /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 29 bits' worth.
90 With positive integer LIMIT, return random number in interval [0,LIMIT).
91 With argument t, set the random number seed from the current time and pid.
92 Other values of LIMIT are ignored. */)
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (limit
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 doc
: /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */)
129 (register Lisp_Object sequence
)
131 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, SCHARS (sequence
));
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, ASIZE (sequence
));
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 CHECK_LIST_END (sequence
, sequence
);
162 val
= make_number (i
);
164 else if (NILP (sequence
))
165 XSETFASTINT (val
, 0);
167 wrong_type_argument (Qsequencep
, sequence
);
172 /* This does not check for quits. That is safe since it must terminate. */
174 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
175 doc
: /* Return the length of a list, but avoid error or infinite loop.
176 This function never gets an error. If LIST is not really a list,
177 it returns 0. If LIST is circular, it returns a finite value
178 which is at least the number of distinct elements. */)
181 Lisp_Object tail
, halftail
, length
;
184 /* halftail is used to detect circular lists. */
186 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
188 if (EQ (tail
, halftail
) && len
!= 0)
192 halftail
= XCDR (halftail
);
195 XSETINT (length
, len
);
199 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
200 doc
: /* Return the number of bytes in STRING.
201 If STRING is multibyte, this may be greater than the length of STRING. */)
204 CHECK_STRING (string
);
205 return make_number (SBYTES (string
));
208 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
209 doc
: /* Return t if two strings have identical contents.
210 Case is significant, but text properties are ignored.
211 Symbols are also allowed; their print names are used instead. */)
212 (register Lisp_Object s1
, Lisp_Object s2
)
215 s1
= SYMBOL_NAME (s1
);
217 s2
= SYMBOL_NAME (s2
);
221 if (SCHARS (s1
) != SCHARS (s2
)
222 || SBYTES (s1
) != SBYTES (s2
)
223 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
228 DEFUN ("compare-strings", Fcompare_strings
,
229 Scompare_strings
, 6, 7, 0,
230 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
231 In string STR1, skip the first START1 characters and stop at END1.
232 In string STR2, skip the first START2 characters and stop at END2.
233 END1 and END2 default to the full lengths of the respective strings.
235 Case is significant in this comparison if IGNORE-CASE is nil.
236 Unibyte strings are converted to multibyte for comparison.
238 The value is t if the strings (or specified portions) match.
239 If string STR1 is less, the value is a negative number N;
240 - 1 - N is the number of characters that match at the beginning.
241 If string STR1 is greater, the value is a positive number N;
242 N - 1 is the number of characters that match at the beginning. */)
243 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
245 register int end1_char
, end2_char
;
246 register int i1
, i1_byte
, i2
, i2_byte
;
251 start1
= make_number (0);
253 start2
= make_number (0);
254 CHECK_NATNUM (start1
);
255 CHECK_NATNUM (start2
);
264 i1_byte
= string_char_to_byte (str1
, i1
);
265 i2_byte
= string_char_to_byte (str2
, i2
);
267 end1_char
= SCHARS (str1
);
268 if (! NILP (end1
) && end1_char
> XINT (end1
))
269 end1_char
= XINT (end1
);
271 end2_char
= SCHARS (str2
);
272 if (! NILP (end2
) && end2_char
> XINT (end2
))
273 end2_char
= XINT (end2
);
275 while (i1
< end1_char
&& i2
< end2_char
)
277 /* When we find a mismatch, we must compare the
278 characters, not just the bytes. */
281 if (STRING_MULTIBYTE (str1
))
282 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
285 c1
= SREF (str1
, i1
++);
286 MAKE_CHAR_MULTIBYTE (c1
);
289 if (STRING_MULTIBYTE (str2
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
293 c2
= SREF (str2
, i2
++);
294 MAKE_CHAR_MULTIBYTE (c2
);
300 if (! NILP (ignore_case
))
304 tem
= Fupcase (make_number (c1
));
306 tem
= Fupcase (make_number (c2
));
313 /* Note that I1 has already been incremented
314 past the character that we are comparing;
315 hence we don't add or subtract 1 here. */
317 return make_number (- i1
+ XINT (start1
));
319 return make_number (i1
- XINT (start1
));
323 return make_number (i1
- XINT (start1
) + 1);
325 return make_number (- i1
+ XINT (start1
) - 1);
330 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
331 doc
: /* Return t if first arg string is less than second in lexicographic order.
333 Symbols are also allowed; their print names are used instead. */)
334 (register Lisp_Object s1
, Lisp_Object s2
)
337 register int i1
, i1_byte
, i2
, i2_byte
;
340 s1
= SYMBOL_NAME (s1
);
342 s2
= SYMBOL_NAME (s2
);
346 i1
= i1_byte
= i2
= i2_byte
= 0;
349 if (end
> SCHARS (s2
))
354 /* When we find a mismatch, we must compare the
355 characters, not just the bytes. */
358 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
359 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
362 return c1
< c2
? Qt
: Qnil
;
364 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
367 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
368 enum Lisp_Type target_type
, int last_special
);
372 concat2 (Lisp_Object s1
, Lisp_Object s2
)
377 return concat (2, args
, Lisp_String
, 0);
382 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
388 return concat (3, args
, Lisp_String
, 0);
391 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
392 doc
: /* Concatenate all the arguments and make the result a list.
393 The result is a list whose elements are the elements of all the arguments.
394 Each argument may be a list, vector or string.
395 The last argument is not copied, just used as the tail of the new list.
396 usage: (append &rest SEQUENCES) */)
397 (int nargs
, Lisp_Object
*args
)
399 return concat (nargs
, args
, Lisp_Cons
, 1);
402 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
403 doc
: /* Concatenate all the arguments and make the result a string.
404 The result is a string whose elements are the elements of all the arguments.
405 Each argument may be a string or a list or vector of characters (integers).
406 usage: (concat &rest SEQUENCES) */)
407 (int nargs
, Lisp_Object
*args
)
409 return concat (nargs
, args
, Lisp_String
, 0);
412 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
413 doc
: /* Concatenate all the arguments and make the result a vector.
414 The result is a vector whose elements are the elements of all the arguments.
415 Each argument may be a list, vector or string.
416 usage: (vconcat &rest SEQUENCES) */)
417 (int nargs
, Lisp_Object
*args
)
419 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
423 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
424 doc
: /* Return a copy of a list, vector, string or char-table.
425 The elements of a list or vector are not copied; they are shared
426 with the original. */)
429 if (NILP (arg
)) return arg
;
431 if (CHAR_TABLE_P (arg
))
433 return copy_char_table (arg
);
436 if (BOOL_VECTOR_P (arg
))
440 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
441 / BOOL_VECTOR_BITS_PER_CHAR
);
443 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
444 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
449 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
450 wrong_type_argument (Qsequencep
, arg
);
452 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
455 /* This structure holds information of an argument of `concat' that is
456 a string and has text properties to be copied. */
459 int argnum
; /* refer to ARGS (arguments of `concat') */
460 int from
; /* refer to ARGS[argnum] (argument string) */
461 int to
; /* refer to VAL (the target string) */
465 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
468 register Lisp_Object tail
;
469 register Lisp_Object
this;
471 int toindex_byte
= 0;
472 register int result_len
;
473 register int result_len_byte
;
475 Lisp_Object last_tail
;
478 /* When we make a multibyte string, we can't copy text properties
479 while concatinating each string because the length of resulting
480 string can't be decided until we finish the whole concatination.
481 So, we record strings that have text properties to be copied
482 here, and copy the text properties after the concatination. */
483 struct textprop_rec
*textprops
= NULL
;
484 /* Number of elements in textprops. */
485 int num_textprops
= 0;
490 /* In append, the last arg isn't treated like the others */
491 if (last_special
&& nargs
> 0)
494 last_tail
= args
[nargs
];
499 /* Check each argument. */
500 for (argnum
= 0; argnum
< nargs
; argnum
++)
503 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
504 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
505 wrong_type_argument (Qsequencep
, this);
508 /* Compute total length in chars of arguments in RESULT_LEN.
509 If desired output is a string, also compute length in bytes
510 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
511 whether the result should be a multibyte string. */
515 for (argnum
= 0; argnum
< nargs
; argnum
++)
519 len
= XFASTINT (Flength (this));
520 if (target_type
== Lisp_String
)
522 /* We must count the number of bytes needed in the string
523 as well as the number of characters. */
529 for (i
= 0; i
< len
; i
++)
532 CHECK_CHARACTER (ch
);
533 this_len_byte
= CHAR_BYTES (XINT (ch
));
534 result_len_byte
+= this_len_byte
;
535 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
538 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
539 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
540 else if (CONSP (this))
541 for (; CONSP (this); this = XCDR (this))
544 CHECK_CHARACTER (ch
);
545 this_len_byte
= CHAR_BYTES (XINT (ch
));
546 result_len_byte
+= this_len_byte
;
547 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
550 else if (STRINGP (this))
552 if (STRING_MULTIBYTE (this))
555 result_len_byte
+= SBYTES (this);
558 result_len_byte
+= count_size_as_multibyte (SDATA (this),
565 error ("String overflow");
568 if (! some_multibyte
)
569 result_len_byte
= result_len
;
571 /* Create the output object. */
572 if (target_type
== Lisp_Cons
)
573 val
= Fmake_list (make_number (result_len
), Qnil
);
574 else if (target_type
== Lisp_Vectorlike
)
575 val
= Fmake_vector (make_number (result_len
), Qnil
);
576 else if (some_multibyte
)
577 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
579 val
= make_uninit_string (result_len
);
581 /* In `append', if all but last arg are nil, return last arg. */
582 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
585 /* Copy the contents of the args into the result. */
587 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
589 toindex
= 0, toindex_byte
= 0;
593 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
595 for (argnum
= 0; argnum
< nargs
; argnum
++)
599 register unsigned int thisindex
= 0;
600 register unsigned int thisindex_byte
= 0;
604 thislen
= Flength (this), thisleni
= XINT (thislen
);
606 /* Between strings of the same kind, copy fast. */
607 if (STRINGP (this) && STRINGP (val
)
608 && STRING_MULTIBYTE (this) == some_multibyte
)
610 int thislen_byte
= SBYTES (this);
612 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
613 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
615 textprops
[num_textprops
].argnum
= argnum
;
616 textprops
[num_textprops
].from
= 0;
617 textprops
[num_textprops
++].to
= toindex
;
619 toindex_byte
+= thislen_byte
;
622 /* Copy a single-byte string to a multibyte string. */
623 else if (STRINGP (this) && STRINGP (val
))
625 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
627 textprops
[num_textprops
].argnum
= argnum
;
628 textprops
[num_textprops
].from
= 0;
629 textprops
[num_textprops
++].to
= toindex
;
631 toindex_byte
+= copy_text (SDATA (this),
632 SDATA (val
) + toindex_byte
,
633 SCHARS (this), 0, 1);
637 /* Copy element by element. */
640 register Lisp_Object elt
;
642 /* Fetch next element of `this' arg into `elt', or break if
643 `this' is exhausted. */
644 if (NILP (this)) break;
646 elt
= XCAR (this), this = XCDR (this);
647 else if (thisindex
>= thisleni
)
649 else if (STRINGP (this))
652 if (STRING_MULTIBYTE (this))
654 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
657 XSETFASTINT (elt
, c
);
661 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
663 && !ASCII_CHAR_P (XINT (elt
))
664 && XINT (elt
) < 0400)
666 c
= BYTE8_TO_CHAR (XINT (elt
));
671 else if (BOOL_VECTOR_P (this))
674 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
675 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
683 elt
= AREF (this, thisindex
);
687 /* Store this element into the result. */
694 else if (VECTORP (val
))
696 ASET (val
, toindex
, elt
);
703 toindex_byte
+= CHAR_STRING (XINT (elt
),
704 SDATA (val
) + toindex_byte
);
706 SSET (val
, toindex_byte
++, XINT (elt
));
712 XSETCDR (prev
, last_tail
);
714 if (num_textprops
> 0)
717 int last_to_end
= -1;
719 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
721 this = args
[textprops
[argnum
].argnum
];
722 props
= text_property_list (this,
724 make_number (SCHARS (this)),
726 /* If successive arguments have properites, be sure that the
727 value of `composition' property be the copy. */
728 if (last_to_end
== textprops
[argnum
].to
)
729 make_composition_value_copy (props
);
730 add_text_properties_from_list (val
, props
,
731 make_number (textprops
[argnum
].to
));
732 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
740 static Lisp_Object string_char_byte_cache_string
;
741 static EMACS_INT string_char_byte_cache_charpos
;
742 static EMACS_INT string_char_byte_cache_bytepos
;
745 clear_string_char_byte_cache (void)
747 string_char_byte_cache_string
= Qnil
;
750 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
753 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
756 EMACS_INT best_below
, best_below_byte
;
757 EMACS_INT best_above
, best_above_byte
;
759 best_below
= best_below_byte
= 0;
760 best_above
= SCHARS (string
);
761 best_above_byte
= SBYTES (string
);
762 if (best_above
== best_above_byte
)
765 if (EQ (string
, string_char_byte_cache_string
))
767 if (string_char_byte_cache_charpos
< char_index
)
769 best_below
= string_char_byte_cache_charpos
;
770 best_below_byte
= string_char_byte_cache_bytepos
;
774 best_above
= string_char_byte_cache_charpos
;
775 best_above_byte
= string_char_byte_cache_bytepos
;
779 if (char_index
- best_below
< best_above
- char_index
)
781 unsigned char *p
= SDATA (string
) + best_below_byte
;
783 while (best_below
< char_index
)
785 p
+= BYTES_BY_CHAR_HEAD (*p
);
788 i_byte
= p
- SDATA (string
);
792 unsigned char *p
= SDATA (string
) + best_above_byte
;
794 while (best_above
> char_index
)
797 while (!CHAR_HEAD_P (*p
)) p
--;
800 i_byte
= p
- SDATA (string
);
803 string_char_byte_cache_bytepos
= i_byte
;
804 string_char_byte_cache_charpos
= char_index
;
805 string_char_byte_cache_string
= string
;
810 /* Return the character index corresponding to BYTE_INDEX in STRING. */
813 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
816 EMACS_INT best_below
, best_below_byte
;
817 EMACS_INT best_above
, best_above_byte
;
819 best_below
= best_below_byte
= 0;
820 best_above
= SCHARS (string
);
821 best_above_byte
= SBYTES (string
);
822 if (best_above
== best_above_byte
)
825 if (EQ (string
, string_char_byte_cache_string
))
827 if (string_char_byte_cache_bytepos
< byte_index
)
829 best_below
= string_char_byte_cache_charpos
;
830 best_below_byte
= string_char_byte_cache_bytepos
;
834 best_above
= string_char_byte_cache_charpos
;
835 best_above_byte
= string_char_byte_cache_bytepos
;
839 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
841 unsigned char *p
= SDATA (string
) + best_below_byte
;
842 unsigned char *pend
= SDATA (string
) + byte_index
;
846 p
+= BYTES_BY_CHAR_HEAD (*p
);
850 i_byte
= p
- SDATA (string
);
854 unsigned char *p
= SDATA (string
) + best_above_byte
;
855 unsigned char *pbeg
= SDATA (string
) + byte_index
;
860 while (!CHAR_HEAD_P (*p
)) p
--;
864 i_byte
= p
- SDATA (string
);
867 string_char_byte_cache_bytepos
= i_byte
;
868 string_char_byte_cache_charpos
= i
;
869 string_char_byte_cache_string
= string
;
874 /* Convert STRING to a multibyte string. */
877 string_make_multibyte (Lisp_Object string
)
884 if (STRING_MULTIBYTE (string
))
887 nbytes
= count_size_as_multibyte (SDATA (string
),
889 /* If all the chars are ASCII, they won't need any more bytes
890 once converted. In that case, we can return STRING itself. */
891 if (nbytes
== SBYTES (string
))
894 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
895 copy_text (SDATA (string
), buf
, SBYTES (string
),
898 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
905 /* Convert STRING (if unibyte) to a multibyte string without changing
906 the number of characters. Characters 0200 trough 0237 are
907 converted to eight-bit characters. */
910 string_to_multibyte (Lisp_Object string
)
917 if (STRING_MULTIBYTE (string
))
920 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
921 /* If all the chars are ASCII, they won't need any more bytes once
923 if (nbytes
== SBYTES (string
))
924 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
926 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
927 memcpy (buf
, SDATA (string
), SBYTES (string
));
928 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
930 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
937 /* Convert STRING to a single-byte string. */
940 string_make_unibyte (Lisp_Object string
)
947 if (! STRING_MULTIBYTE (string
))
950 nchars
= SCHARS (string
);
952 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
953 copy_text (SDATA (string
), buf
, SBYTES (string
),
956 ret
= make_unibyte_string (buf
, nchars
);
962 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
964 doc
: /* Return the multibyte equivalent of STRING.
965 If STRING is unibyte and contains non-ASCII characters, the function
966 `unibyte-char-to-multibyte' is used to convert each unibyte character
967 to a multibyte character. In this case, the returned string is a
968 newly created string with no text properties. If STRING is multibyte
969 or entirely ASCII, it is returned unchanged. In particular, when
970 STRING is unibyte and entirely ASCII, the returned string is unibyte.
971 \(When the characters are all ASCII, Emacs primitives will treat the
972 string the same way whether it is unibyte or multibyte.) */)
975 CHECK_STRING (string
);
977 return string_make_multibyte (string
);
980 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
982 doc
: /* Return the unibyte equivalent of STRING.
983 Multibyte character codes are converted to unibyte according to
984 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
985 If the lookup in the translation table fails, this function takes just
986 the low 8 bits of each character. */)
989 CHECK_STRING (string
);
991 return string_make_unibyte (string
);
994 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
996 doc
: /* Return a unibyte string with the same individual bytes as STRING.
997 If STRING is unibyte, the result is STRING itself.
998 Otherwise it is a newly created string, with no text properties.
999 If STRING is multibyte and contains a character of charset
1000 `eight-bit', it is converted to the corresponding single byte. */)
1001 (Lisp_Object string
)
1003 CHECK_STRING (string
);
1005 if (STRING_MULTIBYTE (string
))
1007 int bytes
= SBYTES (string
);
1008 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1010 memcpy (str
, SDATA (string
), bytes
);
1011 bytes
= str_as_unibyte (str
, bytes
);
1012 string
= make_unibyte_string (str
, bytes
);
1018 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1020 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1021 If STRING is multibyte, the result is STRING itself.
1022 Otherwise it is a newly created string, with no text properties.
1024 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1025 part of a correct utf-8 sequence), it is converted to the corresponding
1026 multibyte character of charset `eight-bit'.
1027 See also `string-to-multibyte'.
1029 Beware, this often doesn't really do what you think it does.
1030 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1031 If you're not sure, whether to use `string-as-multibyte' or
1032 `string-to-multibyte', use `string-to-multibyte'. */)
1033 (Lisp_Object string
)
1035 CHECK_STRING (string
);
1037 if (! STRING_MULTIBYTE (string
))
1039 Lisp_Object new_string
;
1042 parse_str_as_multibyte (SDATA (string
),
1045 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1046 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1047 if (nbytes
!= SBYTES (string
))
1048 str_as_multibyte (SDATA (new_string
), nbytes
,
1049 SBYTES (string
), NULL
);
1050 string
= new_string
;
1051 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1056 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1058 doc
: /* Return a multibyte string with the same individual chars as STRING.
1059 If STRING is multibyte, the result is STRING itself.
1060 Otherwise it is a newly created string, with no text properties.
1062 If STRING is unibyte and contains an 8-bit byte, it is converted to
1063 the corresponding multibyte character of charset `eight-bit'.
1065 This differs from `string-as-multibyte' by converting each byte of a correct
1066 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1067 correct sequence. */)
1068 (Lisp_Object string
)
1070 CHECK_STRING (string
);
1072 return string_to_multibyte (string
);
1075 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1077 doc
: /* Return a unibyte string with the same individual chars as STRING.
1078 If STRING is unibyte, the result is STRING itself.
1079 Otherwise it is a newly created string, with no text properties,
1080 where each `eight-bit' character is converted to the corresponding byte.
1081 If STRING contains a non-ASCII, non-`eight-bit' character,
1082 an error is signaled. */)
1083 (Lisp_Object string
)
1085 CHECK_STRING (string
);
1087 if (STRING_MULTIBYTE (string
))
1089 EMACS_INT chars
= SCHARS (string
);
1090 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1091 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1093 if (converted
< chars
)
1094 error ("Can't convert the %dth character to unibyte", converted
);
1095 string
= make_unibyte_string (str
, chars
);
1102 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1103 doc
: /* Return a copy of ALIST.
1104 This is an alist which represents the same mapping from objects to objects,
1105 but does not share the alist structure with ALIST.
1106 The objects mapped (cars and cdrs of elements of the alist)
1107 are shared, however.
1108 Elements of ALIST that are not conses are also shared. */)
1111 register Lisp_Object tem
;
1116 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1117 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1119 register Lisp_Object car
;
1123 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1128 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1129 doc
: /* Return a new string whose contents are a substring of STRING.
1130 The returned string consists of the characters between index FROM
1131 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1132 zero-indexed: 0 means the first character of STRING. Negative values
1133 are counted from the end of STRING. If TO is nil, the substring runs
1134 to the end of STRING.
1136 The STRING argument may also be a vector. In that case, the return
1137 value is a new vector that contains the elements between index FROM
1138 \(inclusive) and index TO (exclusive) of that vector argument. */)
1139 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1144 int from_char
, to_char
;
1145 int from_byte
= 0, to_byte
= 0;
1147 CHECK_VECTOR_OR_STRING (string
);
1148 CHECK_NUMBER (from
);
1150 if (STRINGP (string
))
1152 size
= SCHARS (string
);
1153 size_byte
= SBYTES (string
);
1156 size
= ASIZE (string
);
1161 to_byte
= size_byte
;
1167 to_char
= XINT (to
);
1171 if (STRINGP (string
))
1172 to_byte
= string_char_to_byte (string
, to_char
);
1175 from_char
= XINT (from
);
1178 if (STRINGP (string
))
1179 from_byte
= string_char_to_byte (string
, from_char
);
1181 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1182 args_out_of_range_3 (string
, make_number (from_char
),
1183 make_number (to_char
));
1185 if (STRINGP (string
))
1187 res
= make_specified_string (SDATA (string
) + from_byte
,
1188 to_char
- from_char
, to_byte
- from_byte
,
1189 STRING_MULTIBYTE (string
));
1190 copy_text_properties (make_number (from_char
), make_number (to_char
),
1191 string
, make_number (0), res
, Qnil
);
1194 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1200 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1201 doc
: /* Return a substring of STRING, without text properties.
1202 It starts at index FROM and ending before TO.
1203 TO may be nil or omitted; then the substring runs to the end of STRING.
1204 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1205 If FROM or TO is negative, it counts from the end.
1207 With one argument, just copy STRING without its properties. */)
1208 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1210 int size
, size_byte
;
1211 int from_char
, to_char
;
1212 int from_byte
, to_byte
;
1214 CHECK_STRING (string
);
1216 size
= SCHARS (string
);
1217 size_byte
= SBYTES (string
);
1220 from_char
= from_byte
= 0;
1223 CHECK_NUMBER (from
);
1224 from_char
= XINT (from
);
1228 from_byte
= string_char_to_byte (string
, from_char
);
1234 to_byte
= size_byte
;
1240 to_char
= XINT (to
);
1244 to_byte
= string_char_to_byte (string
, to_char
);
1247 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1248 args_out_of_range_3 (string
, make_number (from_char
),
1249 make_number (to_char
));
1251 return make_specified_string (SDATA (string
) + from_byte
,
1252 to_char
- from_char
, to_byte
- from_byte
,
1253 STRING_MULTIBYTE (string
));
1256 /* Extract a substring of STRING, giving start and end positions
1257 both in characters and in bytes. */
1260 substring_both (Lisp_Object string
, int from
, int from_byte
, int to
, int to_byte
)
1266 CHECK_VECTOR_OR_STRING (string
);
1268 if (STRINGP (string
))
1270 size
= SCHARS (string
);
1271 size_byte
= SBYTES (string
);
1274 size
= ASIZE (string
);
1276 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1277 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1279 if (STRINGP (string
))
1281 res
= make_specified_string (SDATA (string
) + from_byte
,
1282 to
- from
, to_byte
- from_byte
,
1283 STRING_MULTIBYTE (string
));
1284 copy_text_properties (make_number (from
), make_number (to
),
1285 string
, make_number (0), res
, Qnil
);
1288 res
= Fvector (to
- from
, &AREF (string
, from
));
1293 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1294 doc
: /* Take cdr N times on LIST, returns the result. */)
1295 (Lisp_Object n
, Lisp_Object list
)
1297 register int i
, num
;
1300 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1303 CHECK_LIST_CONS (list
, list
);
1309 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1310 doc
: /* Return the Nth element of LIST.
1311 N counts from zero. If LIST is not that long, nil is returned. */)
1312 (Lisp_Object n
, Lisp_Object list
)
1314 return Fcar (Fnthcdr (n
, list
));
1317 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1318 doc
: /* Return element of SEQUENCE at index N. */)
1319 (register Lisp_Object sequence
, Lisp_Object n
)
1322 if (CONSP (sequence
) || NILP (sequence
))
1323 return Fcar (Fnthcdr (n
, sequence
));
1325 /* Faref signals a "not array" error, so check here. */
1326 CHECK_ARRAY (sequence
, Qsequencep
);
1327 return Faref (sequence
, n
);
1330 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1331 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1332 The value is actually the tail of LIST whose car is ELT. */)
1333 (register Lisp_Object elt
, Lisp_Object list
)
1335 register Lisp_Object tail
;
1336 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1338 register Lisp_Object tem
;
1339 CHECK_LIST_CONS (tail
, list
);
1341 if (! NILP (Fequal (elt
, tem
)))
1348 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1349 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1350 The value is actually the tail of LIST whose car is ELT. */)
1351 (register Lisp_Object elt
, Lisp_Object list
)
1355 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1359 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1363 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1374 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1375 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1376 The value is actually the tail of LIST whose car is ELT. */)
1377 (register Lisp_Object elt
, Lisp_Object list
)
1379 register Lisp_Object tail
;
1382 return Fmemq (elt
, list
);
1384 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1386 register Lisp_Object tem
;
1387 CHECK_LIST_CONS (tail
, list
);
1389 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1396 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1397 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1398 The value is actually the first element of LIST whose car is KEY.
1399 Elements of LIST that are not conses are ignored. */)
1400 (Lisp_Object key
, Lisp_Object list
)
1405 || (CONSP (XCAR (list
))
1406 && EQ (XCAR (XCAR (list
)), key
)))
1411 || (CONSP (XCAR (list
))
1412 && EQ (XCAR (XCAR (list
)), key
)))
1417 || (CONSP (XCAR (list
))
1418 && EQ (XCAR (XCAR (list
)), key
)))
1428 /* Like Fassq but never report an error and do not allow quits.
1429 Use only on lists known never to be circular. */
1432 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1435 && (!CONSP (XCAR (list
))
1436 || !EQ (XCAR (XCAR (list
)), key
)))
1439 return CAR_SAFE (list
);
1442 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1443 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1444 The value is actually the first element of LIST whose car equals KEY. */)
1445 (Lisp_Object key
, Lisp_Object list
)
1452 || (CONSP (XCAR (list
))
1453 && (car
= XCAR (XCAR (list
)),
1454 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1459 || (CONSP (XCAR (list
))
1460 && (car
= XCAR (XCAR (list
)),
1461 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1466 || (CONSP (XCAR (list
))
1467 && (car
= XCAR (XCAR (list
)),
1468 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1478 /* Like Fassoc but never report an error and do not allow quits.
1479 Use only on lists known never to be circular. */
1482 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1485 && (!CONSP (XCAR (list
))
1486 || (!EQ (XCAR (XCAR (list
)), key
)
1487 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1490 return CONSP (list
) ? XCAR (list
) : Qnil
;
1493 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1495 The value is actually the first element of LIST whose cdr is KEY. */)
1496 (register Lisp_Object key
, Lisp_Object list
)
1501 || (CONSP (XCAR (list
))
1502 && EQ (XCDR (XCAR (list
)), key
)))
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCDR (XCAR (list
)), key
)))
1513 || (CONSP (XCAR (list
))
1514 && EQ (XCDR (XCAR (list
)), key
)))
1524 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1525 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1526 The value is actually the first element of LIST whose cdr equals KEY. */)
1527 (Lisp_Object key
, Lisp_Object list
)
1534 || (CONSP (XCAR (list
))
1535 && (cdr
= XCDR (XCAR (list
)),
1536 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (cdr
= XCDR (XCAR (list
)),
1543 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1548 || (CONSP (XCAR (list
))
1549 && (cdr
= XCDR (XCAR (list
)),
1550 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1560 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1561 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1562 The modified LIST is returned. Comparison is done with `eq'.
1563 If the first member of LIST is ELT, there is no way to remove it by side effect;
1564 therefore, write `(setq foo (delq element foo))'
1565 to be sure of changing the value of `foo'. */)
1566 (register Lisp_Object elt
, Lisp_Object list
)
1568 register Lisp_Object tail
, prev
;
1569 register Lisp_Object tem
;
1573 while (!NILP (tail
))
1575 CHECK_LIST_CONS (tail
, list
);
1582 Fsetcdr (prev
, XCDR (tail
));
1592 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1593 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1594 SEQ must be a list, a vector, or a string.
1595 The modified SEQ is returned. Comparison is done with `equal'.
1596 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1597 is not a side effect; it is simply using a different sequence.
1598 Therefore, write `(setq foo (delete element foo))'
1599 to be sure of changing the value of `foo'. */)
1600 (Lisp_Object elt
, Lisp_Object seq
)
1606 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1607 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1610 if (n
!= ASIZE (seq
))
1612 struct Lisp_Vector
*p
= allocate_vector (n
);
1614 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1615 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1616 p
->contents
[n
++] = AREF (seq
, i
);
1618 XSETVECTOR (seq
, p
);
1621 else if (STRINGP (seq
))
1623 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1626 for (i
= nchars
= nbytes
= ibyte
= 0;
1628 ++i
, ibyte
+= cbytes
)
1630 if (STRING_MULTIBYTE (seq
))
1632 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1633 cbytes
= CHAR_BYTES (c
);
1641 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1648 if (nchars
!= SCHARS (seq
))
1652 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1653 if (!STRING_MULTIBYTE (seq
))
1654 STRING_SET_UNIBYTE (tem
);
1656 for (i
= nchars
= nbytes
= ibyte
= 0;
1658 ++i
, ibyte
+= cbytes
)
1660 if (STRING_MULTIBYTE (seq
))
1662 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1663 cbytes
= CHAR_BYTES (c
);
1671 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1673 unsigned char *from
= SDATA (seq
) + ibyte
;
1674 unsigned char *to
= SDATA (tem
) + nbytes
;
1680 for (n
= cbytes
; n
--; )
1690 Lisp_Object tail
, prev
;
1692 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1694 CHECK_LIST_CONS (tail
, seq
);
1696 if (!NILP (Fequal (elt
, XCAR (tail
))))
1701 Fsetcdr (prev
, XCDR (tail
));
1712 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1713 doc
: /* Reverse LIST by modifying cdr pointers.
1714 Return the reversed list. */)
1717 register Lisp_Object prev
, tail
, next
;
1719 if (NILP (list
)) return list
;
1722 while (!NILP (tail
))
1725 CHECK_LIST_CONS (tail
, list
);
1727 Fsetcdr (tail
, prev
);
1734 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1735 doc
: /* Reverse LIST, copying. Return the reversed list.
1736 See also the function `nreverse', which is used more often. */)
1741 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1744 new = Fcons (XCAR (list
), new);
1746 CHECK_LIST_END (list
, list
);
1750 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1752 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1753 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1754 Returns the sorted list. LIST is modified by side effects.
1755 PREDICATE is called with two elements of LIST, and should return non-nil
1756 if the first element should sort before the second. */)
1757 (Lisp_Object list
, Lisp_Object predicate
)
1759 Lisp_Object front
, back
;
1760 register Lisp_Object len
, tem
;
1761 struct gcpro gcpro1
, gcpro2
;
1762 register int length
;
1765 len
= Flength (list
);
1766 length
= XINT (len
);
1770 XSETINT (len
, (length
/ 2) - 1);
1771 tem
= Fnthcdr (len
, list
);
1773 Fsetcdr (tem
, Qnil
);
1775 GCPRO2 (front
, back
);
1776 front
= Fsort (front
, predicate
);
1777 back
= Fsort (back
, predicate
);
1779 return merge (front
, back
, predicate
);
1783 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1786 register Lisp_Object tail
;
1788 register Lisp_Object l1
, l2
;
1789 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1796 /* It is sufficient to protect org_l1 and org_l2.
1797 When l1 and l2 are updated, we copy the new values
1798 back into the org_ vars. */
1799 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1819 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1835 Fsetcdr (tail
, tem
);
1841 /* This does not check for quits. That is safe since it must terminate. */
1843 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1844 doc
: /* Extract a value from a property list.
1845 PLIST is a property list, which is a list of the form
1846 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1847 corresponding to the given PROP, or nil if PROP is not one of the
1848 properties on the list. This function never signals an error. */)
1849 (Lisp_Object plist
, Lisp_Object prop
)
1851 Lisp_Object tail
, halftail
;
1853 /* halftail is used to detect circular lists. */
1854 tail
= halftail
= plist
;
1855 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1857 if (EQ (prop
, XCAR (tail
)))
1858 return XCAR (XCDR (tail
));
1860 tail
= XCDR (XCDR (tail
));
1861 halftail
= XCDR (halftail
);
1862 if (EQ (tail
, halftail
))
1865 #if 0 /* Unsafe version. */
1866 /* This function can be called asynchronously
1867 (setup_coding_system). Don't QUIT in that case. */
1868 if (!interrupt_input_blocked
)
1876 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1877 doc
: /* Return the value of SYMBOL's PROPNAME property.
1878 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1879 (Lisp_Object symbol
, Lisp_Object propname
)
1881 CHECK_SYMBOL (symbol
);
1882 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1885 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1886 doc
: /* Change value in PLIST of PROP to VAL.
1887 PLIST is a property list, which is a list of the form
1888 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1889 If PROP is already a property on the list, its value is set to VAL,
1890 otherwise the new PROP VAL pair is added. The new plist is returned;
1891 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1892 The PLIST is modified by side effects. */)
1893 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1895 register Lisp_Object tail
, prev
;
1896 Lisp_Object newcell
;
1898 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1899 tail
= XCDR (XCDR (tail
)))
1901 if (EQ (prop
, XCAR (tail
)))
1903 Fsetcar (XCDR (tail
), val
);
1910 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1914 Fsetcdr (XCDR (prev
), newcell
);
1918 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1919 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1920 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1921 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1923 CHECK_SYMBOL (symbol
);
1924 XSYMBOL (symbol
)->plist
1925 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1929 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1930 doc
: /* Extract a value from a property list, comparing with `equal'.
1931 PLIST is a property list, which is a list of the form
1932 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1933 corresponding to the given PROP, or nil if PROP is not
1934 one of the properties on the list. */)
1935 (Lisp_Object plist
, Lisp_Object prop
)
1940 CONSP (tail
) && CONSP (XCDR (tail
));
1941 tail
= XCDR (XCDR (tail
)))
1943 if (! NILP (Fequal (prop
, XCAR (tail
))))
1944 return XCAR (XCDR (tail
));
1949 CHECK_LIST_END (tail
, prop
);
1954 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1955 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1956 PLIST is a property list, which is a list of the form
1957 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1958 If PROP is already a property on the list, its value is set to VAL,
1959 otherwise the new PROP VAL pair is added. The new plist is returned;
1960 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1961 The PLIST is modified by side effects. */)
1962 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1964 register Lisp_Object tail
, prev
;
1965 Lisp_Object newcell
;
1967 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1968 tail
= XCDR (XCDR (tail
)))
1970 if (! NILP (Fequal (prop
, XCAR (tail
))))
1972 Fsetcar (XCDR (tail
), val
);
1979 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1983 Fsetcdr (XCDR (prev
), newcell
);
1987 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1988 doc
: /* Return t if the two args are the same Lisp object.
1989 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1990 (Lisp_Object obj1
, Lisp_Object obj2
)
1993 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1995 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1998 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1999 doc
: /* Return t if two Lisp objects have similar structure and contents.
2000 They must have the same data type.
2001 Conses are compared by comparing the cars and the cdrs.
2002 Vectors and strings are compared element by element.
2003 Numbers are compared by value, but integers cannot equal floats.
2004 (Use `=' if you want integers and floats to be able to be equal.)
2005 Symbols must match exactly. */)
2006 (register Lisp_Object o1
, Lisp_Object o2
)
2008 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2011 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2012 doc
: /* Return t if two Lisp objects have similar structure and contents.
2013 This is like `equal' except that it compares the text properties
2014 of strings. (`equal' ignores text properties.) */)
2015 (register Lisp_Object o1
, Lisp_Object o2
)
2017 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2020 /* DEPTH is current depth of recursion. Signal an error if it
2022 PROPS, if non-nil, means compare string text properties too. */
2025 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2028 error ("Stack overflow in equal");
2034 if (XTYPE (o1
) != XTYPE (o2
))
2043 d1
= extract_float (o1
);
2044 d2
= extract_float (o2
);
2045 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2046 though they are not =. */
2047 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2051 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2058 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2062 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2064 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2067 o1
= XOVERLAY (o1
)->plist
;
2068 o2
= XOVERLAY (o2
)->plist
;
2073 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2074 && (XMARKER (o1
)->buffer
== 0
2075 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2079 case Lisp_Vectorlike
:
2082 EMACS_INT size
= ASIZE (o1
);
2083 /* Pseudovectors have the type encoded in the size field, so this test
2084 actually checks that the objects have the same type as well as the
2086 if (ASIZE (o2
) != size
)
2088 /* Boolvectors are compared much like strings. */
2089 if (BOOL_VECTOR_P (o1
))
2092 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2093 / BOOL_VECTOR_BITS_PER_CHAR
);
2095 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2097 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2102 if (WINDOW_CONFIGURATIONP (o1
))
2103 return compare_window_configurations (o1
, o2
, 0);
2105 /* Aside from them, only true vectors, char-tables, compiled
2106 functions, and fonts (font-spec, font-entity, font-ojbect)
2107 are sensible to compare, so eliminate the others now. */
2108 if (size
& PSEUDOVECTOR_FLAG
)
2110 if (!(size
& (PVEC_COMPILED
2111 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2113 size
&= PSEUDOVECTOR_SIZE_MASK
;
2115 for (i
= 0; i
< size
; i
++)
2120 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2128 if (SCHARS (o1
) != SCHARS (o2
))
2130 if (SBYTES (o1
) != SBYTES (o2
))
2132 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2134 if (props
&& !compare_string_intervals (o1
, o2
))
2146 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2147 doc
: /* Store each element of ARRAY with ITEM.
2148 ARRAY is a vector, string, char-table, or bool-vector. */)
2149 (Lisp_Object array
, Lisp_Object item
)
2151 register int size
, index
, charval
;
2152 if (VECTORP (array
))
2154 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2155 size
= ASIZE (array
);
2156 for (index
= 0; index
< size
; index
++)
2159 else if (CHAR_TABLE_P (array
))
2163 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2164 XCHAR_TABLE (array
)->contents
[i
] = item
;
2165 XCHAR_TABLE (array
)->defalt
= item
;
2167 else if (STRINGP (array
))
2169 register unsigned char *p
= SDATA (array
);
2170 CHECK_NUMBER (item
);
2171 charval
= XINT (item
);
2172 size
= SCHARS (array
);
2173 if (STRING_MULTIBYTE (array
))
2175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2176 int len
= CHAR_STRING (charval
, str
);
2177 int size_byte
= SBYTES (array
);
2178 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2181 if (size
!= size_byte
)
2184 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2185 if (len
!= this_len
)
2186 error ("Attempt to change byte length of a string");
2189 for (i
= 0; i
< size_byte
; i
++)
2190 *p
++ = str
[i
% len
];
2193 for (index
= 0; index
< size
; index
++)
2196 else if (BOOL_VECTOR_P (array
))
2198 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2200 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2201 / BOOL_VECTOR_BITS_PER_CHAR
);
2203 charval
= (! NILP (item
) ? -1 : 0);
2204 for (index
= 0; index
< size_in_chars
- 1; index
++)
2206 if (index
< size_in_chars
)
2208 /* Mask out bits beyond the vector size. */
2209 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2210 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2215 wrong_type_argument (Qarrayp
, array
);
2219 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2221 doc
: /* Clear the contents of STRING.
2222 This makes STRING unibyte and may change its length. */)
2223 (Lisp_Object string
)
2226 CHECK_STRING (string
);
2227 len
= SBYTES (string
);
2228 memset (SDATA (string
), 0, len
);
2229 STRING_SET_CHARS (string
, len
);
2230 STRING_SET_UNIBYTE (string
);
2236 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2238 Lisp_Object args
[2];
2241 return Fnconc (2, args
);
2244 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2245 doc
: /* Concatenate any number of lists by altering them.
2246 Only the last argument is not altered, and need not be a list.
2247 usage: (nconc &rest LISTS) */)
2248 (int nargs
, Lisp_Object
*args
)
2250 register int argnum
;
2251 register Lisp_Object tail
, tem
, val
;
2255 for (argnum
= 0; argnum
< nargs
; argnum
++)
2258 if (NILP (tem
)) continue;
2263 if (argnum
+ 1 == nargs
) break;
2265 CHECK_LIST_CONS (tem
, tem
);
2274 tem
= args
[argnum
+ 1];
2275 Fsetcdr (tail
, tem
);
2277 args
[argnum
+ 1] = tail
;
2283 /* This is the guts of all mapping functions.
2284 Apply FN to each element of SEQ, one by one,
2285 storing the results into elements of VALS, a C vector of Lisp_Objects.
2286 LENI is the length of VALS, which should also be the length of SEQ. */
2289 mapcar1 (int leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2291 register Lisp_Object tail
;
2294 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2298 /* Don't let vals contain any garbage when GC happens. */
2299 for (i
= 0; i
< leni
; i
++)
2302 GCPRO3 (dummy
, fn
, seq
);
2304 gcpro1
.nvars
= leni
;
2308 /* We need not explicitly protect `tail' because it is used only on lists, and
2309 1) lists are not relocated and 2) the list is marked via `seq' so will not
2314 for (i
= 0; i
< leni
; i
++)
2316 dummy
= call1 (fn
, AREF (seq
, i
));
2321 else if (BOOL_VECTOR_P (seq
))
2323 for (i
= 0; i
< leni
; i
++)
2326 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2327 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2328 dummy
= call1 (fn
, dummy
);
2333 else if (STRINGP (seq
))
2337 for (i
= 0, i_byte
= 0; i
< leni
;)
2342 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2343 XSETFASTINT (dummy
, c
);
2344 dummy
= call1 (fn
, dummy
);
2346 vals
[i_before
] = dummy
;
2349 else /* Must be a list, since Flength did not get an error */
2352 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2354 dummy
= call1 (fn
, XCAR (tail
));
2364 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2365 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2366 In between each pair of results, stick in SEPARATOR. Thus, " " as
2367 SEPARATOR results in spaces between the values returned by FUNCTION.
2368 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2369 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2374 register Lisp_Object
*args
;
2376 struct gcpro gcpro1
;
2380 len
= Flength (sequence
);
2381 if (CHAR_TABLE_P (sequence
))
2382 wrong_type_argument (Qlistp
, sequence
);
2384 nargs
= leni
+ leni
- 1;
2385 if (nargs
< 0) return empty_unibyte_string
;
2387 SAFE_ALLOCA_LISP (args
, nargs
);
2390 mapcar1 (leni
, args
, function
, sequence
);
2393 for (i
= leni
- 1; i
> 0; i
--)
2394 args
[i
+ i
] = args
[i
];
2396 for (i
= 1; i
< nargs
; i
+= 2)
2397 args
[i
] = separator
;
2399 ret
= Fconcat (nargs
, args
);
2405 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2406 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2407 The result is a list just as long as SEQUENCE.
2408 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2409 (Lisp_Object function
, Lisp_Object sequence
)
2411 register Lisp_Object len
;
2413 register Lisp_Object
*args
;
2417 len
= Flength (sequence
);
2418 if (CHAR_TABLE_P (sequence
))
2419 wrong_type_argument (Qlistp
, sequence
);
2420 leni
= XFASTINT (len
);
2422 SAFE_ALLOCA_LISP (args
, leni
);
2424 mapcar1 (leni
, args
, function
, sequence
);
2426 ret
= Flist (leni
, args
);
2432 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2433 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2434 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2435 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2436 (Lisp_Object function
, Lisp_Object sequence
)
2440 leni
= XFASTINT (Flength (sequence
));
2441 if (CHAR_TABLE_P (sequence
))
2442 wrong_type_argument (Qlistp
, sequence
);
2443 mapcar1 (leni
, 0, function
, sequence
);
2448 /* Anything that calls this function must protect from GC! */
2450 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2451 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2452 Takes one argument, which is the string to display to ask the question.
2453 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2454 No confirmation of the answer is requested; a single character is enough.
2455 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2456 the bindings in `query-replace-map'; see the documentation of that variable
2457 for more information. In this case, the useful bindings are `act', `skip',
2458 `recenter', and `quit'.\)
2460 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2461 is nil and `use-dialog-box' is non-nil. */)
2462 (Lisp_Object prompt
)
2464 register Lisp_Object obj
, key
, def
, map
;
2465 register int answer
;
2466 Lisp_Object xprompt
;
2467 Lisp_Object args
[2];
2468 struct gcpro gcpro1
, gcpro2
;
2469 int count
= SPECPDL_INDEX ();
2471 specbind (Qcursor_in_echo_area
, Qt
);
2473 map
= Fsymbol_value (intern ("query-replace-map"));
2475 CHECK_STRING (prompt
);
2477 GCPRO2 (prompt
, xprompt
);
2479 #ifdef HAVE_WINDOW_SYSTEM
2480 if (display_hourglass_p
)
2481 cancel_hourglass ();
2488 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2489 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2493 Lisp_Object pane
, menu
;
2494 redisplay_preserve_echo_area (3);
2495 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2496 Fcons (Fcons (build_string ("No"), Qnil
),
2498 menu
= Fcons (prompt
, pane
);
2499 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2500 answer
= !NILP (obj
);
2503 #endif /* HAVE_MENUS */
2504 cursor_in_echo_area
= 1;
2505 choose_minibuf_frame ();
2508 Lisp_Object pargs
[3];
2510 /* Colorize prompt according to `minibuffer-prompt' face. */
2511 pargs
[0] = build_string ("%s(y or n) ");
2512 pargs
[1] = intern ("face");
2513 pargs
[2] = intern ("minibuffer-prompt");
2514 args
[0] = Fpropertize (3, pargs
);
2519 if (minibuffer_auto_raise
)
2521 Lisp_Object mini_frame
;
2523 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2525 Fraise_frame (mini_frame
);
2528 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2529 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2530 cursor_in_echo_area
= 0;
2531 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2534 key
= Fmake_vector (make_number (1), obj
);
2535 def
= Flookup_key (map
, key
, Qt
);
2537 if (EQ (def
, intern ("skip")))
2542 else if (EQ (def
, intern ("act")))
2547 else if (EQ (def
, intern ("recenter")))
2553 else if (EQ (def
, intern ("quit")))
2555 /* We want to exit this command for exit-prefix,
2556 and this is the only way to do it. */
2557 else if (EQ (def
, intern ("exit-prefix")))
2562 /* If we don't clear this, then the next call to read_char will
2563 return quit_char again, and we'll enter an infinite loop. */
2568 if (EQ (xprompt
, prompt
))
2570 args
[0] = build_string ("Please answer y or n. ");
2572 xprompt
= Fconcat (2, args
);
2577 if (! noninteractive
)
2579 cursor_in_echo_area
= -1;
2580 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2584 unbind_to (count
, Qnil
);
2585 return answer
? Qt
: Qnil
;
2588 /* This is how C code calls `yes-or-no-p' and allows the user
2591 Anything that calls this function must protect from GC! */
2594 do_yes_or_no_p (Lisp_Object prompt
)
2596 return call1 (intern ("yes-or-no-p"), prompt
);
2599 /* Anything that calls this function must protect from GC! */
2601 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2602 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2603 Takes one argument, which is the string to display to ask the question.
2604 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2605 The user must confirm the answer with RET,
2606 and can edit it until it has been confirmed.
2608 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2609 is nil, and `use-dialog-box' is non-nil. */)
2610 (Lisp_Object prompt
)
2612 register Lisp_Object ans
;
2613 Lisp_Object args
[2];
2614 struct gcpro gcpro1
;
2616 CHECK_STRING (prompt
);
2619 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2620 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2624 Lisp_Object pane
, menu
, obj
;
2625 redisplay_preserve_echo_area (4);
2626 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2627 Fcons (Fcons (build_string ("No"), Qnil
),
2630 menu
= Fcons (prompt
, pane
);
2631 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2635 #endif /* HAVE_MENUS */
2638 args
[1] = build_string ("(yes or no) ");
2639 prompt
= Fconcat (2, args
);
2645 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2646 Qyes_or_no_p_history
, Qnil
,
2648 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2653 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2661 message ("Please answer yes or no.");
2662 Fsleep_for (make_number (2), Qnil
);
2666 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2667 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2669 Each of the three load averages is multiplied by 100, then converted
2672 When USE-FLOATS is non-nil, floats will be used instead of integers.
2673 These floats are not multiplied by 100.
2675 If the 5-minute or 15-minute load averages are not available, return a
2676 shortened list, containing only those averages which are available.
2678 An error is thrown if the load average can't be obtained. In some
2679 cases making it work would require Emacs being installed setuid or
2680 setgid so that it can read kernel information, and that usually isn't
2682 (Lisp_Object use_floats
)
2685 int loads
= getloadavg (load_ave
, 3);
2686 Lisp_Object ret
= Qnil
;
2689 error ("load-average not implemented for this operating system");
2693 Lisp_Object load
= (NILP (use_floats
) ?
2694 make_number ((int) (100.0 * load_ave
[loads
]))
2695 : make_float (load_ave
[loads
]));
2696 ret
= Fcons (load
, ret
);
2702 Lisp_Object Vfeatures
, Qsubfeatures
;
2704 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2705 doc
: /* Returns t if FEATURE is present in this Emacs.
2707 Use this to conditionalize execution of lisp code based on the
2708 presence or absence of Emacs or environment extensions.
2709 Use `provide' to declare that a feature is available. This function
2710 looks at the value of the variable `features'. The optional argument
2711 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2712 (Lisp_Object feature
, Lisp_Object subfeature
)
2714 register Lisp_Object tem
;
2715 CHECK_SYMBOL (feature
);
2716 tem
= Fmemq (feature
, Vfeatures
);
2717 if (!NILP (tem
) && !NILP (subfeature
))
2718 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2719 return (NILP (tem
)) ? Qnil
: Qt
;
2722 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2723 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2724 The optional argument SUBFEATURES should be a list of symbols listing
2725 particular subfeatures supported in this version of FEATURE. */)
2726 (Lisp_Object feature
, Lisp_Object subfeatures
)
2728 register Lisp_Object tem
;
2729 CHECK_SYMBOL (feature
);
2730 CHECK_LIST (subfeatures
);
2731 if (!NILP (Vautoload_queue
))
2732 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2734 tem
= Fmemq (feature
, Vfeatures
);
2736 Vfeatures
= Fcons (feature
, Vfeatures
);
2737 if (!NILP (subfeatures
))
2738 Fput (feature
, Qsubfeatures
, subfeatures
);
2739 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2741 /* Run any load-hooks for this file. */
2742 tem
= Fassq (feature
, Vafter_load_alist
);
2744 Fprogn (XCDR (tem
));
2749 /* `require' and its subroutines. */
2751 /* List of features currently being require'd, innermost first. */
2753 Lisp_Object require_nesting_list
;
2756 require_unwind (Lisp_Object old_value
)
2758 return require_nesting_list
= old_value
;
2761 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2762 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2763 If FEATURE is not a member of the list `features', then the feature
2764 is not loaded; so load the file FILENAME.
2765 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2766 and `load' will try to load this name appended with the suffix `.elc' or
2767 `.el', in that order. The name without appended suffix will not be used.
2768 If the optional third argument NOERROR is non-nil,
2769 then return nil if the file is not found instead of signaling an error.
2770 Normally the return value is FEATURE.
2771 The normal messages at start and end of loading FILENAME are suppressed. */)
2772 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2774 register Lisp_Object tem
;
2775 struct gcpro gcpro1
, gcpro2
;
2776 int from_file
= load_in_progress
;
2778 CHECK_SYMBOL (feature
);
2780 /* Record the presence of `require' in this file
2781 even if the feature specified is already loaded.
2782 But not more than once in any file,
2783 and not when we aren't loading or reading from a file. */
2785 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2786 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2791 tem
= Fcons (Qrequire
, feature
);
2792 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2793 LOADHIST_ATTACH (tem
);
2795 tem
= Fmemq (feature
, Vfeatures
);
2799 int count
= SPECPDL_INDEX ();
2802 /* This is to make sure that loadup.el gives a clear picture
2803 of what files are preloaded and when. */
2804 if (! NILP (Vpurify_flag
))
2805 error ("(require %s) while preparing to dump",
2806 SDATA (SYMBOL_NAME (feature
)));
2808 /* A certain amount of recursive `require' is legitimate,
2809 but if we require the same feature recursively 3 times,
2811 tem
= require_nesting_list
;
2812 while (! NILP (tem
))
2814 if (! NILP (Fequal (feature
, XCAR (tem
))))
2819 error ("Recursive `require' for feature `%s'",
2820 SDATA (SYMBOL_NAME (feature
)));
2822 /* Update the list for any nested `require's that occur. */
2823 record_unwind_protect (require_unwind
, require_nesting_list
);
2824 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2826 /* Value saved here is to be restored into Vautoload_queue */
2827 record_unwind_protect (un_autoload
, Vautoload_queue
);
2828 Vautoload_queue
= Qt
;
2830 /* Load the file. */
2831 GCPRO2 (feature
, filename
);
2832 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2833 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2836 /* If load failed entirely, return nil. */
2838 return unbind_to (count
, Qnil
);
2840 tem
= Fmemq (feature
, Vfeatures
);
2842 error ("Required feature `%s' was not provided",
2843 SDATA (SYMBOL_NAME (feature
)));
2845 /* Once loading finishes, don't undo it. */
2846 Vautoload_queue
= Qt
;
2847 feature
= unbind_to (count
, feature
);
2853 /* Primitives for work of the "widget" library.
2854 In an ideal world, this section would not have been necessary.
2855 However, lisp function calls being as slow as they are, it turns
2856 out that some functions in the widget library (wid-edit.el) are the
2857 bottleneck of Widget operation. Here is their translation to C,
2858 for the sole reason of efficiency. */
2860 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2861 doc
: /* Return non-nil if PLIST has the property PROP.
2862 PLIST is a property list, which is a list of the form
2863 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2864 Unlike `plist-get', this allows you to distinguish between a missing
2865 property and a property with the value nil.
2866 The value is actually the tail of PLIST whose car is PROP. */)
2867 (Lisp_Object plist
, Lisp_Object prop
)
2869 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2872 plist
= XCDR (plist
);
2873 plist
= CDR (plist
);
2878 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2879 doc
: /* In WIDGET, set PROPERTY to VALUE.
2880 The value can later be retrieved with `widget-get'. */)
2881 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2883 CHECK_CONS (widget
);
2884 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2888 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2889 doc
: /* In WIDGET, get the value of PROPERTY.
2890 The value could either be specified when the widget was created, or
2891 later with `widget-put'. */)
2892 (Lisp_Object widget
, Lisp_Object property
)
2900 CHECK_CONS (widget
);
2901 tmp
= Fplist_member (XCDR (widget
), property
);
2907 tmp
= XCAR (widget
);
2910 widget
= Fget (tmp
, Qwidget_type
);
2914 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2915 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2916 ARGS are passed as extra arguments to the function.
2917 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2918 (int nargs
, Lisp_Object
*args
)
2920 /* This function can GC. */
2921 Lisp_Object newargs
[3];
2922 struct gcpro gcpro1
, gcpro2
;
2925 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2926 newargs
[1] = args
[0];
2927 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2928 GCPRO2 (newargs
[0], newargs
[2]);
2929 result
= Fapply (3, newargs
);
2934 #ifdef HAVE_LANGINFO_CODESET
2935 #include <langinfo.h>
2938 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2939 doc
: /* Access locale data ITEM for the current C locale, if available.
2940 ITEM should be one of the following:
2942 `codeset', returning the character set as a string (locale item CODESET);
2944 `days', returning a 7-element vector of day names (locale items DAY_n);
2946 `months', returning a 12-element vector of month names (locale items MON_n);
2948 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2949 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2951 If the system can't provide such information through a call to
2952 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2954 See also Info node `(libc)Locales'.
2956 The data read from the system are decoded using `locale-coding-system'. */)
2960 #ifdef HAVE_LANGINFO_CODESET
2962 if (EQ (item
, Qcodeset
))
2964 str
= nl_langinfo (CODESET
);
2965 return build_string (str
);
2968 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2970 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2971 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2973 struct gcpro gcpro1
;
2975 synchronize_system_time_locale ();
2976 for (i
= 0; i
< 7; i
++)
2978 str
= nl_langinfo (days
[i
]);
2979 val
= make_unibyte_string (str
, strlen (str
));
2980 /* Fixme: Is this coding system necessarily right, even if
2981 it is consistent with CODESET? If not, what to do? */
2982 Faset (v
, make_number (i
),
2983 code_convert_string_norecord (val
, Vlocale_coding_system
,
2991 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2993 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2994 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2995 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2997 struct gcpro gcpro1
;
2999 synchronize_system_time_locale ();
3000 for (i
= 0; i
< 12; i
++)
3002 str
= nl_langinfo (months
[i
]);
3003 val
= make_unibyte_string (str
, strlen (str
));
3004 Faset (v
, make_number (i
),
3005 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3011 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3012 but is in the locale files. This could be used by ps-print. */
3014 else if (EQ (item
, Qpaper
))
3016 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3017 make_number (nl_langinfo (PAPER_HEIGHT
)));
3019 #endif /* PAPER_WIDTH */
3020 #endif /* HAVE_LANGINFO_CODESET*/
3024 /* base64 encode/decode functions (RFC 2045).
3025 Based on code from GNU recode. */
3027 #define MIME_LINE_LENGTH 76
3029 #define IS_ASCII(Character) \
3031 #define IS_BASE64(Character) \
3032 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3033 #define IS_BASE64_IGNORABLE(Character) \
3034 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3035 || (Character) == '\f' || (Character) == '\r')
3037 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3038 character or return retval if there are no characters left to
3040 #define READ_QUADRUPLET_BYTE(retval) \
3045 if (nchars_return) \
3046 *nchars_return = nchars; \
3051 while (IS_BASE64_IGNORABLE (c))
3053 /* Table of characters coding the 64 values. */
3054 static const char base64_value_to_char
[64] =
3056 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3057 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3058 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3059 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3060 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3061 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3062 '8', '9', '+', '/' /* 60-63 */
3065 /* Table of base64 values for first 128 characters. */
3066 static const short base64_char_to_value
[128] =
3068 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3069 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3070 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3071 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3072 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3073 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3074 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3075 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3076 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3077 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3078 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3079 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3080 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3083 /* The following diagram shows the logical steps by which three octets
3084 get transformed into four base64 characters.
3086 .--------. .--------. .--------.
3087 |aaaaaabb| |bbbbcccc| |ccdddddd|
3088 `--------' `--------' `--------'
3090 .--------+--------+--------+--------.
3091 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3092 `--------+--------+--------+--------'
3094 .--------+--------+--------+--------.
3095 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3096 `--------+--------+--------+--------'
3098 The octets are divided into 6 bit chunks, which are then encoded into
3099 base64 characters. */
3102 static int base64_encode_1 (const char *, char *, int, int, int);
3103 static int base64_decode_1 (const char *, char *, int, int, int *);
3105 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3107 doc
: /* Base64-encode the region between BEG and END.
3108 Return the length of the encoded text.
3109 Optional third argument NO-LINE-BREAK means do not break long lines
3110 into shorter lines. */)
3111 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3114 int allength
, length
;
3115 int ibeg
, iend
, encoded_length
;
3119 validate_region (&beg
, &end
);
3121 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3122 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3123 move_gap_both (XFASTINT (beg
), ibeg
);
3125 /* We need to allocate enough room for encoding the text.
3126 We need 33 1/3% more space, plus a newline every 76
3127 characters, and then we round up. */
3128 length
= iend
- ibeg
;
3129 allength
= length
+ length
/3 + 1;
3130 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3132 SAFE_ALLOCA (encoded
, char *, allength
);
3133 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3134 NILP (no_line_break
),
3135 !NILP (current_buffer
->enable_multibyte_characters
));
3136 if (encoded_length
> allength
)
3139 if (encoded_length
< 0)
3141 /* The encoding wasn't possible. */
3143 error ("Multibyte character in data for base64 encoding");
3146 /* Now we have encoded the region, so we insert the new contents
3147 and delete the old. (Insert first in order to preserve markers.) */
3148 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3149 insert (encoded
, encoded_length
);
3151 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3153 /* If point was outside of the region, restore it exactly; else just
3154 move to the beginning of the region. */
3155 if (old_pos
>= XFASTINT (end
))
3156 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3157 else if (old_pos
> XFASTINT (beg
))
3158 old_pos
= XFASTINT (beg
);
3161 /* We return the length of the encoded text. */
3162 return make_number (encoded_length
);
3165 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3167 doc
: /* Base64-encode STRING and return the result.
3168 Optional second argument NO-LINE-BREAK means do not break long lines
3169 into shorter lines. */)
3170 (Lisp_Object string
, Lisp_Object no_line_break
)
3172 int allength
, length
, encoded_length
;
3174 Lisp_Object encoded_string
;
3177 CHECK_STRING (string
);
3179 /* We need to allocate enough room for encoding the text.
3180 We need 33 1/3% more space, plus a newline every 76
3181 characters, and then we round up. */
3182 length
= SBYTES (string
);
3183 allength
= length
+ length
/3 + 1;
3184 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3186 /* We need to allocate enough room for decoding the text. */
3187 SAFE_ALLOCA (encoded
, char *, allength
);
3189 encoded_length
= base64_encode_1 (SDATA (string
),
3190 encoded
, length
, NILP (no_line_break
),
3191 STRING_MULTIBYTE (string
));
3192 if (encoded_length
> allength
)
3195 if (encoded_length
< 0)
3197 /* The encoding wasn't possible. */
3199 error ("Multibyte character in data for base64 encoding");
3202 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3205 return encoded_string
;
3209 base64_encode_1 (const char *from
, char *to
, int length
, int line_break
, int multibyte
)
3211 int counter
= 0, i
= 0;
3221 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3222 if (CHAR_BYTE8_P (c
))
3223 c
= CHAR_TO_BYTE8 (c
);
3231 /* Wrap line every 76 characters. */
3235 if (counter
< MIME_LINE_LENGTH
/ 4)
3244 /* Process first byte of a triplet. */
3246 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3247 value
= (0x03 & c
) << 4;
3249 /* Process second byte of a triplet. */
3253 *e
++ = base64_value_to_char
[value
];
3261 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3262 if (CHAR_BYTE8_P (c
))
3263 c
= CHAR_TO_BYTE8 (c
);
3271 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3272 value
= (0x0f & c
) << 2;
3274 /* Process third byte of a triplet. */
3278 *e
++ = base64_value_to_char
[value
];
3285 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3286 if (CHAR_BYTE8_P (c
))
3287 c
= CHAR_TO_BYTE8 (c
);
3295 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3296 *e
++ = base64_value_to_char
[0x3f & c
];
3303 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3305 doc
: /* Base64-decode the region between BEG and END.
3306 Return the length of the decoded text.
3307 If the region can't be decoded, signal an error and don't modify the buffer. */)
3308 (Lisp_Object beg
, Lisp_Object end
)
3310 int ibeg
, iend
, length
, allength
;
3315 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3318 validate_region (&beg
, &end
);
3320 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3321 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3323 length
= iend
- ibeg
;
3325 /* We need to allocate enough room for decoding the text. If we are
3326 working on a multibyte buffer, each decoded code may occupy at
3328 allength
= multibyte
? length
* 2 : length
;
3329 SAFE_ALLOCA (decoded
, char *, allength
);
3331 move_gap_both (XFASTINT (beg
), ibeg
);
3332 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3333 multibyte
, &inserted_chars
);
3334 if (decoded_length
> allength
)
3337 if (decoded_length
< 0)
3339 /* The decoding wasn't possible. */
3341 error ("Invalid base64 data");
3344 /* Now we have decoded the region, so we insert the new contents
3345 and delete the old. (Insert first in order to preserve markers.) */
3346 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3347 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3350 /* Delete the original text. */
3351 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3352 iend
+ decoded_length
, 1);
3354 /* If point was outside of the region, restore it exactly; else just
3355 move to the beginning of the region. */
3356 if (old_pos
>= XFASTINT (end
))
3357 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3358 else if (old_pos
> XFASTINT (beg
))
3359 old_pos
= XFASTINT (beg
);
3360 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3362 return make_number (inserted_chars
);
3365 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3367 doc
: /* Base64-decode STRING and return the result. */)
3368 (Lisp_Object string
)
3371 int length
, decoded_length
;
3372 Lisp_Object decoded_string
;
3375 CHECK_STRING (string
);
3377 length
= SBYTES (string
);
3378 /* We need to allocate enough room for decoding the text. */
3379 SAFE_ALLOCA (decoded
, char *, length
);
3381 /* The decoded result should be unibyte. */
3382 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3384 if (decoded_length
> length
)
3386 else if (decoded_length
>= 0)
3387 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3389 decoded_string
= Qnil
;
3392 if (!STRINGP (decoded_string
))
3393 error ("Invalid base64 data");
3395 return decoded_string
;
3398 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3399 MULTIBYTE is nonzero, the decoded result should be in multibyte
3400 form. If NCHARS_RETRUN is not NULL, store the number of produced
3401 characters in *NCHARS_RETURN. */
3404 base64_decode_1 (const char *from
, char *to
, int length
, int multibyte
, int *nchars_return
)
3409 unsigned long value
;
3414 /* Process first byte of a quadruplet. */
3416 READ_QUADRUPLET_BYTE (e
-to
);
3420 value
= base64_char_to_value
[c
] << 18;
3422 /* Process second byte of a quadruplet. */
3424 READ_QUADRUPLET_BYTE (-1);
3428 value
|= base64_char_to_value
[c
] << 12;
3430 c
= (unsigned char) (value
>> 16);
3431 if (multibyte
&& c
>= 128)
3432 e
+= BYTE8_STRING (c
, e
);
3437 /* Process third byte of a quadruplet. */
3439 READ_QUADRUPLET_BYTE (-1);
3443 READ_QUADRUPLET_BYTE (-1);
3452 value
|= base64_char_to_value
[c
] << 6;
3454 c
= (unsigned char) (0xff & value
>> 8);
3455 if (multibyte
&& c
>= 128)
3456 e
+= BYTE8_STRING (c
, e
);
3461 /* Process fourth byte of a quadruplet. */
3463 READ_QUADRUPLET_BYTE (-1);
3470 value
|= base64_char_to_value
[c
];
3472 c
= (unsigned char) (0xff & value
);
3473 if (multibyte
&& c
>= 128)
3474 e
+= BYTE8_STRING (c
, e
);
3483 /***********************************************************************
3485 ***** Hash Tables *****
3487 ***********************************************************************/
3489 /* Implemented by gerd@gnu.org. This hash table implementation was
3490 inspired by CMUCL hash tables. */
3494 1. For small tables, association lists are probably faster than
3495 hash tables because they have lower overhead.
3497 For uses of hash tables where the O(1) behavior of table
3498 operations is not a requirement, it might therefore be a good idea
3499 not to hash. Instead, we could just do a linear search in the
3500 key_and_value vector of the hash table. This could be done
3501 if a `:linear-search t' argument is given to make-hash-table. */
3504 /* The list of all weak hash tables. Don't staticpro this one. */
3506 struct Lisp_Hash_Table
*weak_hash_tables
;
3508 /* Various symbols. */
3510 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3511 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3512 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3514 /* Function prototypes. */
3516 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3517 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3518 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3519 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3520 Lisp_Object
, unsigned);
3521 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3522 Lisp_Object
, unsigned);
3523 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3524 unsigned, Lisp_Object
, unsigned);
3525 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3526 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3527 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3528 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3530 static unsigned sxhash_string (unsigned char *, int);
3531 static unsigned sxhash_list (Lisp_Object
, int);
3532 static unsigned sxhash_vector (Lisp_Object
, int);
3533 static unsigned sxhash_bool_vector (Lisp_Object
);
3534 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3538 /***********************************************************************
3540 ***********************************************************************/
3542 /* If OBJ is a Lisp hash table, return a pointer to its struct
3543 Lisp_Hash_Table. Otherwise, signal an error. */
3545 static struct Lisp_Hash_Table
*
3546 check_hash_table (Lisp_Object obj
)
3548 CHECK_HASH_TABLE (obj
);
3549 return XHASH_TABLE (obj
);
3553 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3557 next_almost_prime (int n
)
3569 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3570 which USED[I] is non-zero. If found at index I in ARGS, set
3571 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3572 -1. This function is used to extract a keyword/argument pair from
3573 a DEFUN parameter list. */
3576 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3580 for (i
= 0; i
< nargs
- 1; ++i
)
3581 if (!used
[i
] && EQ (args
[i
], key
))
3596 /* Return a Lisp vector which has the same contents as VEC but has
3597 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3598 vector that are not copied from VEC are set to INIT. */
3601 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3603 struct Lisp_Vector
*v
;
3606 xassert (VECTORP (vec
));
3607 old_size
= ASIZE (vec
);
3608 xassert (new_size
>= old_size
);
3610 v
= allocate_vector (new_size
);
3611 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3612 for (i
= old_size
; i
< new_size
; ++i
)
3613 v
->contents
[i
] = init
;
3614 XSETVECTOR (vec
, v
);
3619 /***********************************************************************
3621 ***********************************************************************/
3623 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3624 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3625 KEY2 are the same. */
3628 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3630 return (FLOATP (key1
)
3632 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3636 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3637 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3638 KEY2 are the same. */
3641 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3643 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3647 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3648 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3649 if KEY1 and KEY2 are the same. */
3652 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3656 Lisp_Object args
[3];
3658 args
[0] = h
->user_cmp_function
;
3661 return !NILP (Ffuncall (3, args
));
3668 /* Value is a hash code for KEY for use in hash table H which uses
3669 `eq' to compare keys. The hash code returned is guaranteed to fit
3670 in a Lisp integer. */
3673 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3675 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3676 xassert ((hash
& ~INTMASK
) == 0);
3681 /* Value is a hash code for KEY for use in hash table H which uses
3682 `eql' to compare keys. The hash code returned is guaranteed to fit
3683 in a Lisp integer. */
3686 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3690 hash
= sxhash (key
, 0);
3692 hash
= XUINT (key
) ^ XTYPE (key
);
3693 xassert ((hash
& ~INTMASK
) == 0);
3698 /* Value is a hash code for KEY for use in hash table H which uses
3699 `equal' to compare keys. The hash code returned is guaranteed to fit
3700 in a Lisp integer. */
3703 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3705 unsigned hash
= sxhash (key
, 0);
3706 xassert ((hash
& ~INTMASK
) == 0);
3711 /* Value is a hash code for KEY for use in hash table H which uses as
3712 user-defined function to compare keys. The hash code returned is
3713 guaranteed to fit in a Lisp integer. */
3716 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3718 Lisp_Object args
[2], hash
;
3720 args
[0] = h
->user_hash_function
;
3722 hash
= Ffuncall (2, args
);
3723 if (!INTEGERP (hash
))
3724 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3725 return XUINT (hash
);
3729 /* Create and initialize a new hash table.
3731 TEST specifies the test the hash table will use to compare keys.
3732 It must be either one of the predefined tests `eq', `eql' or
3733 `equal' or a symbol denoting a user-defined test named TEST with
3734 test and hash functions USER_TEST and USER_HASH.
3736 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3738 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3739 new size when it becomes full is computed by adding REHASH_SIZE to
3740 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3741 table's new size is computed by multiplying its old size with
3744 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3745 be resized when the ratio of (number of entries in the table) /
3746 (table size) is >= REHASH_THRESHOLD.
3748 WEAK specifies the weakness of the table. If non-nil, it must be
3749 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3752 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3753 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3754 Lisp_Object user_test
, Lisp_Object user_hash
)
3756 struct Lisp_Hash_Table
*h
;
3758 int index_size
, i
, sz
;
3760 /* Preconditions. */
3761 xassert (SYMBOLP (test
));
3762 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3763 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3764 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3765 xassert (FLOATP (rehash_threshold
)
3766 && XFLOATINT (rehash_threshold
) > 0
3767 && XFLOATINT (rehash_threshold
) <= 1.0);
3769 if (XFASTINT (size
) == 0)
3770 size
= make_number (1);
3772 /* Allocate a table and initialize it. */
3773 h
= allocate_hash_table ();
3775 /* Initialize hash table slots. */
3776 sz
= XFASTINT (size
);
3779 if (EQ (test
, Qeql
))
3781 h
->cmpfn
= cmpfn_eql
;
3782 h
->hashfn
= hashfn_eql
;
3784 else if (EQ (test
, Qeq
))
3787 h
->hashfn
= hashfn_eq
;
3789 else if (EQ (test
, Qequal
))
3791 h
->cmpfn
= cmpfn_equal
;
3792 h
->hashfn
= hashfn_equal
;
3796 h
->user_cmp_function
= user_test
;
3797 h
->user_hash_function
= user_hash
;
3798 h
->cmpfn
= cmpfn_user_defined
;
3799 h
->hashfn
= hashfn_user_defined
;
3803 h
->rehash_threshold
= rehash_threshold
;
3804 h
->rehash_size
= rehash_size
;
3806 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3807 h
->hash
= Fmake_vector (size
, Qnil
);
3808 h
->next
= Fmake_vector (size
, Qnil
);
3809 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3810 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3811 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3813 /* Set up the free list. */
3814 for (i
= 0; i
< sz
- 1; ++i
)
3815 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3816 h
->next_free
= make_number (0);
3818 XSET_HASH_TABLE (table
, h
);
3819 xassert (HASH_TABLE_P (table
));
3820 xassert (XHASH_TABLE (table
) == h
);
3822 /* Maybe add this hash table to the list of all weak hash tables. */
3824 h
->next_weak
= NULL
;
3827 h
->next_weak
= weak_hash_tables
;
3828 weak_hash_tables
= h
;
3835 /* Return a copy of hash table H1. Keys and values are not copied,
3836 only the table itself is. */
3839 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3842 struct Lisp_Hash_Table
*h2
;
3843 struct Lisp_Vector
*next
;
3845 h2
= allocate_hash_table ();
3846 next
= h2
->vec_next
;
3847 memcpy (h2
, h1
, sizeof *h2
);
3848 h2
->vec_next
= next
;
3849 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3850 h2
->hash
= Fcopy_sequence (h1
->hash
);
3851 h2
->next
= Fcopy_sequence (h1
->next
);
3852 h2
->index
= Fcopy_sequence (h1
->index
);
3853 XSET_HASH_TABLE (table
, h2
);
3855 /* Maybe add this hash table to the list of all weak hash tables. */
3856 if (!NILP (h2
->weak
))
3858 h2
->next_weak
= weak_hash_tables
;
3859 weak_hash_tables
= h2
;
3866 /* Resize hash table H if it's too full. If H cannot be resized
3867 because it's already too large, throw an error. */
3870 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3872 if (NILP (h
->next_free
))
3874 int old_size
= HASH_TABLE_SIZE (h
);
3875 int i
, new_size
, index_size
;
3878 if (INTEGERP (h
->rehash_size
))
3879 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3881 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3882 new_size
= max (old_size
+ 1, new_size
);
3883 index_size
= next_almost_prime ((int)
3885 / XFLOATINT (h
->rehash_threshold
)));
3886 /* Assignment to EMACS_INT stops GCC whining about limited range
3888 nsize
= max (index_size
, 2 * new_size
);
3889 if (nsize
> MOST_POSITIVE_FIXNUM
)
3890 error ("Hash table too large to resize");
3892 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3893 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3894 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3895 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3897 /* Update the free list. Do it so that new entries are added at
3898 the end of the free list. This makes some operations like
3900 for (i
= old_size
; i
< new_size
- 1; ++i
)
3901 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3903 if (!NILP (h
->next_free
))
3905 Lisp_Object last
, next
;
3907 last
= h
->next_free
;
3908 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3912 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3915 XSETFASTINT (h
->next_free
, old_size
);
3918 for (i
= 0; i
< old_size
; ++i
)
3919 if (!NILP (HASH_HASH (h
, i
)))
3921 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3922 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3923 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3924 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3930 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3931 the hash code of KEY. Value is the index of the entry in H
3932 matching KEY, or -1 if not found. */
3935 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3938 int start_of_bucket
;
3941 hash_code
= h
->hashfn (h
, key
);
3945 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3946 idx
= HASH_INDEX (h
, start_of_bucket
);
3948 /* We need not gcpro idx since it's either an integer or nil. */
3951 int i
= XFASTINT (idx
);
3952 if (EQ (key
, HASH_KEY (h
, i
))
3954 && h
->cmpfn (h
, key
, hash_code
,
3955 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3957 idx
= HASH_NEXT (h
, i
);
3960 return NILP (idx
) ? -1 : XFASTINT (idx
);
3964 /* Put an entry into hash table H that associates KEY with VALUE.
3965 HASH is a previously computed hash code of KEY.
3966 Value is the index of the entry in H matching KEY. */
3969 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3971 int start_of_bucket
, i
;
3973 xassert ((hash
& ~INTMASK
) == 0);
3975 /* Increment count after resizing because resizing may fail. */
3976 maybe_resize_hash_table (h
);
3979 /* Store key/value in the key_and_value vector. */
3980 i
= XFASTINT (h
->next_free
);
3981 h
->next_free
= HASH_NEXT (h
, i
);
3982 HASH_KEY (h
, i
) = key
;
3983 HASH_VALUE (h
, i
) = value
;
3985 /* Remember its hash code. */
3986 HASH_HASH (h
, i
) = make_number (hash
);
3988 /* Add new entry to its collision chain. */
3989 start_of_bucket
= hash
% ASIZE (h
->index
);
3990 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3991 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3996 /* Remove the entry matching KEY from hash table H, if there is one. */
3999 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4002 int start_of_bucket
;
4003 Lisp_Object idx
, prev
;
4005 hash_code
= h
->hashfn (h
, key
);
4006 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4007 idx
= HASH_INDEX (h
, start_of_bucket
);
4010 /* We need not gcpro idx, prev since they're either integers or nil. */
4013 int i
= XFASTINT (idx
);
4015 if (EQ (key
, HASH_KEY (h
, i
))
4017 && h
->cmpfn (h
, key
, hash_code
,
4018 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4020 /* Take entry out of collision chain. */
4022 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4024 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4026 /* Clear slots in key_and_value and add the slots to
4028 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4029 HASH_NEXT (h
, i
) = h
->next_free
;
4030 h
->next_free
= make_number (i
);
4032 xassert (h
->count
>= 0);
4038 idx
= HASH_NEXT (h
, i
);
4044 /* Clear hash table H. */
4047 hash_clear (struct Lisp_Hash_Table
*h
)
4051 int i
, size
= HASH_TABLE_SIZE (h
);
4053 for (i
= 0; i
< size
; ++i
)
4055 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4056 HASH_KEY (h
, i
) = Qnil
;
4057 HASH_VALUE (h
, i
) = Qnil
;
4058 HASH_HASH (h
, i
) = Qnil
;
4061 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4062 ASET (h
->index
, i
, Qnil
);
4064 h
->next_free
= make_number (0);
4071 /************************************************************************
4073 ************************************************************************/
4076 init_weak_hash_tables (void)
4078 weak_hash_tables
= NULL
;
4081 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4082 entries from the table that don't survive the current GC.
4083 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4084 non-zero if anything was marked. */
4087 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
4089 int bucket
, n
, marked
;
4091 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4094 for (bucket
= 0; bucket
< n
; ++bucket
)
4096 Lisp_Object idx
, next
, prev
;
4098 /* Follow collision chain, removing entries that
4099 don't survive this garbage collection. */
4101 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4103 int i
= XFASTINT (idx
);
4104 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4105 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4108 if (EQ (h
->weak
, Qkey
))
4109 remove_p
= !key_known_to_survive_p
;
4110 else if (EQ (h
->weak
, Qvalue
))
4111 remove_p
= !value_known_to_survive_p
;
4112 else if (EQ (h
->weak
, Qkey_or_value
))
4113 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4114 else if (EQ (h
->weak
, Qkey_and_value
))
4115 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4119 next
= HASH_NEXT (h
, i
);
4121 if (remove_entries_p
)
4125 /* Take out of collision chain. */
4127 HASH_INDEX (h
, bucket
) = next
;
4129 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4131 /* Add to free list. */
4132 HASH_NEXT (h
, i
) = h
->next_free
;
4135 /* Clear key, value, and hash. */
4136 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4137 HASH_HASH (h
, i
) = Qnil
;
4150 /* Make sure key and value survive. */
4151 if (!key_known_to_survive_p
)
4153 mark_object (HASH_KEY (h
, i
));
4157 if (!value_known_to_survive_p
)
4159 mark_object (HASH_VALUE (h
, i
));
4170 /* Remove elements from weak hash tables that don't survive the
4171 current garbage collection. Remove weak tables that don't survive
4172 from Vweak_hash_tables. Called from gc_sweep. */
4175 sweep_weak_hash_tables (void)
4177 struct Lisp_Hash_Table
*h
, *used
, *next
;
4180 /* Mark all keys and values that are in use. Keep on marking until
4181 there is no more change. This is necessary for cases like
4182 value-weak table A containing an entry X -> Y, where Y is used in a
4183 key-weak table B, Z -> Y. If B comes after A in the list of weak
4184 tables, X -> Y might be removed from A, although when looking at B
4185 one finds that it shouldn't. */
4189 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4191 if (h
->size
& ARRAY_MARK_FLAG
)
4192 marked
|= sweep_weak_table (h
, 0);
4197 /* Remove tables and entries that aren't used. */
4198 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4200 next
= h
->next_weak
;
4202 if (h
->size
& ARRAY_MARK_FLAG
)
4204 /* TABLE is marked as used. Sweep its contents. */
4206 sweep_weak_table (h
, 1);
4208 /* Add table to the list of used weak hash tables. */
4209 h
->next_weak
= used
;
4214 weak_hash_tables
= used
;
4219 /***********************************************************************
4220 Hash Code Computation
4221 ***********************************************************************/
4223 /* Maximum depth up to which to dive into Lisp structures. */
4225 #define SXHASH_MAX_DEPTH 3
4227 /* Maximum length up to which to take list and vector elements into
4230 #define SXHASH_MAX_LEN 7
4232 /* Combine two integers X and Y for hashing. */
4234 #define SXHASH_COMBINE(X, Y) \
4235 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4239 /* Return a hash for string PTR which has length LEN. The hash
4240 code returned is guaranteed to fit in a Lisp integer. */
4243 sxhash_string (unsigned char *ptr
, int len
)
4245 unsigned char *p
= ptr
;
4246 unsigned char *end
= p
+ len
;
4255 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4258 return hash
& INTMASK
;
4262 /* Return a hash for list LIST. DEPTH is the current depth in the
4263 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4266 sxhash_list (Lisp_Object list
, int depth
)
4271 if (depth
< SXHASH_MAX_DEPTH
)
4273 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4274 list
= XCDR (list
), ++i
)
4276 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4277 hash
= SXHASH_COMBINE (hash
, hash2
);
4282 unsigned hash2
= sxhash (list
, depth
+ 1);
4283 hash
= SXHASH_COMBINE (hash
, hash2
);
4290 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4291 the Lisp structure. */
4294 sxhash_vector (Lisp_Object vec
, int depth
)
4296 unsigned hash
= ASIZE (vec
);
4299 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4300 for (i
= 0; i
< n
; ++i
)
4302 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4303 hash
= SXHASH_COMBINE (hash
, hash2
);
4310 /* Return a hash for bool-vector VECTOR. */
4313 sxhash_bool_vector (Lisp_Object vec
)
4315 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4318 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4319 for (i
= 0; i
< n
; ++i
)
4320 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4326 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4327 structure. Value is an unsigned integer clipped to INTMASK. */
4330 sxhash (Lisp_Object obj
, int depth
)
4334 if (depth
> SXHASH_MAX_DEPTH
)
4337 switch (XTYPE (obj
))
4348 obj
= SYMBOL_NAME (obj
);
4352 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4355 /* This can be everything from a vector to an overlay. */
4356 case Lisp_Vectorlike
:
4358 /* According to the CL HyperSpec, two arrays are equal only if
4359 they are `eq', except for strings and bit-vectors. In
4360 Emacs, this works differently. We have to compare element
4362 hash
= sxhash_vector (obj
, depth
);
4363 else if (BOOL_VECTOR_P (obj
))
4364 hash
= sxhash_bool_vector (obj
);
4366 /* Others are `equal' if they are `eq', so let's take their
4372 hash
= sxhash_list (obj
, depth
);
4377 double val
= XFLOAT_DATA (obj
);
4378 unsigned char *p
= (unsigned char *) &val
;
4379 unsigned char *e
= p
+ sizeof val
;
4380 for (hash
= 0; p
< e
; ++p
)
4381 hash
= SXHASH_COMBINE (hash
, *p
);
4389 return hash
& INTMASK
;
4394 /***********************************************************************
4396 ***********************************************************************/
4399 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4400 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4403 unsigned hash
= sxhash (obj
, 0);
4404 return make_number (hash
);
4408 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4409 doc
: /* Create and return a new hash table.
4411 Arguments are specified as keyword/argument pairs. The following
4412 arguments are defined:
4414 :test TEST -- TEST must be a symbol that specifies how to compare
4415 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4416 `equal'. User-supplied test and hash functions can be specified via
4417 `define-hash-table-test'.
4419 :size SIZE -- A hint as to how many elements will be put in the table.
4422 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4423 fills up. If REHASH-SIZE is an integer, add that many space. If it
4424 is a float, it must be > 1.0, and the new size is computed by
4425 multiplying the old size with that factor. Default is 1.5.
4427 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4428 Resize the hash table when ratio of the number of entries in the
4429 table. Default is 0.8.
4431 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4432 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4433 returned is a weak table. Key/value pairs are removed from a weak
4434 hash table when there are no non-weak references pointing to their
4435 key, value, one of key or value, or both key and value, depending on
4436 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4439 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4440 (int nargs
, Lisp_Object
*args
)
4442 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4443 Lisp_Object user_test
, user_hash
;
4447 /* The vector `used' is used to keep track of arguments that
4448 have been consumed. */
4449 used
= (char *) alloca (nargs
* sizeof *used
);
4450 memset (used
, 0, nargs
* sizeof *used
);
4452 /* See if there's a `:test TEST' among the arguments. */
4453 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4454 test
= i
< 0 ? Qeql
: args
[i
];
4455 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4457 /* See if it is a user-defined test. */
4460 prop
= Fget (test
, Qhash_table_test
);
4461 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4462 signal_error ("Invalid hash table test", test
);
4463 user_test
= XCAR (prop
);
4464 user_hash
= XCAR (XCDR (prop
));
4467 user_test
= user_hash
= Qnil
;
4469 /* See if there's a `:size SIZE' argument. */
4470 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4471 size
= i
< 0 ? Qnil
: args
[i
];
4473 size
= make_number (DEFAULT_HASH_SIZE
);
4474 else if (!INTEGERP (size
) || XINT (size
) < 0)
4475 signal_error ("Invalid hash table size", size
);
4477 /* Look for `:rehash-size SIZE'. */
4478 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4479 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4480 if (!NUMBERP (rehash_size
)
4481 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4482 || XFLOATINT (rehash_size
) <= 1.0)
4483 signal_error ("Invalid hash table rehash size", rehash_size
);
4485 /* Look for `:rehash-threshold THRESHOLD'. */
4486 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4487 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4488 if (!FLOATP (rehash_threshold
)
4489 || XFLOATINT (rehash_threshold
) <= 0.0
4490 || XFLOATINT (rehash_threshold
) > 1.0)
4491 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4493 /* Look for `:weakness WEAK'. */
4494 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4495 weak
= i
< 0 ? Qnil
: args
[i
];
4497 weak
= Qkey_and_value
;
4500 && !EQ (weak
, Qvalue
)
4501 && !EQ (weak
, Qkey_or_value
)
4502 && !EQ (weak
, Qkey_and_value
))
4503 signal_error ("Invalid hash table weakness", weak
);
4505 /* Now, all args should have been used up, or there's a problem. */
4506 for (i
= 0; i
< nargs
; ++i
)
4508 signal_error ("Invalid argument list", args
[i
]);
4510 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4511 user_test
, user_hash
);
4515 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4516 doc
: /* Return a copy of hash table TABLE. */)
4519 return copy_hash_table (check_hash_table (table
));
4523 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4524 doc
: /* Return the number of elements in TABLE. */)
4527 return make_number (check_hash_table (table
)->count
);
4531 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4532 Shash_table_rehash_size
, 1, 1, 0,
4533 doc
: /* Return the current rehash size of TABLE. */)
4536 return check_hash_table (table
)->rehash_size
;
4540 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4541 Shash_table_rehash_threshold
, 1, 1, 0,
4542 doc
: /* Return the current rehash threshold of TABLE. */)
4545 return check_hash_table (table
)->rehash_threshold
;
4549 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4550 doc
: /* Return the size of TABLE.
4551 The size can be used as an argument to `make-hash-table' to create
4552 a hash table than can hold as many elements of TABLE holds
4553 without need for resizing. */)
4556 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4557 return make_number (HASH_TABLE_SIZE (h
));
4561 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4562 doc
: /* Return the test TABLE uses. */)
4565 return check_hash_table (table
)->test
;
4569 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4571 doc
: /* Return the weakness of TABLE. */)
4574 return check_hash_table (table
)->weak
;
4578 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4579 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4582 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4586 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4587 doc
: /* Clear hash table TABLE and return it. */)
4590 hash_clear (check_hash_table (table
));
4591 /* Be compatible with XEmacs. */
4596 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4597 doc
: /* Look up KEY in TABLE and return its associated value.
4598 If KEY is not found, return DFLT which defaults to nil. */)
4599 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4601 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4602 int i
= hash_lookup (h
, key
, NULL
);
4603 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4607 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4608 doc
: /* Associate KEY with VALUE in hash table TABLE.
4609 If KEY is already present in table, replace its current value with
4611 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4613 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4617 i
= hash_lookup (h
, key
, &hash
);
4619 HASH_VALUE (h
, i
) = value
;
4621 hash_put (h
, key
, value
, hash
);
4627 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4628 doc
: /* Remove KEY from TABLE. */)
4629 (Lisp_Object key
, Lisp_Object table
)
4631 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4632 hash_remove_from_table (h
, key
);
4637 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4638 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4639 FUNCTION is called with two arguments, KEY and VALUE. */)
4640 (Lisp_Object function
, Lisp_Object table
)
4642 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4643 Lisp_Object args
[3];
4646 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4647 if (!NILP (HASH_HASH (h
, i
)))
4650 args
[1] = HASH_KEY (h
, i
);
4651 args
[2] = HASH_VALUE (h
, i
);
4659 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4660 Sdefine_hash_table_test
, 3, 3, 0,
4661 doc
: /* Define a new hash table test with name NAME, a symbol.
4663 In hash tables created with NAME specified as test, use TEST to
4664 compare keys, and HASH for computing hash codes of keys.
4666 TEST must be a function taking two arguments and returning non-nil if
4667 both arguments are the same. HASH must be a function taking one
4668 argument and return an integer that is the hash code of the argument.
4669 Hash code computation should use the whole value range of integers,
4670 including negative integers. */)
4671 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4673 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4678 /************************************************************************
4680 ************************************************************************/
4684 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4685 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4687 A message digest is a cryptographic checksum of a document, and the
4688 algorithm to calculate it is defined in RFC 1321.
4690 The two optional arguments START and END are character positions
4691 specifying for which part of OBJECT the message digest should be
4692 computed. If nil or omitted, the digest is computed for the whole
4695 The MD5 message digest is computed from the result of encoding the
4696 text in a coding system, not directly from the internal Emacs form of
4697 the text. The optional fourth argument CODING-SYSTEM specifies which
4698 coding system to encode the text with. It should be the same coding
4699 system that you used or will use when actually writing the text into a
4702 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4703 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4704 system would be chosen by default for writing this text into a file.
4706 If OBJECT is a string, the most preferred coding system (see the
4707 command `prefer-coding-system') is used.
4709 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4710 guesswork fails. Normally, an error is signaled in such case. */)
4711 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4713 unsigned char digest
[16];
4714 unsigned char value
[33];
4718 int start_char
= 0, end_char
= 0;
4719 int start_byte
= 0, end_byte
= 0;
4721 register struct buffer
*bp
;
4724 if (STRINGP (object
))
4726 if (NILP (coding_system
))
4728 /* Decide the coding-system to encode the data with. */
4730 if (STRING_MULTIBYTE (object
))
4731 /* use default, we can't guess correct value */
4732 coding_system
= preferred_coding_system ();
4734 coding_system
= Qraw_text
;
4737 if (NILP (Fcoding_system_p (coding_system
)))
4739 /* Invalid coding system. */
4741 if (!NILP (noerror
))
4742 coding_system
= Qraw_text
;
4744 xsignal1 (Qcoding_system_error
, coding_system
);
4747 if (STRING_MULTIBYTE (object
))
4748 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4750 size
= SCHARS (object
);
4751 size_byte
= SBYTES (object
);
4755 CHECK_NUMBER (start
);
4757 start_char
= XINT (start
);
4762 start_byte
= string_char_to_byte (object
, start_char
);
4768 end_byte
= size_byte
;
4774 end_char
= XINT (end
);
4779 end_byte
= string_char_to_byte (object
, end_char
);
4782 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4783 args_out_of_range_3 (object
, make_number (start_char
),
4784 make_number (end_char
));
4788 struct buffer
*prev
= current_buffer
;
4790 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4792 CHECK_BUFFER (object
);
4794 bp
= XBUFFER (object
);
4795 if (bp
!= current_buffer
)
4796 set_buffer_internal (bp
);
4802 CHECK_NUMBER_COERCE_MARKER (start
);
4810 CHECK_NUMBER_COERCE_MARKER (end
);
4815 temp
= b
, b
= e
, e
= temp
;
4817 if (!(BEGV
<= b
&& e
<= ZV
))
4818 args_out_of_range (start
, end
);
4820 if (NILP (coding_system
))
4822 /* Decide the coding-system to encode the data with.
4823 See fileio.c:Fwrite-region */
4825 if (!NILP (Vcoding_system_for_write
))
4826 coding_system
= Vcoding_system_for_write
;
4829 int force_raw_text
= 0;
4831 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4832 if (NILP (coding_system
)
4833 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4835 coding_system
= Qnil
;
4836 if (NILP (current_buffer
->enable_multibyte_characters
))
4840 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4842 /* Check file-coding-system-alist. */
4843 Lisp_Object args
[4], val
;
4845 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4846 args
[3] = Fbuffer_file_name(object
);
4847 val
= Ffind_operation_coding_system (4, args
);
4848 if (CONSP (val
) && !NILP (XCDR (val
)))
4849 coding_system
= XCDR (val
);
4852 if (NILP (coding_system
)
4853 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4855 /* If we still have not decided a coding system, use the
4856 default value of buffer-file-coding-system. */
4857 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4861 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4862 /* Confirm that VAL can surely encode the current region. */
4863 coding_system
= call4 (Vselect_safe_coding_system_function
,
4864 make_number (b
), make_number (e
),
4865 coding_system
, Qnil
);
4868 coding_system
= Qraw_text
;
4871 if (NILP (Fcoding_system_p (coding_system
)))
4873 /* Invalid coding system. */
4875 if (!NILP (noerror
))
4876 coding_system
= Qraw_text
;
4878 xsignal1 (Qcoding_system_error
, coding_system
);
4882 object
= make_buffer_string (b
, e
, 0);
4883 if (prev
!= current_buffer
)
4884 set_buffer_internal (prev
);
4885 /* Discard the unwind protect for recovering the current
4889 if (STRING_MULTIBYTE (object
))
4890 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4893 md5_buffer (SDATA (object
) + start_byte
,
4894 SBYTES (object
) - (size_byte
- end_byte
),
4897 for (i
= 0; i
< 16; i
++)
4898 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4901 return make_string (value
, 32);
4908 /* Hash table stuff. */
4909 Qhash_table_p
= intern_c_string ("hash-table-p");
4910 staticpro (&Qhash_table_p
);
4911 Qeq
= intern_c_string ("eq");
4913 Qeql
= intern_c_string ("eql");
4915 Qequal
= intern_c_string ("equal");
4916 staticpro (&Qequal
);
4917 QCtest
= intern_c_string (":test");
4918 staticpro (&QCtest
);
4919 QCsize
= intern_c_string (":size");
4920 staticpro (&QCsize
);
4921 QCrehash_size
= intern_c_string (":rehash-size");
4922 staticpro (&QCrehash_size
);
4923 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4924 staticpro (&QCrehash_threshold
);
4925 QCweakness
= intern_c_string (":weakness");
4926 staticpro (&QCweakness
);
4927 Qkey
= intern_c_string ("key");
4929 Qvalue
= intern_c_string ("value");
4930 staticpro (&Qvalue
);
4931 Qhash_table_test
= intern_c_string ("hash-table-test");
4932 staticpro (&Qhash_table_test
);
4933 Qkey_or_value
= intern_c_string ("key-or-value");
4934 staticpro (&Qkey_or_value
);
4935 Qkey_and_value
= intern_c_string ("key-and-value");
4936 staticpro (&Qkey_and_value
);
4939 defsubr (&Smake_hash_table
);
4940 defsubr (&Scopy_hash_table
);
4941 defsubr (&Shash_table_count
);
4942 defsubr (&Shash_table_rehash_size
);
4943 defsubr (&Shash_table_rehash_threshold
);
4944 defsubr (&Shash_table_size
);
4945 defsubr (&Shash_table_test
);
4946 defsubr (&Shash_table_weakness
);
4947 defsubr (&Shash_table_p
);
4948 defsubr (&Sclrhash
);
4949 defsubr (&Sgethash
);
4950 defsubr (&Sputhash
);
4951 defsubr (&Sremhash
);
4952 defsubr (&Smaphash
);
4953 defsubr (&Sdefine_hash_table_test
);
4955 Qstring_lessp
= intern_c_string ("string-lessp");
4956 staticpro (&Qstring_lessp
);
4957 Qprovide
= intern_c_string ("provide");
4958 staticpro (&Qprovide
);
4959 Qrequire
= intern_c_string ("require");
4960 staticpro (&Qrequire
);
4961 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4962 staticpro (&Qyes_or_no_p_history
);
4963 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4964 staticpro (&Qcursor_in_echo_area
);
4965 Qwidget_type
= intern_c_string ("widget-type");
4966 staticpro (&Qwidget_type
);
4968 staticpro (&string_char_byte_cache_string
);
4969 string_char_byte_cache_string
= Qnil
;
4971 require_nesting_list
= Qnil
;
4972 staticpro (&require_nesting_list
);
4974 Fset (Qyes_or_no_p_history
, Qnil
);
4976 DEFVAR_LISP ("features", &Vfeatures
,
4977 doc
: /* A list of symbols which are the features of the executing Emacs.
4978 Used by `featurep' and `require', and altered by `provide'. */);
4979 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4980 Qsubfeatures
= intern_c_string ("subfeatures");
4981 staticpro (&Qsubfeatures
);
4983 #ifdef HAVE_LANGINFO_CODESET
4984 Qcodeset
= intern_c_string ("codeset");
4985 staticpro (&Qcodeset
);
4986 Qdays
= intern_c_string ("days");
4988 Qmonths
= intern_c_string ("months");
4989 staticpro (&Qmonths
);
4990 Qpaper
= intern_c_string ("paper");
4991 staticpro (&Qpaper
);
4992 #endif /* HAVE_LANGINFO_CODESET */
4994 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4995 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4996 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4997 invoked by mouse clicks and mouse menu items.
4999 On some platforms, file selection dialogs are also enabled if this is
5003 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5004 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5005 This applies to commands from menus and tool bar buttons even when
5006 they are initiated from the keyboard. If `use-dialog-box' is nil,
5007 that disables the use of a file dialog, regardless of the value of
5009 use_file_dialog
= 1;
5011 defsubr (&Sidentity
);
5014 defsubr (&Ssafe_length
);
5015 defsubr (&Sstring_bytes
);
5016 defsubr (&Sstring_equal
);
5017 defsubr (&Scompare_strings
);
5018 defsubr (&Sstring_lessp
);
5021 defsubr (&Svconcat
);
5022 defsubr (&Scopy_sequence
);
5023 defsubr (&Sstring_make_multibyte
);
5024 defsubr (&Sstring_make_unibyte
);
5025 defsubr (&Sstring_as_multibyte
);
5026 defsubr (&Sstring_as_unibyte
);
5027 defsubr (&Sstring_to_multibyte
);
5028 defsubr (&Sstring_to_unibyte
);
5029 defsubr (&Scopy_alist
);
5030 defsubr (&Ssubstring
);
5031 defsubr (&Ssubstring_no_properties
);
5044 defsubr (&Snreverse
);
5045 defsubr (&Sreverse
);
5047 defsubr (&Splist_get
);
5049 defsubr (&Splist_put
);
5051 defsubr (&Slax_plist_get
);
5052 defsubr (&Slax_plist_put
);
5055 defsubr (&Sequal_including_properties
);
5056 defsubr (&Sfillarray
);
5057 defsubr (&Sclear_string
);
5061 defsubr (&Smapconcat
);
5062 defsubr (&Sy_or_n_p
);
5063 defsubr (&Syes_or_no_p
);
5064 defsubr (&Sload_average
);
5065 defsubr (&Sfeaturep
);
5066 defsubr (&Srequire
);
5067 defsubr (&Sprovide
);
5068 defsubr (&Splist_member
);
5069 defsubr (&Swidget_put
);
5070 defsubr (&Swidget_get
);
5071 defsubr (&Swidget_apply
);
5072 defsubr (&Sbase64_encode_region
);
5073 defsubr (&Sbase64_decode_region
);
5074 defsubr (&Sbase64_encode_string
);
5075 defsubr (&Sbase64_decode_string
);
5077 defsubr (&Slocale_info
);
5086 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5087 (do not change this comment) */